ada: Elide copy for calls as default values of nonlimited by-reference components

This prevents a temporary from being created on the primary stack to hold
the result of the function calls before it is copied to the object being
elaborated in the nonlimited by-reference case.

That's already not done in the nonlimited non-by-reference case and there is
no reason to do it in the former case either.  The main issue are the calls
to Remove_Side_Effects in Expand_Ctrl_Function_Call (controlled case only)
and in Expand_N_Assignment_Statement, which serve various purposes including
very technical ones beside removing side effects.

The change is therefore very conservative and only removes the copy in the
case of a naked function call for the time being.

gcc/ada/ChangeLog:

	* einfo.ads (Returns_By_Ref): Fix description.
	* exp_ch3.adb (Build_Record_Init_Proc.Build_Assignment): Do not
	adjust the component manually (if need be), set No_Finalize_Actions
	instead of No_Ctrl_Actions for this purpose.  Do not adjust when
	the expression is a naked function call.
	* exp_ch5.adb (Make_Tag_Ctrl_Assignment): Document the quirks of
	the function.  Assert that the LHS of the assignment does not have
	side effects and replace calls to Duplicate_Subexpr_No_Checks with
	calls to New_Copy_Tree.  Rename local variable Asn to New_N.
	(Expand_N_Assignment_Statement): In the tagged or controlled record
	case, do remove side effects from both operands on entry.  Remove
	them in the controlled record case, except if the RHS is a function
	call and the assignment has the No_Ctrl_Actions flag set.
	* exp_ch6.adb (Expand_Ctrl_Function_Call): Bail out when the parent
	node is an assignment statement with the No_Ctrl_Actions flag set.
	* sem_util.adb (Statically_Different): Return True for a function
	call that does not return its result by reference.
	* sinfo.ads (No_Ctrl_Actions): Adjust description and add a note for
	the code generator.
	(No_Finalize_Actions): Likewise.

6 files changed, 180 insertions, 118 deletions

diff --git a/gcc/ada/einfo.ads b/gcc/ada/einfo.ads
index d283358..1946e68 100644
--- a/gcc/ada/einfo.ads
+++ b/gcc/ada/einfo.ads
@@ -4278,8 +4278,8 @@ package Einfo is
 
 --    Returns_By_Ref
 --       Defined in subprogram type entities and functions. Set if a function
---       (or an access-to-function type) returns a result by reference, either
---       because the result is built in place, or its type is by-reference.
+--       (or a function type) returns a result by reference, either because the
+--       result is built in place or its type is limited in Ada 95.
 
 --    Reverse_Bit_Order [base type only]
 --       Defined in all record type entities. Set if entity has a Bit_Order
diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb
index 9419d5d..65d8eb7 100644
--- a/gcc/ada/exp_ch3.adb
+++ b/gcc/ada/exp_ch3.adb
@@ -2618,11 +2618,10 @@ package body Exp_Ch3 is
          Default_Loc : constant Source_Ptr := Sloc (Default);
          Typ         : constant Entity_Id  := Underlying_Type (Etype (Id));
 
-         Adj_Call : Node_Id;
-         Exp      : Node_Id;
-         Exp_Q    : Node_Id;
-         Lhs      : Node_Id;
-         Res      : List_Id;
+         Exp   : Node_Id;
+         Exp_Q : Node_Id;
+         Lhs   : Node_Id;
+         Res   : List_Id;
 
       begin
          Lhs :=
@@ -2677,57 +2676,48 @@ package body Exp_Ch3 is
              Name       => Lhs,
              Expression => Exp));
 
-         Set_No_Ctrl_Actions (First (Res));
-
          Exp_Q := Unqualify (Exp);
 
-         --  Adjust the tag if tagged (because of possible view conversions).
-         --  Suppress the tag adjustment when not Tagged_Type_Expansion because
-         --  tags are represented implicitly in objects, and when the record is
-         --  initialized with a raise expression.
-
-         if Is_Tagged_Type (Typ)
-           and then Tagged_Type_Expansion
-           and then Nkind (Exp_Q) /= N_Raise_Expression
-         then
-            --  Get the relevant type for the call to
-            --  Make_Tag_Assignment_From_Type, which, for concurrent types is
-            --  their corresponding record.
-
-            declare
-               T : Entity_Id := Underlying_Type (Typ);
-            begin
-               if Ekind (T) in E_Protected_Type | E_Task_Type then
-                  T := Corresponding_Record_Type (T);
-               end if;
-
-               Append_To (Res,
-                 Make_Tag_Assignment_From_Type
-                   (Default_Loc,
-                    New_Copy_Tree (Lhs, New_Scope => Proc_Id),
-                    T));
-            end;
-         end if;
-
-         --  Adjust the component if controlled except if it is an aggregate
+         --  Adjust the component if controlled, except if it is an aggregate
          --  that will be expanded inline (but note that the case of container
-         --  aggregates does require component adjustment).
+         --  aggregates does require component adjustment), or a function call.
+         --  Note that, when we don't inhibit component adjustment, the tag
+         --  will be automatically inserted by Make_Tag_Ctrl_Assignment in the
+         --  tagged case. Otherwise, we have to generate a tag assignment here.
 
          if Needs_Finalization (Typ)
            and then (Nkind (Exp_Q) not in N_Aggregate | N_Extension_Aggregate
                       or else Is_Container_Aggregate (Exp_Q))
            and then not Is_Build_In_Place_Function_Call (Exp)
+           and then Nkind (Exp) /= N_Function_Call
          then
-            Adj_Call :=
-              Make_Adjust_Call
-                (Obj_Ref => New_Copy_Tree (Lhs),
-                 Typ     => Etype (Id));
+            Set_No_Finalize_Actions (First (Res));
+
+         else
+            Set_No_Ctrl_Actions (First (Res));
+
+            --  Adjust the tag if tagged because of possible view conversions
+
+            if Is_Tagged_Type (Typ)
+              and then Tagged_Type_Expansion
+              and then Nkind (Exp_Q) /= N_Raise_Expression
+            then
+               declare
+                  Utyp : Entity_Id := Underlying_Type (Typ);
+
+               begin
+                  --  Get the relevant type for Make_Tag_Assignment_From_Type,
+                  --  which, for concurrent types is the corresponding record.
 
-            --  Guard against a missing [Deep_]Adjust when the component type
-            --  was not properly frozen.
+                  if Ekind (Utyp) in E_Protected_Type | E_Task_Type then
+                     Utyp := Corresponding_Record_Type (Utyp);
+                  end if;
 
-            if Present (Adj_Call) then
-               Append_To (Res, Adj_Call);
+                  Append_To (Res,
+                    Make_Tag_Assignment_From_Type (Default_Loc,
+                      New_Copy_Tree (Lhs, New_Scope => Proc_Id),
+                      Utyp));
+               end;
             end if;
          end if;
 
diff --git a/gcc/ada/exp_ch5.adb b/gcc/ada/exp_ch5.adb
index 5bd61ba..39b26e0 100644
--- a/gcc/ada/exp_ch5.adb
+++ b/gcc/ada/exp_ch5.adb
@@ -196,9 +196,14 @@ package body Exp_Ch5 is
    function Make_Tag_Ctrl_Assignment (N : Node_Id) return List_Id;
    --  Generate the necessary code for controlled and tagged assignment, that
    --  is to say, finalization of the target before, adjustment of the target
-   --  after and save and restore of the tag and finalization pointers which
-   --  are not 'part of the value' and must not be changed upon assignment. N
-   --  is the original Assignment node.
+   --  after, and save and restore of the tag. N is the original assignment.
+
+   --  Note that the function relocates N and adds it to the list result, which
+   --  means that the subtrees of N are effectively detached from the main tree
+   --  until after the list result is inserted into it. That's why inserting
+   --  actions in them and, in particular, removing side effects will not work
+   --  properly. Therefore, this must be done before invoking the function, and
+   --  it assumes that side effects have been removed from the Name of N.
 
    --------------------------------------
    -- Build_Formal_Container_Iteration --
@@ -2963,19 +2968,13 @@ package body Exp_Ch5 is
         or else (Needs_Finalization (Typ) and then not Is_Array_Type (Typ))
       then
          Tagged_Case : declare
-            L                   : List_Id := No_List;
             Expand_Ctrl_Actions : constant Boolean :=
               not No_Ctrl_Actions (N)
                 and then not No_Finalize_Actions (N);
 
-         begin
-            --  In the controlled case, we ensure that function calls are
-            --  evaluated before finalizing the target. In all cases, it makes
-            --  the expansion easier if the side effects are removed first.
-
-            Remove_Side_Effects (Lhs);
-            Remove_Side_Effects (Rhs);
+            L :  List_Id := No_List;
 
+         begin
             --  Avoid recursion in the mechanism
 
             Set_Analyzed (N);
@@ -3162,40 +3161,70 @@ package body Exp_Ch5 is
                   end;
                end;
 
+            --  Untagged case
+
             else
-               L := Make_Tag_Ctrl_Assignment (N);
+               declare
+                  Needs_Self_Protection : constant Boolean :=
+                    Expand_Ctrl_Actions
+                      and then not Restriction_Active (No_Finalization)
+                      and then not Statically_Different (Lhs, Rhs);
+                  --  We can't afford to have destructive finalization actions
+                  --  in the self-assignment case, so if the target and source
+                  --  are not obviously different, we generate code to avoid
+                  --  the self-assignment case altogether.
 
-               --  We can't afford to have destructive Finalization Actions in
-               --  the Self assignment case, so if the target and the source
-               --  are not obviously different, code is generated to avoid the
-               --  self assignment case:
+               begin
+                  --  See the description of Make_Tag_Ctrl_Assignment
 
-               --    if lhs'address /= rhs'address then
-               --       <code for controlled and/or tagged assignment>
-               --    end if;
+                  Remove_Side_Effects (Lhs);
 
-               --  Skip this if Restriction (No_Finalization) is active
+                  --  Logically we would only need to remove side effects from
+                  --  the RHS when the protection against self-assignment will
+                  --  be generated below. However, in some very specific cases
+                  --  like Present (Unqual_BIP_Iface_Function_Call (Rhs)), the
+                  --  creation of the temporary is necessary to enable further
+                  --  expansion of the RHS. Therefore, we take a conservative
+                  --  stance and always do it for the time being, except when
+                  --  Expand_Ctrl_Function_Call does not do it either.
 
-               if not Statically_Different (Lhs, Rhs)
-                 and then Expand_Ctrl_Actions
-                 and then not Restriction_Active (No_Finalization)
-               then
-                  L := New_List (
-                    Make_Implicit_If_Statement (N,
-                      Condition =>
-                        Make_Op_Ne (Loc,
-                          Left_Opnd =>
-                            Make_Attribute_Reference (Loc,
-                              Prefix         => Duplicate_Subexpr (Lhs),
-                              Attribute_Name => Name_Address),
-
-                           Right_Opnd =>
-                            Make_Attribute_Reference (Loc,
-                              Prefix         => Duplicate_Subexpr (Rhs),
-                              Attribute_Name => Name_Address)),
-
-                      Then_Statements => L));
-               end if;
+                  if Nkind (Rhs) = N_Function_Call
+                    and then No_Ctrl_Actions (N)
+                  then
+                     --  We should not need protection against self-assignment
+                     --  in the case of a function call
+
+                     pragma Assert (not Needs_Self_Protection);
+
+                  else
+                     Remove_Side_Effects (Rhs);
+                  end if;
+
+                  L := Make_Tag_Ctrl_Assignment (N);
+
+                  --  Generate:
+                  --    if Lhs'Address /= Rhs'Address then
+                  --       <code for controlled and/or tagged assignment>
+                  --    end if;
+
+                  if Needs_Self_Protection then
+                     L := New_List (
+                       Make_Implicit_If_Statement (N,
+                         Condition =>
+                           Make_Op_Ne (Loc,
+                             Left_Opnd =>
+                               Make_Attribute_Reference (Loc,
+                                 Prefix         => New_Copy_Tree (Lhs),
+                                 Attribute_Name => Name_Address),
+
+                             Right_Opnd =>
+                               Make_Attribute_Reference (Loc,
+                                 Prefix         => New_Copy_Tree (Rhs),
+                                 Attribute_Name => Name_Address)),
+
+                         Then_Statements => L));
+                  end if;
+               end;
 
                --  We need to set up an exception handler for implementing
                --  7.6.1(18), but this is skipped if the type has relaxed
@@ -3215,11 +3244,16 @@ package body Exp_Ch5 is
                end if;
             end if;
 
+            --  No need for a block if there are no controlling actions
+
+            if No_Ctrl_Actions (N) and then List_Length (L) = 1 then
+               Rewrite (N, Remove_Head (L));
+
             --  We will analyze the block statement with all checks suppressed
             --  below, but we need elaboration checks for the primitives in the
             --  case of an assignment created by the expansion of an aggregate.
 
-            if No_Finalize_Actions (N) then
+            elsif No_Finalize_Actions (N) then
                Rewrite (N,
                  Make_Unsuppress_Block (Loc, Name_Elaboration_Check, L));
 
@@ -6332,7 +6366,6 @@ package body Exp_Ch5 is
    ------------------------------
 
    function Make_Tag_Ctrl_Assignment (N : Node_Id) return List_Id is
-      Asn : constant Node_Id    := Relocate_Node (N);
       L   : constant Node_Id    := Name (N);
       Loc : constant Source_Ptr := Sloc (N);
       Res : constant List_Id    := New_List;
@@ -6355,9 +6388,12 @@ package body Exp_Ch5 is
                                        and then Tagged_Type_Expansion;
       Adj_Call : Node_Id;
       Fin_Call : Node_Id;
+      New_N    : Node_Id;
       Tag_Id   : Entity_Id;
 
    begin
+      pragma Assert (Side_Effect_Free (L));
+
       --  Finalize the target of the assignment when controlled
 
       --  We have two exceptions here:
@@ -6389,9 +6425,7 @@ package body Exp_Ch5 is
 
       else
          Fin_Call :=
-           Make_Final_Call
-             (Obj_Ref => Duplicate_Subexpr_No_Checks (L),
-              Typ     => Etype (L));
+           Make_Final_Call (Obj_Ref => New_Copy_Tree (L), Typ => Etype (L));
 
          if Present (Fin_Call) then
             Append_To (Res, Fin_Call);
@@ -6409,7 +6443,7 @@ package body Exp_Ch5 is
              Object_Definition   => New_Occurrence_Of (RTE (RE_Tag), Loc),
              Expression          =>
                Make_Selected_Component (Loc,
-                 Prefix        => Duplicate_Subexpr_No_Checks (L),
+                 Prefix        => New_Copy_Tree (L),
                  Selector_Name =>
                    New_Occurrence_Of (First_Tag_Component (T), Loc))));
 
@@ -6424,12 +6458,14 @@ package body Exp_Ch5 is
       --  generate the proper code and propagate this scenario by setting a
       --  flag to avoid infinite recursion.
 
+      New_N := Relocate_Node (N);
+
       if Comp_Asn then
-         Set_Analyzed (Asn, False);
-         Set_Componentwise_Assignment (Asn, True);
+         Set_Analyzed (New_N, False);
+         Set_Componentwise_Assignment (New_N, True);
       end if;
 
-      Append_To (Res, Asn);
+      Append_To (Res, New_N);
 
       --  Restore the tag
 
@@ -6438,7 +6474,7 @@ package body Exp_Ch5 is
            Make_Assignment_Statement (Loc,
              Name       =>
                Make_Selected_Component (Loc,
-                 Prefix        => Duplicate_Subexpr_No_Checks (L),
+                 Prefix        => New_Copy_Tree (L),
                  Selector_Name =>
                    New_Occurrence_Of (First_Tag_Component (T), Loc)),
              Expression => New_Occurrence_Of (Tag_Id, Loc)));
@@ -6447,8 +6483,7 @@ package body Exp_Ch5 is
 
       elsif Set_Tag then
          Append_To (Res,
-           Make_Tag_Assignment_From_Type
-             (Loc, Duplicate_Subexpr_No_Checks (L), T));
+           Make_Tag_Assignment_From_Type (Loc, New_Copy_Tree (L), T));
       end if;
 
       --  Adjust the target after the assignment when controlled (not in the
@@ -6456,9 +6491,7 @@ package body Exp_Ch5 is
 
       if Ctrl_Act or else Adj_Act then
          Adj_Call :=
-           Make_Adjust_Call
-             (Obj_Ref => Duplicate_Subexpr_Move_Checks (L),
-              Typ     => Etype (L));
+           Make_Adjust_Call (Obj_Ref => New_Copy_Tree (L), Typ => Etype (L));
 
          if Present (Adj_Call) then
             Append_To (Res, Adj_Call);
diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb
index e6e5d50..11b954f 100644
--- a/gcc/ada/exp_ch6.adb
+++ b/gcc/ada/exp_ch6.adb
@@ -281,10 +281,17 @@ package body Exp_Ch6 is
    --  Does the main work of Expand_Call. Post_Call is as for Expand_Actuals.
 
    procedure Expand_Ctrl_Function_Call (N : Node_Id; Use_Sec_Stack : Boolean);
-   --  N is a function call which returns a controlled object. Transform the
+   --  N is a function call that returns a controlled object. Transform the
    --  call into a temporary which retrieves the returned object from the
    --  primary or secondary stack (Use_Sec_Stack says which) using 'reference.
 
+   --  This expansion is necessary in all the cases where the constant object
+   --  denoted by the call needs finalization in the current subprogram, which
+   --  excludes return statements, and is not identified with another object
+   --  that will be finalized, which excludes (statically) declared objects,
+   --  dynamically allocated objects, and targets of assignments that are done
+   --  directly (without intermediate temporaries).
+
    procedure Expand_Non_Function_Return (N : Node_Id);
    --  Expand a simple return statement found in a procedure body, entry body,
    --  accept statement, or an extended return statement. Note that all non-
@@ -5406,9 +5413,15 @@ package body Exp_Ch6 is
       end if;
 
       --  Avoid expansion to catch the error when the function call is on the
-      --  left-hand side of an assignment.
-
-      if Nkind (Par) = N_Assignment_Statement and then N = Name (Par) then
+      --  left-hand side of an assignment. Likewise if it is on the right-hand
+      --  side and no controlling actions will be performed for the assignment,
+      --  which means that this is an initialization of the target and it can
+      --  thus be performed directly. Note that the code generator should also
+      --  avoid creating a temporary for the right-hand side in this case.
+
+      if Nkind (Par) = N_Assignment_Statement
+        and then (N = Name (Par) or else No_Ctrl_Actions (Par))
+      then
          return;
       end if;
 
diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb
index c1af228..595d3d1 100644
--- a/gcc/ada/sem_util.adb
+++ b/gcc/ada/sem_util.adb
@@ -28309,11 +28309,29 @@ package body Sem_Util is
       R1 : constant Node_Id := Get_Referenced_Object (E1);
       R2 : constant Node_Id := Get_Referenced_Object (E2);
    begin
-      return     Is_Entity_Name (R1)
-        and then Is_Entity_Name (R2)
-        and then Entity (R1) /= Entity (R2)
-        and then not Is_Formal (Entity (R1))
-        and then not Is_Formal (Entity (R2));
+      --  Two identifiers are statically different if they denote different
+      --  entities that are not formal parameters.
+
+      if Is_Entity_Name (R1) and then Is_Entity_Name (R2) then
+         return Entity (R1) /= Entity (R2)
+           and then not Is_Formal (Entity (R1))
+           and then not Is_Formal (Entity (R2));
+
+      --  A function call that does not return its result by reference denotes
+      --  a constant object that is statically different from anything else.
+
+      elsif (Nkind (R1) = N_Function_Call
+              and then Is_Entity_Name (Name (R1))
+              and then not Returns_By_Ref (Entity (Name (R1))))
+        or else (Nkind (R2) = N_Function_Call
+                  and then Is_Entity_Name (Name (R2))
+                  and then not Returns_By_Ref (Entity (Name (R2))))
+      then
+         return R1 /= R2;
+
+      else
+         return False;
+      end if;
    end Statically_Different;
 
    -----------------------------
diff --git a/gcc/ada/sinfo.ads b/gcc/ada/sinfo.ads
index a092fdf..2e1ac25 100644
--- a/gcc/ada/sinfo.ads
+++ b/gcc/ada/sinfo.ads
@@ -1770,7 +1770,7 @@ package Sinfo is
    --    in interpolated expressions.
 
    --  Is_Known_Guaranteed_ABE
-   --    NOTE: this flag is shared between the legacy ABE mechanism and the
+   --    Note: this flag is shared between the legacy ABE mechanism and the
    --    default ABE mechanism.
    --
    --    Present in the following nodes:
@@ -2058,14 +2058,18 @@ package Sinfo is
    --    Present in N_Assignment_Statement to indicate that neither Finalize
    --    nor Adjust should take place on this assignment even though the LHS
    --    and RHS are controlled. Also to indicate that the primitive _assign
-   --    should not be used for a tagged assignment. This flag is used in init
-   --    proc and aggregate expansion where the generated assignments are
+   --    should not be used for a tagged assignment. This flag is only used
+   --    in initialization procedures, and the expansion of aggregates, object
+   --    declarations and allocators, where the generated assignments are
    --    initializations, not real assignments. Note that it also suppresses
    --    the creation of transient scopes around the N_Assignment_Statement,
    --    in other words it disables all controlled actions for the assignment.
+   --    Additional note: the code generator should avoid creating a temporary
+   --    for the RHS when this flag is set on the N_Assignment_Statement node,
+   --    including when this RHS is a function call.
 
    --  No_Elaboration_Check
-   --    NOTE: this flag is relevant only for the legacy ABE mechanism and
+   --    Note: this flag is relevant only for the legacy ABE mechanism and
    --    should not be used outside of that context.
    --
    --    Present in N_Function_Call and N_Procedure_Call_Statement. Indicates
@@ -2086,10 +2090,14 @@ package Sinfo is
    --    Present in N_Assignment_Statement to indicate that no Finalize should
    --    take place on this assignment even though the LHS is controlled. Also
    --    to indicate that the primitive _assign should not be used for a tagged
-   --    assignment. This flag is only used in aggregates expansion where the
-   --    generated assignments are initializations, not real assignments. Note
-   --    that, unlike the No_Ctrl_Actions flag, it does *not* suppress the
+   --    assignment. This flag is only used in initialization procedures, and
+   --    the expansion of aggregates, object declarations and allocators, where
+   --    the generated assignments are initializations, not real assignments.
+   --    Note that, unlike No_Ctrl_Actions, this flag does *not* suppress the
    --    creation of transient scopes around the N_Assignment_Statement.
+   --    Additional note: the code generator should avoid creating a temporary
+   --    for the RHS when this flag is set on the N_Assignment_Statement node,
+   --    including when this RHS is a function call.
 
    --  No_Initialization
    --    Present in N_Object_Declaration and N_Allocator to indicate that the