[Ada] Improve code generated for assignment of dynamic record aggregates

2020-06-12  Eric Botcazou  <ebotcazou@adacore.com>

gcc/ada/

	* exp_aggr.adb: Add with and use clauses for Sem_Mech.
	(Get_Base_Object): New function to get the base object of a node.
	(In_Place_Assign_OK): Add Target_Object parameter.  Deal with a
	qualified expression on entry.  Remove short-circuit for array
	aggregates with a single "others" choice.  Do not look into the
	components of the aggregate if the parent is an allocator.
	(Check_Component): Add T_OK parameter and rewrite.
	(Safe_Component): Invoke Check_Component with T_OK set to False.
	(Convert_To_Assignments): Try to use an in-place assignment for
	any target; for that, call Get_Base_Object on the target and pass
	the result to In_Place_Assign_OK.
	(Expand_Array_Aggregate): Use Parent_Kind and Parent_Node more
	consistently.  For an assignment, call Get_Base_Object on the
	target and pass the result to In_Place_Assign_OK.

1 files changed, 231 insertions, 80 deletions

diff --git a/gcc/ada/exp_aggr.adb b/gcc/ada/exp_aggr.adb
index ced0d70..22ed3ae 100644
--- a/gcc/ada/exp_aggr.adb
+++ b/gcc/ada/exp_aggr.adb
@@ -53,6 +53,7 @@ with Sem_Aggr; use Sem_Aggr;
 with Sem_Aux;  use Sem_Aux;
 with Sem_Ch3;  use Sem_Ch3;
 with Sem_Eval; use Sem_Eval;
+with Sem_Mech; use Sem_Mech;
 with Sem_Res;  use Sem_Res;
 with Sem_Util; use Sem_Util;
 with Sinfo;    use Sinfo;
@@ -86,6 +87,11 @@ package body Exp_Aggr is
    procedure Expand_Delta_Array_Aggregate  (N : Node_Id; Deltas : List_Id);
    procedure Expand_Delta_Record_Aggregate (N : Node_Id; Deltas : List_Id);
 
+   function Get_Base_Object (N : Node_Id) return Entity_Id;
+   --  Return the base object, i.e. the outermost prefix object, that N refers
+   --  to statically, or Empty if it cannot be determined. The assumption is
+   --  that all dereferences are explicit in the tree rooted at N.
+
    function Has_Default_Init_Comps (N : Node_Id) return Boolean;
    --  N is an aggregate (record or array). Checks the presence of default
    --  initialization (<>) in any component (Ada 2005: AI-287).
@@ -217,7 +223,9 @@ package body Exp_Aggr is
    --  defaults. An aggregate for a type with mutable components must be
    --  expanded into individual assignments.
 
-   function In_Place_Assign_OK (N : Node_Id) return Boolean;
+   function In_Place_Assign_OK
+     (N             : Node_Id;
+      Target_Object : Entity_Id := Empty) return Boolean;
    --  Predicate to determine whether an aggregate assignment can be done in
    --  place, because none of the new values can depend on the components of
    --  the target of the assignment.
@@ -4122,23 +4130,40 @@ package body Exp_Aggr is
    -- In_Place_Assign_OK --
    ------------------------
 
-   function In_Place_Assign_OK (N : Node_Id) return Boolean is
+   function In_Place_Assign_OK
+     (N             : Node_Id;
+      Target_Object : Entity_Id := Empty) return Boolean
+   is
       Is_Array : constant Boolean := Is_Array_Type (Etype (N));
 
-      Aggr_In : Node_Id;
-      Aggr_Lo : Node_Id;
-      Aggr_Hi : Node_Id;
-      Obj_In  : Node_Id;
-      Obj_Lo  : Node_Id;
-      Obj_Hi  : Node_Id;
+      Aggr_In     : Node_Id;
+      Aggr_Lo     : Node_Id;
+      Aggr_Hi     : Node_Id;
+      Obj_In      : Node_Id;
+      Obj_Lo      : Node_Id;
+      Obj_Hi      : Node_Id;
+      Parent_Kind : Node_Kind;
+      Parent_Node : Node_Id;
 
       function Safe_Aggregate (Aggr : Node_Id) return Boolean;
       --  Check recursively that each component of a (sub)aggregate does not
       --  depend on the variable being assigned to.
 
       function Safe_Component (Expr : Node_Id) return Boolean;
-      --  Verify that an expression cannot depend on the variable being
-      --  assigned to. Room for improvement here (but less than before).
+      --  Verify that an expression cannot depend on the target being assigned
+      --  to. Return true for compile-time known values, stand-alone objects,
+      --  parameters passed by copy, calls to functions that return by copy,
+      --  selected components thereof only if the aggregate's type is an array,
+      --  indexed components and slices thereof only if the aggregate's type is
+      --  a record, and simple expressions involving only these as operands.
+      --  This is OK whatever the target because, for a component to overlap
+      --  with the target, it must be either a direct reference to a component
+      --  of the target, in which case there must be a matching selection or
+      --  indexation or slicing, or an indirect reference to such a component,
+      --  which is excluded by the above condition. Additionally, if the target
+      --  is statically known, return true for arbitrarily nested selections,
+      --  indexations or slicings, provided that their ultimate prefix is not
+      --  the target itself.
 
       --------------------
       -- Safe_Aggregate --
@@ -4200,43 +4225,137 @@ package body Exp_Aggr is
       function Safe_Component (Expr : Node_Id) return Boolean is
          Comp : Node_Id := Expr;
 
-         function Check_Component (Comp : Node_Id) return Boolean;
-         --  Do the recursive traversal, after copy
+         function Check_Component (C : Node_Id; T_OK : Boolean) return Boolean;
+         --  Do the recursive traversal, after copy. If T_OK is True, return
+         --  True for a stand-alone object only if the target is statically
+         --  known and distinct from the object. At the top level, we start
+         --  with T_OK set to False and set it to True at a deeper level only
+         --  if we cannot disambiguate the component here without statically
+         --  knowing the target. Note that this is not optimal, we should do
+         --  something along the lines of Denotes_Same_Prefix for that.
 
          ---------------------
          -- Check_Component --
          ---------------------
 
-         function Check_Component (Comp : Node_Id) return Boolean is
+         function Check_Component (C : Node_Id; T_OK : Boolean) return Boolean
+         is
+
+            function SDO (E : Entity_Id) return Uint;
+            --  Return the Scope Depth Of the enclosing dynamic scope of E
+
+            ---------
+            -- SDO --
+            ---------
+
+            function SDO (E : Entity_Id) return Uint is
+            begin
+               return Scope_Depth (Enclosing_Dynamic_Scope (E));
+            end SDO;
+
+         --  Start of processing for Check_Component
+
          begin
-            if Is_Overloaded (Comp) then
+            if Is_Overloaded (C) then
                return False;
+
+            elsif Compile_Time_Known_Value (C) then
+               return True;
             end if;
 
-            return Compile_Time_Known_Value (Comp)
+            case Nkind (C) is
+               when N_Attribute_Reference =>
+                  return Check_Component (Prefix (C), T_OK);
+
+               when N_Function_Call =>
+                  if Nkind (Name (C)) = N_Explicit_Dereference then
+                     return not Returns_By_Ref (Etype (Name (C)));
+                  else
+                     return not Returns_By_Ref (Entity (Name (C)));
+                  end if;
+
+               when N_Indexed_Component | N_Slice =>
+                  --  In a target record, these operations cannot determine
+                  --  alone a component so we can recurse whatever the target.
+                  return Check_Component (Prefix (C), T_OK or else Is_Array);
+
+               when N_Selected_Component =>
+                  --  In a target array, this operation cannot determine alone
+                  --  a component so we can recurse whatever the target.
+                  return
+                    Check_Component (Prefix (C), T_OK or else not Is_Array);
+
+               when N_Type_Conversion | N_Unchecked_Type_Conversion =>
+                  return Check_Component (Expression (C), T_OK);
 
-              or else (Is_Entity_Name (Comp)
-                        and then Present (Entity (Comp))
-                        and then Ekind (Entity (Comp)) not in Type_Kind
-                        and then No (Renamed_Object (Entity (Comp))))
+               when N_Binary_Op =>
+                  return Check_Component (Left_Opnd (C), T_OK)
+                    and then Check_Component (Right_Opnd (C), T_OK);
 
-              or else (Nkind (Comp) = N_Attribute_Reference
-                        and then Check_Component (Prefix (Comp)))
+               when N_Unary_Op =>
+                  return Check_Component (Right_Opnd (C), T_OK);
 
-              or else (Nkind (Comp) in N_Binary_Op
-                        and then Check_Component (Left_Opnd  (Comp))
-                        and then Check_Component (Right_Opnd (Comp)))
+               when others =>
+                  if Is_Entity_Name (C) and then Is_Object (Entity (C)) then
+                     --  Case of a formal parameter component. It's either
+                     --  trivial if passed by copy or very annoying if not,
+                     --  because in the latter case it's almost equivalent
+                     --  to a dereference, so the path-based disambiguation
+                     --  logic is totally off and we always need the target.
 
-              or else (Nkind (Comp) in N_Unary_Op
-                        and then Check_Component (Right_Opnd (Comp)))
+                     if Is_Formal (Entity (C)) then
+
+                        --  If it is passed by copy, then this is safe
+
+                        if Mechanism (Entity (C)) = By_Copy then
+                           return True;
+
+                        --  Otherwise, this is safe if the target is present
+                        --  and is at least as deeply nested as the component.
+
+                        else
+                           return Present (Target_Object)
+                             and then not Is_Formal (Target_Object)
+                             and then SDO (Target_Object) >= SDO (Entity (C));
+                        end if;
+
+                     --  For a renamed object, recurse
+
+                     elsif Present (Renamed_Object (Entity (C))) then
+                        return
+                          Check_Component (Renamed_Object (Entity (C)), T_OK);
+
+                     --  If this is safe whatever the target, we are done
+
+                     elsif not T_OK then
+                        return True;
+
+                     --  If there is no target or the component is the target,
+                     --  this is not safe.
+
+                     elsif No (Target_Object)
+                       or else Entity (C) = Target_Object
+                     then
+                        return False;
+
+                     --  Case of a formal parameter target. This is safe if it
+                     --  is at most as deeply nested as the component.
+
+                     elsif Is_Formal (Target_Object) then
+                        return SDO (Target_Object) <= SDO (Entity (C));
+
+                     --  For distinct stand-alone objects, this is safe
+
+                     else
+                        return True;
+                     end if;
 
-              or else (Nkind (Comp) = N_Selected_Component
-                        and then Is_Array
-                        and then Check_Component (Prefix (Comp)))
+                  --  For anything else than an object, this is not safe
 
-              or else (Nkind_In (Comp, N_Type_Conversion,
-                                       N_Unchecked_Type_Conversion)
-                        and then Check_Component (Expression (Comp)));
+                  else
+                     return False;
+                  end if;
+            end case;
          end Check_Component;
 
       --  Start of processing for Safe_Component
@@ -4275,7 +4394,7 @@ package body Exp_Aggr is
          if Nkind (Comp) = N_Aggregate then
             return Safe_Aggregate (Comp);
          else
-            return Check_Component (Comp);
+            return Check_Component (Comp, False);
          end if;
       end Safe_Component;
 
@@ -4286,33 +4405,38 @@ package body Exp_Aggr is
 
       if Needs_Finalization (Etype (N)) then
          return False;
+      end if;
 
-      elsif Is_Array and then Present (Component_Associations (N)) then
+      Parent_Node := Parent (N);
+      Parent_Kind := Nkind (Parent_Node);
 
-         --  On assignment, sliding can take place, so we cannot do the
-         --  assignment in place unless the bounds of the aggregate are
-         --  statically equal to those of the target.
+      if Parent_Kind = N_Qualified_Expression then
+         Parent_Node := Parent (Parent_Node);
+         Parent_Kind := Nkind (Parent_Node);
+      end if;
 
-         --  If the aggregate is given by an others choice, the bounds are
-         --  derived from the left-hand side, and the assignment is safe if
-         --  the expression is.
+      --  On assignment, sliding can take place, so we cannot do the
+      --  assignment in place unless the bounds of the aggregate are
+      --  statically equal to those of the target.
 
-         if Is_Others_Aggregate (N) then
-            return
-              Safe_Component
-               (Expression (First (Component_Associations (N))));
-         end if;
+      --  If the aggregate is given by an others choice, the bounds are
+      --  derived from the left-hand side, and the assignment is safe if
+      --  the expression is.
 
+      if Is_Array
+        and then Present (Component_Associations (N))
+        and then not Is_Others_Aggregate (N)
+      then
          Aggr_In := First_Index (Etype (N));
 
-         if Nkind (Parent (N)) = N_Assignment_Statement then
-            Obj_In := First_Index (Etype (Name (Parent (N))));
+         if Parent_Kind = N_Assignment_Statement then
+            Obj_In := First_Index (Etype (Name (Parent_Node)));
 
          else
             --  Context is an allocator. Check bounds of aggregate against
             --  given type in qualified expression.
 
-            pragma Assert (Nkind (Parent (Parent (N))) = N_Allocator);
+            pragma Assert (Parent_Kind = N_Allocator);
             Obj_In := First_Index (Etype (Entity (Subtype_Mark (Parent (N)))));
          end if;
 
@@ -4320,9 +4444,12 @@ package body Exp_Aggr is
             Get_Index_Bounds (Aggr_In, Aggr_Lo, Aggr_Hi);
             Get_Index_Bounds (Obj_In, Obj_Lo, Obj_Hi);
 
-            if not Compile_Time_Known_Value (Aggr_Lo)
-              or else not Compile_Time_Known_Value (Obj_Lo)
+            --  We require static bounds for the target and a static matching
+            --  of low bound for the aggregate.
+
+            if not Compile_Time_Known_Value (Obj_Lo)
               or else not Compile_Time_Known_Value (Obj_Hi)
+              or else not Compile_Time_Known_Value (Aggr_Lo)
               or else Expr_Value (Aggr_Lo) /= Expr_Value (Obj_Lo)
             then
                return False;
@@ -4336,8 +4463,8 @@ package body Exp_Aggr is
             --  diminishing returns) for safely building arrays in place
             --  here.
 
-            elsif Nkind (Parent (N)) = N_Assignment_Statement
-              or else Is_Constrained (Etype (Parent (N)))
+            elsif Parent_Kind = N_Assignment_Statement
+              or else Is_Constrained (Etype (Parent_Node))
             then
                if not Compile_Time_Known_Value (Aggr_Hi)
                  or else Expr_Value (Aggr_Hi) /= Expr_Value (Obj_Hi)
@@ -4351,9 +4478,14 @@ package body Exp_Aggr is
          end loop;
       end if;
 
-      --  Now check the component values themselves
+      --  Now check the component values themselves, except for an allocator
+      --  for which the target is newly allocated memory.
 
-      return Safe_Aggregate (N);
+      if Parent_Kind = N_Allocator then
+         return True;
+      else
+         return Safe_Aggregate (N);
+      end if;
    end In_Place_Assign_OK;
 
    ----------------------------
@@ -4468,14 +4600,13 @@ package body Exp_Aggr is
            Build_Record_Aggr_Code (N, Typ, Target_Expr));
          Rewrite (Parent_Node, Make_Null_Statement (Loc));
 
-      --  Do not declare a temporary to initialize an aggregate assigned to an
-      --  identifier when in-place assignment is possible, preserving the
+      --  Do not declare a temporary to initialize an aggregate assigned to
+      --  a target when in-place assignment is possible, i.e. preserving the
       --  by-copy semantic of aggregates. This avoids large stack usage and
       --  generates more efficient code.
 
       elsif Parent_Kind = N_Assignment_Statement
-        and then Nkind (Name (Parent_Node)) = N_Identifier
-        and then In_Place_Assign_OK (N)
+        and then In_Place_Assign_OK (N, Get_Base_Object (Name (Parent_Node)))
       then
          declare
             Lhs : constant Node_Id := Name (Parent_Node);
@@ -6284,14 +6415,15 @@ package body Exp_Aggr is
       then
          Maybe_In_Place_OK := False;
 
-      else
+      elsif Parent_Kind = N_Assignment_Statement then
          Maybe_In_Place_OK :=
-          (Nkind (Parent (N)) = N_Assignment_Statement
-            and then In_Place_Assign_OK (N))
+           In_Place_Assign_OK (N, Get_Base_Object (Name (Parent_Node)));
+
+      elsif Parent_Kind = N_Allocator then
+         Maybe_In_Place_OK := In_Place_Assign_OK (N);
 
-            or else
-             (Nkind (Parent (Parent (N))) = N_Allocator
-              and then In_Place_Assign_OK (N));
+      else
+         Maybe_In_Place_OK := False;
       end if;
 
       --  If this is an array of tasks, it will be expanded into build-in-place
@@ -6345,10 +6477,7 @@ package body Exp_Aggr is
             Set_Etype (Tmp, Typ);
          end if;
 
-      elsif Maybe_In_Place_OK
-        and then Nkind (Parent (N)) = N_Qualified_Expression
-        and then Nkind (Parent (Parent (N))) = N_Allocator
-      then
+      elsif Maybe_In_Place_OK and then Parent_Kind = N_Allocator then
          Set_Expansion_Delayed (N);
          return;
 
@@ -6356,7 +6485,7 @@ package body Exp_Aggr is
       --  enclosing construct is expanded.
 
       elsif Maybe_In_Place_OK
-        and then Nkind (Parent (N)) = N_Simple_Return_Statement
+        and then Parent_Kind = N_Simple_Return_Statement
       then
          Set_Expansion_Delayed (N);
          return;
@@ -6364,9 +6493,9 @@ package body Exp_Aggr is
       --  In the remaining cases the aggregate is the RHS of an assignment
 
       elsif Maybe_In_Place_OK
-        and then Safe_Left_Hand_Side (Name (Parent (N)))
+        and then Safe_Left_Hand_Side (Name (Parent_Node))
       then
-         Tmp := Name (Parent (N));
+         Tmp := Name (Parent_Node);
 
          if Etype (Tmp) /= Etype (N) then
             Apply_Length_Check (N, Etype (Tmp));
@@ -6384,10 +6513,10 @@ package body Exp_Aggr is
       --  by converting it into a loop over the discrete range of the slice.
 
       elsif Maybe_In_Place_OK
-        and then Nkind (Name (Parent (N))) = N_Slice
+        and then Nkind (Name (Parent_Node)) = N_Slice
         and then Is_Others_Aggregate (N)
       then
-         Tmp := Name (Parent (N));
+         Tmp := Name (Parent_Node);
 
          --  Set type of aggregate to be type of lhs in assignment, in order
          --  to suppress redundant length checks.
@@ -6415,7 +6544,7 @@ package body Exp_Aggr is
          --  around the aggregate for this purpose.
 
          if Ekind (Current_Scope) = E_Loop
-           and then Nkind (Parent (Parent (N))) = N_Allocator
+           and then Parent_Kind = N_Allocator
          then
             Establish_Transient_Scope (N, Manage_Sec_Stack => False);
          end if;
@@ -6525,13 +6654,13 @@ package body Exp_Aggr is
       --  If the aggregate has been assigned in place, remove the original
       --  assignment.
 
-      if Nkind (Parent (N)) = N_Assignment_Statement
-        and then Maybe_In_Place_OK
-      then
-         Rewrite (Parent (N), Make_Null_Statement (Loc));
+      if Parent_Kind = N_Assignment_Statement and then Maybe_In_Place_OK then
+         Rewrite (Parent_Node, Make_Null_Statement (Loc));
+
+      --  Or else, if a temporary was created, replace the aggregate with it
 
-      elsif Nkind (Parent (N)) /= N_Object_Declaration
-        or else Tmp /= Defining_Identifier (Parent (N))
+      elsif Parent_Kind /= N_Object_Declaration
+        or else Tmp /= Defining_Identifier (Parent_Node)
       then
          Rewrite (N, New_Occurrence_Of (Tmp, Loc));
          Analyze_And_Resolve (N, Typ);
@@ -7611,6 +7740,28 @@ package body Exp_Aggr is
       end if;
    end Expand_Record_Aggregate;
 
+   ---------------------
+   -- Get_Base_Object --
+   ---------------------
+
+   function Get_Base_Object (N : Node_Id) return Entity_Id is
+      R : Node_Id;
+
+   begin
+      R := Get_Referenced_Object (N);
+
+      while Nkind_In (R, N_Indexed_Component, N_Selected_Component, N_Slice)
+      loop
+         R := Get_Referenced_Object (Prefix (R));
+      end loop;
+
+      if Is_Entity_Name (R) and then Is_Object (Entity (R)) then
+         return Entity (R);
+      else
+         return Empty;
+      end if;
+   end Get_Base_Object;
+
    ----------------------------
    -- Has_Default_Init_Comps --
    ----------------------------