procyberian/gcc
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

ada: Cleanup in expansion of array aggregates in object declarations

Browse source 
This mainly decouples the handling of the declaration case from that of the
assignment case in Expand_Array_Aggregate, as well as moves the expansion
in the case of an aggregate that can be processed by the back end to the
Build_Array_Aggr_Code routine.

gcc/ada/ChangeLog:

	* exp_aggr.adb (Build_Array_Aggr_Code): Build the simple assignment
	for the case of an aggregate that can be handled by the back end.
	(Expand_Array_Aggregate): Adjust description of the processing.
	Move handling of declaration case to STEP 4 and remove handling of
	the case of an aggregate that can be processed by the back end.
	(Late_Expansion): Likewise for the second part.
	* exp_ch3.adb (Expand_N_Object_Declaration): Deal with a delayed
	aggregate synthesized for the default initialization, if any.
	* sem_eval.adb (Eval_Indexed_Component): Bail out for the name of
	an assignment statement.
This commit is contained in:
Eric Botcazou 2024-11-06 16:09:28 +01:00 • committed by Marc Poulhiès
parent 7617b83242
commit b2320a12df
3 changed files with 144 additions and 245 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

360
gcc/ada/exp_aggr.adb
View file

@ -1924,6 +1924,48 @@ package body Exp_Aggr is
-- Start of processing for Build_Array_Aggr_Code -- Start of processing for Build_Array_Aggr_Code
begin begin
-- If the assignment can be done directly by the back end, then reset
-- the Set_Expansion_Delayed flag and do not expand further.
if Present (Etype (N))
and then Aggr_Assignment_OK_For_Backend (N)
and then not Possible_Bit_Aligned_Component (Into)
and then not Is_Possibly_Unaligned_Slice (Into)
and then not CodePeer_Mode
then
declare
New_Aggr : constant Node_Id := Relocate_Node (N);
Target : constant Node_Id :=
(if Nkind (Into) = N_Unchecked_Type_Conversion
then Expression (Into)
else Into);
begin
Set_Expansion_Delayed (New_Aggr, False);
-- In the case where the target is the dereference of a prefix
-- with Designated_Storage_Model aspect specifying the Copy_To
-- procedure, first insert a temporary and have the back end
-- handle the assignment to it, then assign the result to the
-- original target.
if Nkind (Target) = N_Explicit_Dereference
and then
Has_Designated_Storage_Model_Aspect (Etype (Prefix (Target)))
and then Present (Storage_Model_Copy_To
(Storage_Model_Object
(Etype (Prefix (Target)))))
then
return Build_Assignment_With_Temporary (Into, Typ, New_Aggr);
else
return New_List (
Make_OK_Assignment_Statement (Loc,
Name => Into,
Expression => New_Aggr));
end if;
end;
end if;
-- First before we start, a special case. If we have a bit packed -- First before we start, a special case. If we have a bit packed
-- array represented as a modular type, then clear the value to -- array represented as a modular type, then clear the value to
-- zero first, to ensure that unused bits are properly cleared. -- zero first, to ensure that unused bits are properly cleared.
@ -4873,17 +4915,17 @@ package body Exp_Aggr is
-- 2. Check for packed array aggregate which can be converted to a -- 2. Check for packed array aggregate which can be converted to a
-- constant so that the aggregate disappears completely. -- constant so that the aggregate disappears completely.
-- 3. Check case of nested aggregate. Generally nested aggregates are -- 3. Check if the aggregate can be statically processed. If this is the
-- handled during the processing of the parent aggregate.
-- 4. Check if the aggregate can be statically processed. If this is the
-- case pass it as is to Gigi. Note that a necessary condition for -- case pass it as is to Gigi. Note that a necessary condition for
-- static processing is that the aggregate be fully positional. -- static processing is that the aggregate be fully positional.
-- 5. If in-place aggregate expansion is possible (i.e. no need to create -- 4. Check if delayed expansion is needed, for example in the cases of
-- a temporary) then mark the aggregate as such and return. Otherwise -- nested aggregates or aggregates in allocators or declarations.
-- create a new temporary and generate the appropriate initialization
-- code. -- 5. If in-place aggregate expansion is not possible, create a temporary
-- and generate the appropriate initialization code.
-- 6. Build and insert the aggregate code
procedure Expand_Array_Aggregate (N : Node_Id) is procedure Expand_Array_Aggregate (N : Node_Id) is
Loc : constant Source_Ptr := Sloc (N); Loc : constant Source_Ptr := Sloc (N);
@ -4904,9 +4946,6 @@ package body Exp_Aggr is
Aggr_Index_Typ : array (1 .. Aggr_Dimension) of Entity_Id; Aggr_Index_Typ : array (1 .. Aggr_Dimension) of Entity_Id;
-- The type of each index -- The type of each index
In_Place_Assign_OK_For_Declaration : Boolean := False;
-- True if we are to generate an in-place assignment for a declaration
Maybe_In_Place_OK : Boolean; Maybe_In_Place_OK : Boolean;
-- If the type is neither controlled nor packed and the aggregate -- If the type is neither controlled nor packed and the aggregate
-- is the expression in an assignment, assignment in place may be -- is the expression in an assignment, assignment in place may be
@ -4946,8 +4985,8 @@ package body Exp_Aggr is
function Safe_Left_Hand_Side (N : Node_Id) return Boolean; function Safe_Left_Hand_Side (N : Node_Id) return Boolean;
-- In addition to Maybe_In_Place_OK, in order for an aggregate to be -- In addition to Maybe_In_Place_OK, in order for an aggregate to be
-- built directly into the target of the assignment it must be free -- built directly into the target of an assignment, the target must
-- of side effects. N is the LHS of an assignment. -- be free of side effects. N is the target of the assignment.
procedure Two_Pass_Aggregate_Expansion (N : Node_Id); procedure Two_Pass_Aggregate_Expansion (N : Node_Id);
-- If the aggregate consists only of iterated associations then the -- If the aggregate consists only of iterated associations then the
@ -5809,7 +5848,6 @@ package body Exp_Aggr is
Tmp_Decl : Node_Id; Tmp_Decl : Node_Id;
-- Holds the declaration of Tmp -- Holds the declaration of Tmp
Aggr_Code : List_Id;
Parent_Node : Node_Id; Parent_Node : Node_Id;
Parent_Kind : Node_Kind; Parent_Kind : Node_Kind;
@ -5989,6 +6027,8 @@ package body Exp_Aggr is
return; return;
end if; end if;
-- STEP 3
-- Now see if back end processing is possible -- Now see if back end processing is possible
if Backend_Processing_Possible (N) then if Backend_Processing_Possible (N) then
@ -6024,7 +6064,7 @@ package body Exp_Aggr is
return; return;
end if; end if;
-- STEP 3 -- STEP 4
-- Set the Expansion_Delayed flag in the cases where the transformation -- Set the Expansion_Delayed flag in the cases where the transformation
-- will be done top down from above. -- will be done top down from above.
@ -6052,7 +6092,8 @@ package body Exp_Aggr is
-- Allocator (see Convert_Aggr_In_Allocator) -- Allocator (see Convert_Aggr_In_Allocator)
or else (Nkind (Parent_Node) = N_Allocator or else (Nkind (Parent_Node) = N_Allocator
and then (Is_Limited_Type (Typ) and then (Aggr_Assignment_OK_For_Backend (N)
or else Is_Limited_Type (Typ)
or else Needs_Finalization (Typ) or else Needs_Finalization (Typ)
or else (not Is_Bit_Packed_Array (Typ) or else (not Is_Bit_Packed_Array (Typ)
and then not and then not
@ -6065,15 +6106,35 @@ package body Exp_Aggr is
-- Object declaration (see Convert_Aggr_In_Object_Decl) -- Object declaration (see Convert_Aggr_In_Object_Decl)
or else (Parent_Kind = N_Object_Declaration or else (Parent_Kind = N_Object_Declaration
and then (Needs_Finalization (Typ) and then (Aggr_Assignment_OK_For_Backend (N)
or else Is_Limited_Type (Typ)
or else Needs_Finalization (Typ)
or else Is_Special_Return_Object or else Is_Special_Return_Object
(Defining_Identifier (Parent_Node)))) (Defining_Identifier (Parent_Node))
or else (not Is_Bit_Packed_Array (Typ)
and then not
Must_Slide
(N,
Etype
(Defining_Identifier
(Parent_Node)),
Typ))))
-- Safe assignment (see Convert_Aggr_In_Assignment). So far only the -- Safe assignment (see Convert_Aggr_In_Assignment). So far only the
-- assignments in init procs are taken into account. -- assignments in init procs are taken into account, as well those
-- directly performed by the back end.
or else (Parent_Kind = N_Assignment_Statement or else (Parent_Kind = N_Assignment_Statement
and then Inside_Init_Proc) and then (Inside_Init_Proc
or else
(Aggr_Assignment_OK_For_Backend (N)
and then not
Possible_Bit_Aligned_Component
(Name (Parent_Node))
and then not
Is_Possibly_Unaligned_Slice
(Name (Parent_Node))
and then not CodePeer_Mode)))
-- Simple return statement, which will be handled in a build-in-place -- Simple return statement, which will be handled in a build-in-place
-- fashion and will ultimately be rewritten as an extended return. -- fashion and will ultimately be rewritten as an extended return.
@ -6084,43 +6145,28 @@ package body Exp_Aggr is
return; return;
end if; end if;
-- STEP 4 -- Otherwise, if a transient scope is required, create it now
-- Check whether in-place aggregate expansion is possible
-- For object declarations we build the aggregate in place, unless
-- the array is bit-packed.
-- For assignments we do the assignment in place if all the component
-- associations have compile-time known values, or are default-
-- initialized limited components, e.g. tasks. For other cases we
-- create a temporary. A full analysis for safety of in-place assignment
-- is delicate.
if Requires_Transient_Scope (Typ) then if Requires_Transient_Scope (Typ) then
Establish_Transient_Scope (N, Manage_Sec_Stack => False); Establish_Transient_Scope (N, Manage_Sec_Stack => False);
end if; end if;
-- An array of limited components is built in place -- STEP 5
if Is_Limited_Type (Typ) then -- Check whether in-place aggregate expansion is possible
Maybe_In_Place_OK := True;
elsif Has_Default_Init_Comps (N) then -- We do assignments in place if all the component associations have
Maybe_In_Place_OK := False; -- known safe values, or have default-initialized limited values, e.g.
-- protected objects or tasks. For other cases we create a temporary.
elsif Is_Bit_Packed_Array (Typ) Maybe_In_Place_OK :=
or else Has_Controlled_Component (Typ) Parent_Kind = N_Assignment_Statement
then and then (Is_Limited_Type (Typ)
Maybe_In_Place_OK := False; or else (not Has_Default_Init_Comps (N)
and then not Is_Bit_Packed_Array (Typ)
elsif Parent_Kind = N_Assignment_Statement then and then
Maybe_In_Place_OK := In_Place_Assign_OK
In_Place_Assign_OK (N, Get_Base_Object (Name (Parent_Node))); (N, Get_Base_Object (Name (Parent_Node)))));
else
Maybe_In_Place_OK := False;
end if;
-- If this is an array of tasks, it will be expanded into build-in-place -- If this is an array of tasks, it will be expanded into build-in-place
-- assignments. Build an activation chain for the tasks now. -- assignments. Build an activation chain for the tasks now.
@ -6129,57 +6175,9 @@ package body Exp_Aggr is
Build_Activation_Chain_Entity (N); Build_Activation_Chain_Entity (N);
end if; end if;
-- Perform in-place expansion of aggregate in an object declaration. -- Check that the target of the assignment is also safe
-- Note: actions generated for the aggregate will be captured in an
-- expression-with-actions statement so that they can be transferred
-- to freeze actions later if there is an address clause for the
-- object. (Note: we don't use a block statement because this would
-- cause generated freeze nodes to be elaborated in the wrong scope).
-- Arrays of limited components must be built in place. The code if Maybe_In_Place_OK
-- previously excluded controlled components but this is an old
-- oversight: the rules in 7.6 (17) are clear.
if Comes_From_Source (Parent_Node)
and then Parent_Kind = N_Object_Declaration
and then Present (Expression (Parent_Node))
and then not
Must_Slide (N, Etype (Defining_Identifier (Parent_Node)), Typ)
and then not Is_Bit_Packed_Array (Typ)
then
In_Place_Assign_OK_For_Declaration := True;
Tmp := Defining_Identifier (Parent_Node);
Set_No_Initialization (Parent_Node);
Set_Expression (Parent_Node, Empty);
-- Set kind and type of the entity, for use in the analysis
-- of the subsequent assignments. If the nominal type is not
-- constrained, build a subtype from the known bounds of the
-- aggregate. If the declaration has a subtype mark, use it,
-- otherwise use the itype of the aggregate.
Mutate_Ekind (Tmp, E_Variable);
if not Is_Constrained (Typ) then
Build_Constrained_Type (Positional => False);
elsif Is_Entity_Name (Object_Definition (Parent_Node))
and then Is_Constrained (Entity (Object_Definition (Parent_Node)))
then
Set_Etype (Tmp, Entity (Object_Definition (Parent_Node)));
else
Set_Size_Known_At_Compile_Time (Typ, False);
Set_Etype (Tmp, Typ);
end if;
-- In the remaining cases the aggregate appears in the RHS of an
-- assignment, which may be part of the expansion of an object
-- declaration. If the aggregate is an actual in a call, itself
-- possibly in a RHS, building it in the target is not possible.
elsif Maybe_In_Place_OK
and then Nkind (Parent_Node) not in N_Subprogram_Call
and then Safe_Left_Hand_Side (Name (Parent_Node)) and then Safe_Left_Hand_Side (Name (Parent_Node))
then then
Tmp := Name (Parent_Node); Tmp := Name (Parent_Node);
@ -6210,8 +6208,6 @@ package body Exp_Aggr is
Set_Etype (N, Etype (Tmp)); Set_Etype (N, Etype (Tmp));
-- Step 5
-- In-place aggregate expansion is not possible -- In-place aggregate expansion is not possible
else else
@ -6247,12 +6243,13 @@ package body Exp_Aggr is
Insert_Action (N, Tmp_Decl); Insert_Action (N, Tmp_Decl);
end if; end if;
-- Construct and insert the aggregate code. We can safely suppress index -- STEP 6
-- checks because this code is guaranteed not to raise CE on index
-- checks. However we should *not* suppress all checks. -- Build and insert the aggregate code
declare declare
Target : Node_Id; Aggr_Code : List_Id;
Target : Node_Id;
begin begin
if Nkind (Tmp) = N_Defining_Identifier then if Nkind (Tmp) = N_Defining_Identifier then
@ -6269,58 +6266,15 @@ package body Exp_Aggr is
-- Name in assignment is explicit dereference -- Name in assignment is explicit dereference
Target := New_Copy (Tmp); Target := New_Copy_Tree (Tmp);
end if; end if;
-- If we are to generate an in-place assignment for a declaration or Aggr_Code :=
-- an assignment statement, and the assignment can be done directly Build_Array_Aggr_Code (N,
-- by the back end, then do not expand further. Ctype => Ctyp,
Index => First_Index (Typ),
-- ??? We can also do that if in-place expansion is not possible but Into => Target,
-- then we could go into an infinite recursion. Scalar_Comp => Is_Scalar_Type (Ctyp));
if (In_Place_Assign_OK_For_Declaration or else Maybe_In_Place_OK)
and then not CodePeer_Mode
and then not Possible_Bit_Aligned_Component (Target)
and then not Is_Possibly_Unaligned_Slice (Target)
and then Aggr_Assignment_OK_For_Backend (N)
then
-- In the case of an assignment using an access with the
-- Designated_Storage_Model aspect with a Copy_To procedure,
-- insert a temporary and have the back end handle the assignment
-- to it. Copy the result to the original target.
if Parent_Kind = N_Assignment_Statement
and then Nkind (Name (Parent_Node)) = N_Explicit_Dereference
and then Has_Designated_Storage_Model_Aspect
(Etype (Prefix (Name (Parent_Node))))
and then Present (Storage_Model_Copy_To
(Storage_Model_Object
(Etype (Prefix (Name (Parent_Node))))))
then
Aggr_Code := Build_Assignment_With_Temporary
(Target, Typ, New_Copy_Tree (N));
else
if Maybe_In_Place_OK then
return;
end if;
Aggr_Code := New_List (
Make_Assignment_Statement (Loc,
Name => Target,
Expression => New_Copy_Tree (N)));
end if;
else
Aggr_Code :=
Build_Array_Aggr_Code (N,
Ctype => Ctyp,
Index => First_Index (Typ),
Into => Target,
Scalar_Comp => Is_Scalar_Type (Ctyp));
end if;
-- Save the last assignment statement associated with the aggregate -- Save the last assignment statement associated with the aggregate
-- when building a controlled object. This reference is utilized by -- when building a controlled object. This reference is utilized by
@ -6334,47 +6288,17 @@ package body Exp_Aggr is
then then
Set_Last_Aggregate_Assignment (Entity (Target), Last (Aggr_Code)); Set_Last_Aggregate_Assignment (Entity (Target), Last (Aggr_Code));
end if; end if;
Insert_Actions (N, Aggr_Code);
end; end;
-- If the aggregate is the expression in a declaration, the expanded
-- code must be inserted after it. The defining entity might not come
-- from source if this is part of an inlined body, but the declaration
-- itself will.
-- The test below looks very specialized and kludgy???
if Comes_From_Source (Tmp)
or else
(Nkind (Parent (N)) = N_Object_Declaration
and then Comes_From_Source (Parent (N))
and then Tmp = Defining_Entity (Parent (N)))
then
if Parent_Kind /= N_Object_Declaration or else Is_Frozen (Tmp) then
Insert_Actions_After (Parent_Node, Aggr_Code);
else
declare
Comp_Stmt : constant Node_Id :=
Make_Compound_Statement
(Sloc (Parent_Node), Actions => Aggr_Code);
begin
Insert_Action_After (Parent_Node, Comp_Stmt);
Set_Initialization_Statements (Tmp, Comp_Stmt);
end;
end if;
else
Insert_Actions (N, Aggr_Code);
end if;
-- If the aggregate has been assigned in place, remove the original -- If the aggregate has been assigned in place, remove the original
-- assignment. -- assignment. Otherwise replace the aggregate with the temporary.
if Parent_Kind = N_Assignment_Statement and then Maybe_In_Place_OK then if Maybe_In_Place_OK then
Rewrite (Parent_Node, Make_Null_Statement (Loc)); Rewrite (Parent_Node, Make_Null_Statement (Loc));
-- Or else, if a temporary was created, replace the aggregate with it else
elsif Parent_Kind /= N_Object_Declaration
or else Tmp /= Defining_Identifier (Parent_Node)
then
Rewrite (N, New_Occurrence_Of (Tmp, Loc)); Rewrite (N, New_Occurrence_Of (Tmp, Loc));
Analyze_And_Resolve (N, Typ); Analyze_And_Resolve (N, Typ);
end if; end if;
@ -8878,58 +8802,16 @@ package body Exp_Aggr is
Target : Node_Id) return List_Id Target : Node_Id) return List_Id
is is
Aggr_Code : List_Id; Aggr_Code : List_Id;
New_Aggr : Node_Id;
begin begin
if Is_Array_Type (Typ) then if Is_Array_Type (Typ) then
-- If the assignment can be done directly by the back end, then Aggr_Code :=
-- reset Set_Expansion_Delayed and do not expand further. Build_Array_Aggr_Code
(N => N,
if not CodePeer_Mode Ctype => Component_Type (Typ),
and then not Possible_Bit_Aligned_Component (Target) Index => First_Index (Typ),
and then not Is_Possibly_Unaligned_Slice (Target) Into => Target,
and then Aggr_Assignment_OK_For_Backend (N) Scalar_Comp => Is_Scalar_Type (Component_Type (Typ)));
then
New_Aggr := New_Copy_Tree (N);
Set_Expansion_Delayed (New_Aggr, False);
-- In case of Target's type having the Designated_Storage_Model
-- aspect with a Copy_To procedure, first insert a temporary and
-- have the back end handle the assignment to it, then copy the
-- result to the original target.
if Nkind (Target) = N_Unchecked_Type_Conversion
and then Nkind (Expression (Target)) = N_Explicit_Dereference
and then Has_Designated_Storage_Model_Aspect
(Etype (Prefix (Expression (Target))))
and then Present (Storage_Model_Copy_To
(Storage_Model_Object
(Etype (Prefix (Expression (Target))))))
then
Aggr_Code :=
Build_Assignment_With_Temporary (Target, Typ, New_Aggr);
else
Aggr_Code :=
New_List (
Make_OK_Assignment_Statement (Sloc (New_Aggr),
Name => Target,
Expression => New_Aggr));
end if;
-- Or else, generate component assignments to it
else
Aggr_Code :=
Build_Array_Aggr_Code
(N => N,
Ctype => Component_Type (Typ),
Index => First_Index (Typ),
Into => Target,
Scalar_Comp => Is_Scalar_Type (Component_Type (Typ)));
end if;
-- Directly or indirectly (e.g. access protected procedure) a record
else else
Aggr_Code := Build_Record_Aggr_Code (N, Typ, Target); Aggr_Code := Build_Record_Aggr_Code (N, Typ, Target);

21
gcc/ada/exp_ch3.adb
View file

@ -7654,16 +7654,25 @@ package body Exp_Ch3 is
end if; end if;
end if; end if;
-- For a special return object, the initialization must wait until
-- after the object is turned into an allocator.
if not Special_Ret_Obj then if not Special_Ret_Obj then
Default_Initialize_Object (Init_After); Default_Initialize_Object (Init_After);
-- Check whether an access object has been initialized above -- Check whether the object has been initialized above
if Is_Access_Type (Typ) and then Present (Expression (N)) then if Present (Expression (N)) then
if Known_Non_Null (Expression (N)) then if Is_Access_Type (Typ) then
Set_Is_Known_Non_Null (Def_Id); if Known_Non_Null (Expression (N)) then
elsif Known_Null (Expression (N)) then Set_Is_Known_Non_Null (Def_Id);
Set_Is_Known_Null (Def_Id); elsif Known_Null (Expression (N)) then
Set_Is_Known_Null (Def_Id);
end if;
end if;
if Is_Delayed_Aggregate (Expression (N)) then
Convert_Aggr_In_Object_Decl (N);
end if; end if;
end if; end if;
end if; end if;

8
gcc/ada/sem_eval.adb
View file

@ -2645,6 +2645,14 @@ package body Sem_Eval is
elsif Nkind (Parent (N)) = N_Attribute_Reference then elsif Nkind (Parent (N)) = N_Attribute_Reference then
return; return;
-- Similarly if the indexed component appears as the name of an
-- assignment statement, we don't want to evaluate it,
elsif Nkind (Parent (N)) = N_Assignment_Statement
and then N = Name (Parent (N))
then
return;
end if; end if;
-- Note: there are other cases, such as the left side of an assignment, -- Note: there are other cases, such as the left side of an assignment,