ada: Remove dependence on secondary stack for type with controlled component

There are cases where GNAT introduces a dependence on the secondary stack
in a build-in-place function with a result subtype that is definite, when
this dependence could be avoided.  In particular this is done for record
types that requires finalization due to having a controlled component.

At one time such functions required the secondary stack in order to
properly handle cases where the function might raise an exception
(to avoid improper finalization in the caller), but that is no longer
necessary.  We remove the dependence of these functions on the SS,
along with the BIPalloc formal and the generation of the big if_statement
that uses that formal.

An additional small change is to revise the condition for determining when
to generate SS mark/release within functions.

gcc/ada/ChangeLog:

	* exp_ch6.ads (Make_Build_In_Place_Call_In_Allocator): Simplify comment.
	* exp_ch6.adb (Make_Build_In_Place_Call_In_Allocator): Remove obsolete
	comment about not being able to allocate fixed-size controlled results
	on the caller side, and replace another obsolete comment with a simpler
	comment. Call Build_Allocate_Deallocate_Proc when the function doesn't
	need a BIPalloc formal to ensure that function results with controlled
	parts allocated on the caller side will be chained for finalization.
	(Make_Build_In_Place_Call_In_Object_Declaration): Call Needs_BIP_Collection
	on the function's Entity_Id rather than the function call.
	(Needs_BIP_Collection): If a BIP function doesn't need a BIPalloc formal
	then it doesn't need a BIP collection either; return False in that case.
	(Needs_BIP_Alloc_Form): Remove test of Needs_BIP_Collection.
	* exp_ch7.adb (Expand_Cleanup_Actions): Move test of Uses_Sec_Stack
	to be the first conjunct in setting of Needs_Sec_Stack_Mark, and put
	the other tests in a disjunction subsidiary to that. Improve preceding
	comment.

diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb
index 5056b1f990fa47206b8f936634ce454bdf92bb27..58361e10bd9cf1c1f88111133c85a35f07711afc 100644 (file)
--- a/gcc/ada/exp_ch6.adb
+++ b/gcc/ada/exp_ch6.adb
@@ -9093,27 +9093,6 @@ package body Exp_Ch6 is
       --  tagged, the called function itself must perform the allocation of
       --  the return object, so we pass parameters indicating that.
 
-      --  But that's also the case when the result subtype needs finalization
-      --  actions because the caller side allocation may result in undesirable
-      --  finalization. Consider the following example:
-      --
-      --    function Make_Lim_Ctrl return Lim_Ctrl is
-      --    begin
-      --       return Result : Lim_Ctrl := raise Program_Error do
-      --          null;
-      --       end return;
-      --    end Make_Lim_Ctrl;
-      --
-      --    Obj : Lim_Ctrl_Ptr := new Lim_Ctrl'(Make_Lim_Ctrl);
-      --
-      --  Even though the size of limited controlled type Lim_Ctrl is known,
-      --  allocating Obj at the caller side will chain Obj on Lim_Ctrl_Ptr's
-      --  finalization collection. The subsequent call to Make_Lim_Ctrl will
-      --  fail during the initialization actions for Result, which means that
-      --  Result (and Obj by extension) should not be finalized. However Obj
-      --  will be finalized when access type Lim_Ctrl_Ptr goes out of scope
-      --  since it is already attached on the its finalization collection.
-
       if Needs_BIP_Alloc_Form (Function_Id) then
          Temp_Init := Empty;
 
@@ -9278,11 +9257,7 @@ package body Exp_Ch6 is
          end if;
       end;
 
-      --  When the function has a controlling result, an allocation-form
-      --  parameter must be passed indicating that the caller is allocating
-      --  the result object. This is needed because such a function can be
-      --  called as a dispatching operation and must be treated similarly
-      --  to functions with unconstrained result subtypes.
+      --  Add implicit actuals for the BIP formal parameters, if any
 
       Add_Unconstrained_Actuals_To_Build_In_Place_Call
         (Func_Call,
@@ -9307,6 +9282,14 @@ package body Exp_Ch6 is
       Add_Access_Actual_To_Build_In_Place_Call
         (Func_Call, Function_Id, Return_Obj_Actual);
 
+      --  If the allocation is done in the caller, create a custom Allocate
+      --  procedure if need be.
+
+      if not Needs_BIP_Alloc_Form (Function_Id) then
+         Build_Allocate_Deallocate_Proc
+           (Declaration_Node (Return_Obj_Access), Mark => Allocator);
+      end if;
+
       --  Finally, replace the allocator node with a reference to the temp
 
       Rewrite (Allocator, New_Occurrence_Of (Return_Obj_Access, Loc));
@@ -9768,7 +9751,7 @@ package body Exp_Ch6 is
          --  ensure that the heap allocation can properly chain the object
          --  and later finalize it when the library unit goes out of scope.
 
-         if Needs_BIP_Collection (Func_Call) then
+         if Needs_BIP_Collection (Function_Id) then
             Build_Finalization_Collection
               (Typ            => Ptr_Typ,
                For_Lib_Level  => True,
@@ -10331,6 +10314,12 @@ package body Exp_Ch6 is
       Typ : constant Entity_Id := Underlying_Type (Etype (Func_Id));
 
    begin
+      --  No need for BIP_Collection if allocation is always done in the caller
+
+      if not Needs_BIP_Alloc_Form (Func_Id) then
+         return False;
+      end if;
+
       --  A formal for the finalization collection is needed for build-in-place
       --  functions whose result type needs finalization or is a tagged type.
       --  Tagged primitive build-in-place functions need such a formal because
@@ -10355,12 +10344,6 @@ package body Exp_Ch6 is
       Typ : constant Entity_Id := Underlying_Type (Etype (Func_Id));
 
    begin
-      --  See Make_Build_In_Place_Call_In_Allocator for the rationale
-
-      if Needs_BIP_Collection (Func_Id) then
-         return True;
-      end if;
-
       --  A formal giving the allocation method is needed for build-in-place
       --  functions whose result type is returned on the secondary stack or
       --  is a tagged type. Tagged primitive build-in-place functions need

diff --git a/gcc/ada/exp_ch6.ads b/gcc/ada/exp_ch6.ads
index 5919627a4e7e1ea572eca5fec36a9d9eebcdf28f..3867270e71a9e05f02c3945737fbd1de095bf0cd 100644 (file)
--- a/gcc/ada/exp_ch6.ads
+++ b/gcc/ada/exp_ch6.ads
@@ -301,10 +301,8 @@ package Exp_Ch6 is
    --  BIP_Alloc_Form parameter (see type BIP_Formal_Kind).
 
    function Needs_BIP_Collection (Func_Id : Entity_Id) return Boolean;
-   --  Ada 2005 (AI-318-02): Return True if the result subtype of function
-   --  Func_Id might need finalization actions. This includes build-in-place
-   --  functions with tagged result types, since they can be invoked via
-   --  dispatching calls, and descendant types may require finalization.
+   --  Ada 2005 (AI-318-02): Return True if the function needs an implicit
+   --  BIP_Collection parameter (see type BIP_Formal_Kind).
 
    function Needs_BIP_Task_Actuals (Func_Id : Entity_Id) return Boolean;
    --  Return True if the function returns an object of a type that has tasks.

diff --git a/gcc/ada/exp_ch7.adb b/gcc/ada/exp_ch7.adb
index 62e9d2cbb73f793f452d56ae88fec47171fe5d93..d60c6edecdfff81a4b02683da900cacc011ea5f5 100644 (file)
--- a/gcc/ada/exp_ch7.adb
+++ b/gcc/ada/exp_ch7.adb
@@ -4758,18 +4758,18 @@ package body Exp_Ch7 is
 
       --  We mark the secondary stack if it is used in this construct, and
       --  we're not returning a function result on the secondary stack, except
-      --  that a build-in-place function that might or might not return on the
-      --  secondary stack always needs a mark. A run-time test is required in
-      --  the case where the build-in-place function has a BIP_Alloc extra
-      --  parameter (see Create_Finalizer).
+      --  that a build-in-place function that only conditionally returns on
+      --  the secondary stack will also need a mark. A run-time test for doing
+      --  the release call is needed in the case where the build-in-place
+      --  function has a BIP_Alloc_Form parameter (see Create_Finalizer).
 
       Needs_Sec_Stack_Mark   : constant Boolean :=
-                                   (Uses_Sec_Stack (Scop)
-                                     and then
-                                       not Sec_Stack_Needed_For_Return (Scop))
-                                 or else
-                                   (Is_Build_In_Place_Function (Scop)
-                                     and then Needs_BIP_Alloc_Form (Scop));
+                                 Uses_Sec_Stack (Scop)
+                                   and then
+                                 (not Sec_Stack_Needed_For_Return (Scop)
+                                   or else
+                                     (Is_Build_In_Place_Function (Scop)
+                                       and then Needs_BIP_Alloc_Form (Scop)));
 
       Needs_Custom_Cleanup   : constant Boolean :=
                                  Nkind (N) = N_Block_Statement