exp_ch6.ads (BIP_Storage_Pool): New "extra implicit parameter" that gets passed…

exp_ch6.ads (BIP_Storage_Pool): New "extra implicit parameter" that gets passed in the same cases where...

2011-10-13  Bob Duff  <duff@adacore.com>

	* exp_ch6.ads (BIP_Storage_Pool): New "extra implicit parameter"
	that gets passed in the same cases where BIP_Alloc_Form is passed
	(caller-unknown-size results). BIP_Storage_Pool is used when
	BIP_Alloc_Form = User_Storage_Pool.  In that case, a pointer
	to the user-defined storage pool is passed at the call site,
	and this pool is used in callee to allocate the result.
	* exp_ch6.adb (Add_Unconstrained_Actuals_To_Build_In_Place_Call): New
	version of Add_Alloc_Form_Actual_To_Build_In_Place_Call. Passes
	the additional BIP_Storage_Pool actual.
	(Expand_N_Extended_Return_Statement): Allocate the function
	result using the user-defined storage pool, if BIP_Alloc_Form =
	User_Storage_Pool.
	* sem_ch6.adb: Add the "extra formal" for BIP_Storage_Pool.
	* exp_ch4.adb: Don't overwrite storage pool set by
	Expand_N_Extended_Return_Statement.
	* s-stopoo.ads, rtsfind.ads (Root_Storage_Pool_Ptr): New type,
	for use in build-in-place function calls within allocators
	where the access type has a user-defined storage pool.

From-SVN: r179903

gcc/ada/ChangeLog

+2011-10-13  Bob Duff  <duff@adacore.com>
+
+	* exp_ch6.ads (BIP_Storage_Pool): New "extra implicit parameter"
+	that gets passed in the same cases where BIP_Alloc_Form is passed
+	(caller-unknown-size results). BIP_Storage_Pool is used when
+	BIP_Alloc_Form = User_Storage_Pool.  In that case, a pointer
+	to the user-defined storage pool is passed at the call site,
+	and this pool is used in callee to allocate the result.
+	* exp_ch6.adb (Add_Unconstrained_Actuals_To_Build_In_Place_Call): New
+	version of Add_Alloc_Form_Actual_To_Build_In_Place_Call. Passes
+	the additional BIP_Storage_Pool actual.
+	(Expand_N_Extended_Return_Statement): Allocate the function
+	result using the user-defined storage pool, if BIP_Alloc_Form =
+	User_Storage_Pool.
+	* sem_ch6.adb: Add the "extra formal" for BIP_Storage_Pool.
+	* exp_ch4.adb: Don't overwrite storage pool set by
+	Expand_N_Extended_Return_Statement.
+	* s-stopoo.ads, rtsfind.ads (Root_Storage_Pool_Ptr): New type,
+	for use in build-in-place function calls within allocators
+	where the access type has a user-defined storage pool.
+
 2011-10-13  Sergey Rybin  <rybin@adacore.com>
 
 	* gnat_ugn.texi, vms_data.ads: Add an option to control enumeration

gcc/ada/exp_ch4.adb

@@ -3526,23 +3526,28 @@ package body Exp_Ch4 is
       end if;
 
       --  Set the storage pool and find the appropriate version of Allocate to
-      --  call.
+      --  call. But don't overwrite the storage pool if it is already set,
+      --  which can happen for build-in-place function returns (see
+      --  Exp_Ch4.Expand_N_Extended_Return_Statement).
 
-      Pool := Associated_Storage_Pool (Root_Type (PtrT));
-      Set_Storage_Pool (N, Pool);
+      if No (Storage_Pool (N)) then
+         Pool := Associated_Storage_Pool (Root_Type (PtrT));
 
-      if Present (Pool) then
-         if Is_RTE (Pool, RE_SS_Pool) then
-            if VM_Target = No_VM then
-               Set_Procedure_To_Call (N, RTE (RE_SS_Allocate));
-            end if;
+         if Present (Pool) then
+            Set_Storage_Pool (N, Pool);
 
-         elsif Is_Class_Wide_Type (Etype (Pool)) then
-            Set_Procedure_To_Call (N, RTE (RE_Allocate_Any));
+            if Is_RTE (Pool, RE_SS_Pool) then
+               if VM_Target = No_VM then
+                  Set_Procedure_To_Call (N, RTE (RE_SS_Allocate));
+               end if;
 
-         else
-            Set_Procedure_To_Call (N,
-              Find_Prim_Op (Etype (Pool), Name_Allocate));
+            elsif Is_Class_Wide_Type (Etype (Pool)) then
+               Set_Procedure_To_Call (N, RTE (RE_Allocate_Any));
+
+            else
+               Set_Procedure_To_Call (N,
+                 Find_Prim_Op (Etype (Pool), Name_Allocate));
+            end if;
          end if;
       end if;
 

gcc/ada/exp_ch6.ads

@@ -88,15 +88,20 @@ package Exp_Ch6 is
 
    type BIP_Formal_Kind is
    --  Ada 2005 (AI-318-02): This type defines the kinds of implicit extra
-   --  formals created for build-in-place functions. The order of the above
+   --  formals created for build-in-place functions. The order of these
    --  enumeration literals matches the order in which the formals are
    --  declared. See Sem_Ch6.Create_Extra_Formals.
 
      (BIP_Alloc_Form,
-      --  Present if result subtype is unconstrained, or if the result type
-      --  is tagged. Indicates whether the return object is allocated by the
-      --  caller or callee, and if the callee, whether to use the secondary
-      --  stack or the heap. See Create_Extra_Formals.
+      --  Present if result subtype is unconstrained or tagged. Indicates
+      --  whether the return object is allocated by the caller or callee, and
+      --  if the callee, whether to use the secondary stack or the heap. See
+      --  Create_Extra_Formals.
+
+      BIP_Storage_Pool,
+      --  Present if result subtype is unconstrained or tagged. If
+      --  BIP_Alloc_Form = User_Storage_Pool, this is a pointer to the pool
+      --  (of type access to Root_Storage_Pool'Class). Otherwise null.
 
       BIP_Finalization_Master,
       --  Present if result type needs finalization. Pointer to caller's
@@ -114,8 +119,7 @@ package Exp_Ch6 is
       --  the return object, or null if BIP_Alloc_Form indicates allocated by
       --  callee.
       --
-      --  ??? We also need to be able to pass in some way to access a user-
-      --  defined storage pool at some point. And perhaps a constrained flag.
+      --  ??? We might also need to be able to pass in a constrained flag.
 
    function BIP_Formal_Suffix (Kind : BIP_Formal_Kind) return String;
    --  Ada 2005 (AI-318-02): Returns a string to be used as the suffix of names

gcc/ada/rtsfind.ads

@@ -1346,6 +1346,7 @@ package Rtsfind is
      RE_Storage_Offset,                  -- System.Storage_Elements
      RE_To_Address,                      -- System.Storage_Elements
 
+     RE_Root_Storage_Pool_Ptr,           -- System.Storage_Pools
      RE_Allocate_Any,                    -- System.Storage_Pools
      RE_Deallocate_Any,                  -- System.Storage_Pools
      RE_Root_Storage_Pool,               -- System.Storage_Pools
@@ -2542,6 +2543,7 @@ package Rtsfind is
      RE_Storage_Offset                   => System_Storage_Elements,
      RE_To_Address                       => System_Storage_Elements,
 
+     RE_Root_Storage_Pool_Ptr            => System_Storage_Pools,
      RE_Allocate_Any                     => System_Storage_Pools,
      RE_Deallocate_Any                   => System_Storage_Pools,
      RE_Root_Storage_Pool                => System_Storage_Pools,

gcc/ada/s-stopoo.ads

@@ -65,6 +65,14 @@ private
    type Root_Storage_Pool is abstract
      new Ada.Finalization.Limited_Controlled with null record;
 
+   type Root_Storage_Pool_Ptr is access all Root_Storage_Pool'Class;
+   for Root_Storage_Pool_Ptr'Storage_Size use 0;
+   --  Type of the BIP_Storage_Pool extra parameter (see Exp_Ch6). The
+   --  Storage_Size clause is necessary, because otherwise we have a
+   --  chicken&egg problem; we can't be creating collection finalization code
+   --  in this low-level package, because that involves Pool_Global, which
+   --  imports this package.
+
    --  ??? Are these two still needed? It might be possible to use Subpools.
    --  Allocate_Any_Controlled / Deallocate_Any_Controlled for non-controlled
    --  objects.

gcc/ada/sem_ch6.adb

@@ -6482,6 +6482,15 @@ package body Sem_Ch6 is
                  Add_Extra_Formal
                    (E, Standard_Natural,
                     E, BIP_Formal_Suffix (BIP_Alloc_Form));
+
+               --  Whenever we need BIP_Alloc_Form, we also need
+               --  BIP_Storage_Pool, in case BIP_Alloc_Form indicates to use a
+               --  user-defined pool.
+
+               Discard :=
+                 Add_Extra_Formal
+                   (E, RTE (RE_Root_Storage_Pool_Ptr),
+                    E, BIP_Formal_Suffix (BIP_Storage_Pool));
             end if;
 
             --  In the case of functions whose result type needs finalization,