From a80b1eb72d6f227fc7d1cca36a6c29614a80ab10 Mon Sep 17 00:00:00 2001 From: Eric Botcazou Date: Tue, 24 Mar 2020 14:57:09 +0100 Subject: [PATCH] [Ada] Improve code generated for assignment of dynamic record aggregates 2020-06-12 Eric Botcazou 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. --- gcc/ada/exp_aggr.adb | 311 ++++++++++++++++++++++++++++++++----------- 1 file changed, 231 insertions(+), 80 deletions(-) diff --git a/gcc/ada/exp_aggr.adb b/gcc/ada/exp_aggr.adb index ced0d70629d..22ed3aeddeb 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 -- ---------------------------- -- 2.30.2