* [COMMITTED] ada: Factor common processing in expansion of aggregates
@ 2023-06-13 7:37 Marc Poulhiès
0 siblings, 0 replies; only message in thread
From: Marc Poulhiès @ 2023-06-13 7:37 UTC (permalink / raw)
To: gcc-patches; +Cc: Eric Botcazou
From: Eric Botcazou <ebotcazou@adacore.com>
The final processing at the component level of array aggregates and record
aggregates is very similar, so this factors out the common processing into
three new library-level subprograms.
There should be no functional changes, but the expanded code may be changed
in the case of controlled components of array aggregates not covered by a
multiple choice: the previous expansion used to place new declarations prior
to the aggregate in this case and that is no longer the case, i.e. they are
always placed right before the initialization of the component (as was done
for all controlled components of record aggregates and controlled components
of array aggregates covered by a multiple choice).
gcc/ada/
* exp_aggr.adb (Initialize_Component): New procedure factored out
from the processing of array and record aggregates.
(Initialize_Controlled_Component): Likewise.
(Initialize_Simple_Component): Likewise.
(Build_Array_Aggr_Code.Gen_Assign): Remove In_Loop parameter.
Call Initialize_Component to initialize the component.
(Initialize_Array_Component): Delete.
(Initialize_Ctrl_Array_Component): Likewise.
(Build_Array_Aggr_Code): Adjust calls to Gen_Assign.
(Build_Record_Aggr_Code): Call Initialize_Simple_Component or
Initialize_Component to initialize the component.
(Initialize_Ctrl_Record_Component): Delete.
(Initialize_Record_Component): Likewise.
Tested on x86_64-pc-linux-gnu, committed on master.
---
gcc/ada/exp_aggr.adb | 1000 +++++++++++++++---------------------------
1 file changed, 360 insertions(+), 640 deletions(-)
diff --git a/gcc/ada/exp_aggr.adb b/gcc/ada/exp_aggr.adb
index 270d3bb8d66..e5b2cedb954 100644
--- a/gcc/ada/exp_aggr.adb
+++ b/gcc/ada/exp_aggr.adb
@@ -105,6 +105,36 @@ package body Exp_Aggr is
-- N is an aggregate (record or array). Checks the presence of default
-- initialization (<>) in any component (Ada 2005: AI-287).
+ procedure Initialize_Component
+ (N : Node_Id;
+ Comp : Node_Id;
+ Comp_Typ : Entity_Id;
+ Init_Expr : Node_Id;
+ Stmts : List_Id);
+ -- Perform the initialization of component Comp with expected type Comp_Typ
+ -- of aggregate N. Init_Expr denotes the initialization expression of the
+ -- component. All generated code is added to Stmts.
+
+ procedure Initialize_Controlled_Component
+ (N : Node_Id;
+ Comp : Node_Id;
+ Comp_Typ : Entity_Id;
+ Init_Expr : Node_Id;
+ Stmts : List_Id);
+ -- Perform the initialization of controlled component Comp with expected
+ -- type Comp_Typ of aggregate N. Init_Expr denotes the initialization
+ -- expression of the component. All generated code is added to Stmts.
+
+ procedure Initialize_Simple_Component
+ (N : Node_Id;
+ Comp : Node_Id;
+ Comp_Typ : Node_Id;
+ Init_Expr : Node_Id;
+ Stmts : List_Id);
+ -- Perform the initialization of simple component Comp with expected
+ -- type Comp_Typ of aggregate N. Init_Expr denotes the initialization
+ -- expression of the component. All generated code is added to Stmts.
+
function Is_CCG_Supported_Aggregate (N : Node_Id) return Boolean;
-- Return True if aggregate N is located in a context supported by the
-- CCG backend; False otherwise.
@@ -1081,16 +1111,14 @@ package body Exp_Aggr is
function Gen_Assign
(Ind : Node_Id;
- Expr : Node_Id;
- In_Loop : Boolean := False) return List_Id;
+ Expr : Node_Id) return List_Id;
-- Ind must be a side-effect-free expression. If the input aggregate N
-- to Build_Loop contains no subaggregates, then this function returns
-- the assignment statement:
--
-- Into (Indexes, Ind) := Expr;
--
- -- Otherwise we call Build_Code recursively. Flag In_Loop should be set
- -- when the assignment appears within a generated loop.
+ -- Otherwise we call Build_Code recursively.
--
-- Ada 2005 (AI-287): In case of default initialized component, Expr
-- is empty and we generate a call to the corresponding IP subprogram.
@@ -1310,35 +1338,13 @@ package body Exp_Aggr is
function Gen_Assign
(Ind : Node_Id;
- Expr : Node_Id;
- In_Loop : Boolean := False) return List_Id
+ Expr : Node_Id) return List_Id
is
function Add_Loop_Actions (Lis : List_Id) return List_Id;
-- Collect insert_actions generated in the construction of a loop,
-- and prepend them to the sequence of assignments to complete the
-- eventual body of the loop.
- procedure Initialize_Array_Component
- (Arr_Comp : Node_Id;
- Comp_Typ : Node_Id;
- Init_Expr : Node_Id;
- Stmts : List_Id);
- -- Perform the initialization of array component Arr_Comp with
- -- expected type Comp_Typ. Init_Expr denotes the initialization
- -- expression of the array component. All generated code is added
- -- to list Stmts.
-
- procedure Initialize_Ctrl_Array_Component
- (Arr_Comp : Node_Id;
- Comp_Typ : Entity_Id;
- Init_Expr : Node_Id;
- Stmts : List_Id);
- -- Perform the initialization of array component Arr_Comp when its
- -- expected type Comp_Typ needs finalization actions. Init_Expr is
- -- the initialization expression of the array component. All hook-
- -- related declarations are inserted prior to aggregate N. Remaining
- -- code is added to list Stmts.
-
----------------------
-- Add_Loop_Actions --
----------------------
@@ -1366,263 +1372,6 @@ package body Exp_Aggr is
end if;
end Add_Loop_Actions;
- --------------------------------
- -- Initialize_Array_Component --
- --------------------------------
-
- procedure Initialize_Array_Component
- (Arr_Comp : Node_Id;
- Comp_Typ : Node_Id;
- Init_Expr : Node_Id;
- Stmts : List_Id)
- is
- Exceptions_OK : constant Boolean :=
- not Restriction_Active
- (No_Exception_Propagation);
-
- Finalization_OK : constant Boolean :=
- Present (Comp_Typ)
- and then Needs_Finalization (Comp_Typ);
-
- Full_Typ : constant Entity_Id := Underlying_Type (Comp_Typ);
- Adj_Call : Node_Id;
- Blk_Stmts : List_Id;
- Init_Stmt : Node_Id;
-
- begin
- -- Protect the initialization statements from aborts. Generate:
-
- -- Abort_Defer;
-
- if Finalization_OK and Abort_Allowed then
- if Exceptions_OK then
- Blk_Stmts := New_List;
- else
- Blk_Stmts := Stmts;
- end if;
-
- Append_To (Blk_Stmts, Build_Runtime_Call (Loc, RE_Abort_Defer));
-
- -- Otherwise aborts are not allowed. All generated code is added
- -- directly to the input list.
-
- else
- Blk_Stmts := Stmts;
- end if;
-
- -- Initialize the array element. Generate:
-
- -- Arr_Comp := Init_Expr;
-
- -- Note that the initialization expression is replicated because
- -- it has to be reevaluated within a generated loop.
-
- Init_Stmt :=
- Make_OK_Assignment_Statement (Loc,
- Name => New_Copy_Tree (Arr_Comp),
- Expression => New_Copy_Tree (Init_Expr));
- Set_No_Ctrl_Actions (Init_Stmt);
-
- Append_To (Blk_Stmts, Init_Stmt);
-
- -- Adjust the tag due to a possible view conversion. Generate:
-
- -- Arr_Comp._tag := Full_TypP;
-
- if Tagged_Type_Expansion
- and then Present (Comp_Typ)
- and then Is_Tagged_Type (Comp_Typ)
- then
- Append_To (Blk_Stmts,
- Make_OK_Assignment_Statement (Loc,
- Name =>
- Make_Selected_Component (Loc,
- Prefix => New_Copy_Tree (Arr_Comp),
- Selector_Name =>
- New_Occurrence_Of
- (First_Tag_Component (Full_Typ), Loc)),
-
- Expression =>
- Unchecked_Convert_To (RTE (RE_Tag),
- New_Occurrence_Of
- (Node (First_Elmt (Access_Disp_Table (Full_Typ))),
- Loc))));
- end if;
-
- -- Adjust the array component. Controlled subaggregates are not
- -- considered because each of their individual elements will
- -- receive an adjustment of its own. Generate:
-
- -- [Deep_]Adjust (Arr_Comp);
-
- if Finalization_OK
- and then not Is_Limited_Type (Comp_Typ)
- and then not Is_Build_In_Place_Function_Call (Init_Expr)
- and then not
- (Is_Array_Type (Comp_Typ)
- and then Needs_Finalization (Component_Type (Comp_Typ))
- and then Nkind (Unqualify (Init_Expr)) = N_Aggregate)
- then
- Adj_Call :=
- Make_Adjust_Call
- (Obj_Ref => New_Copy_Tree (Arr_Comp),
- Typ => Comp_Typ);
-
- -- Guard against a missing [Deep_]Adjust when the component
- -- type was not frozen properly.
-
- if Present (Adj_Call) then
- Append_To (Blk_Stmts, Adj_Call);
- end if;
- end if;
-
- -- Complete the protection of the initialization statements
-
- if Finalization_OK and Abort_Allowed then
-
- -- Wrap the initialization statements in a block to catch a
- -- potential exception. Generate:
-
- -- begin
- -- Abort_Defer;
- -- Arr_Comp := Init_Expr;
- -- Arr_Comp._tag := Full_TypP;
- -- [Deep_]Adjust (Arr_Comp);
- -- at end
- -- Abort_Undefer_Direct;
- -- end;
-
- if Exceptions_OK then
- Append_To (Stmts,
- Build_Abort_Undefer_Block (Loc,
- Stmts => Blk_Stmts,
- Context => N));
-
- -- Otherwise exceptions are not propagated. Generate:
-
- -- Abort_Defer;
- -- Arr_Comp := Init_Expr;
- -- Arr_Comp._tag := Full_TypP;
- -- [Deep_]Adjust (Arr_Comp);
- -- Abort_Undefer;
-
- else
- Append_To (Blk_Stmts,
- Build_Runtime_Call (Loc, RE_Abort_Undefer));
- end if;
- end if;
- end Initialize_Array_Component;
-
- -------------------------------------
- -- Initialize_Ctrl_Array_Component --
- -------------------------------------
-
- procedure Initialize_Ctrl_Array_Component
- (Arr_Comp : Node_Id;
- Comp_Typ : Entity_Id;
- Init_Expr : Node_Id;
- Stmts : List_Id)
- is
- Init_Expr_Q : constant Node_Id := Unqualify (Init_Expr);
-
- Act_Aggr : Node_Id;
- Act_Stmts : List_Id;
- Fin_Call : Node_Id;
- Hook_Clear : Node_Id;
-
- In_Place_Expansion : Boolean;
- -- Flag set when a nonlimited controlled function call requires
- -- in-place expansion.
-
- begin
- -- Perform a preliminary analysis and resolution to determine what
- -- the initialization expression denotes. An unanalyzed function
- -- call may appear as an identifier or an indexed component.
-
- if Nkind (Init_Expr_Q) in N_Function_Call
- | N_Identifier
- | N_Indexed_Component
- and then not Analyzed (Init_Expr)
- then
- Preanalyze_And_Resolve (Init_Expr, Comp_Typ);
- end if;
-
- In_Place_Expansion :=
- Nkind (Init_Expr_Q) = N_Function_Call
- and then not Is_Build_In_Place_Result_Type (Comp_Typ);
-
- -- The initialization expression is a controlled function call.
- -- Perform in-place removal of side effects to avoid creating a
- -- transient scope, which leads to premature finalization.
-
- -- This in-place expansion is not performed for limited transient
- -- objects, because the initialization is already done in place.
-
- if In_Place_Expansion then
-
- -- Suppress the removal of side effects by general analysis,
- -- because this behavior is emulated here. This avoids the
- -- generation of a transient scope, which leads to out-of-order
- -- adjustment and finalization.
-
- Set_No_Side_Effect_Removal (Init_Expr);
-
- -- When the transient component initialization is related to a
- -- range or an "others", keep all generated statements within
- -- the enclosing loop. This way the controlled function call
- -- will be evaluated at each iteration, and its result will be
- -- finalized at the end of each iteration.
-
- if In_Loop then
- Act_Aggr := Empty;
- Act_Stmts := Stmts;
-
- -- Otherwise this is a single component initialization. Hook-
- -- related statements are inserted prior to the aggregate.
-
- else
- Act_Aggr := N;
- Act_Stmts := No_List;
- end if;
-
- -- Install all hook-related declarations and prepare the clean
- -- up statements.
-
- Process_Transient_Component
- (Loc => Loc,
- Comp_Typ => Comp_Typ,
- Init_Expr => Init_Expr,
- Fin_Call => Fin_Call,
- Hook_Clear => Hook_Clear,
- Aggr => Act_Aggr,
- Stmts => Act_Stmts);
- end if;
-
- -- Use the noncontrolled component initialization circuitry to
- -- assign the result of the function call to the array element.
- -- This also performs subaggregate wrapping, tag adjustment, and
- -- [deep] adjustment of the array element.
-
- Initialize_Array_Component
- (Arr_Comp => Arr_Comp,
- Comp_Typ => Comp_Typ,
- Init_Expr => Init_Expr,
- Stmts => Stmts);
-
- -- At this point the array element is fully initialized. Complete
- -- the processing of the controlled array component by finalizing
- -- the transient function result.
-
- if In_Place_Expansion then
- Process_Transient_Component_Completion
- (Loc => Loc,
- Aggr => N,
- Fin_Call => Fin_Call,
- Hook_Clear => Hook_Clear,
- Stmts => Stmts);
- end if;
- end Initialize_Ctrl_Array_Component;
-
-- Local variables
Stmts : constant List_Id := New_List;
@@ -1768,57 +1517,12 @@ package body Exp_Aggr is
end if;
if Present (Expr) then
-
- -- Handle an initialization expression of a controlled type in
- -- case it denotes a function call. In general such a scenario
- -- will produce a transient scope, but this will lead to wrong
- -- order of initialization, adjustment, and finalization in the
- -- context of aggregates.
-
- -- Target (1) := Ctrl_Func_Call;
-
- -- begin -- scope
- -- Trans_Obj : ... := Ctrl_Func_Call; -- object
- -- Target (1) := Trans_Obj;
- -- Finalize (Trans_Obj);
- -- end;
- -- Target (1)._tag := ...;
- -- Adjust (Target (1));
-
- -- In the example above, the call to Finalize occurs too early
- -- and as a result it may leave the array component in a bad
- -- state. Finalization of the transient object should really
- -- happen after adjustment.
-
- -- To avoid this scenario, perform in-place side-effect removal
- -- of the function call. This eliminates the transient property
- -- of the function result and ensures correct order of actions.
-
- -- Res : ... := Ctrl_Func_Call;
- -- Target (1) := Res;
- -- Target (1)._tag := ...;
- -- Adjust (Target (1));
- -- Finalize (Res);
-
- if Present (Comp_Typ)
- and then Needs_Finalization (Comp_Typ)
- and then Nkind (Expr_Q) /= N_Aggregate
- then
- Initialize_Ctrl_Array_Component
- (Arr_Comp => Indexed_Comp,
- Comp_Typ => Comp_Typ,
- Init_Expr => Expr,
- Stmts => Stmts);
-
- -- Otherwise perform simple component initialization
-
- else
- Initialize_Array_Component
- (Arr_Comp => Indexed_Comp,
- Comp_Typ => Comp_Typ,
- Init_Expr => Expr,
- Stmts => Stmts);
- end if;
+ Initialize_Component
+ (N => N,
+ Comp => Indexed_Comp,
+ Comp_Typ => Comp_Typ,
+ Init_Expr => Expr,
+ Stmts => Stmts);
-- Ada 2005 (AI-287): In case of default initialized component, call
-- the initialization subprogram associated with the component type.
@@ -2070,8 +1774,7 @@ package body Exp_Aggr is
-- Construct the statements to execute in the loop body
- L_Body :=
- Gen_Assign (New_Occurrence_Of (L_J, Loc), Expr, In_Loop => True);
+ L_Body := Gen_Assign (New_Occurrence_Of (L_J, Loc), Expr);
-- Construct the final loop
@@ -2184,7 +1887,7 @@ package body Exp_Aggr is
Append_To (W_Body, W_Increment);
Append_List_To (W_Body,
- Gen_Assign (New_Occurrence_Of (W_J, Loc), Expr, In_Loop => True));
+ Gen_Assign (New_Occurrence_Of (W_J, Loc), Expr));
-- Construct the final loop
@@ -2606,26 +2309,6 @@ package body Exp_Aggr is
-- The type of the aggregate is a subtype created ealier using the
-- given values of the discriminant components of the aggregate.
- procedure Initialize_Ctrl_Record_Component
- (Rec_Comp : Node_Id;
- Comp_Typ : Entity_Id;
- Init_Expr : Node_Id;
- Stmts : List_Id);
- -- Perform the initialization of controlled record component Rec_Comp.
- -- Comp_Typ is the component type. Init_Expr is the initialization
- -- expression for the record component. Hook-related declarations are
- -- inserted prior to aggregate N using Insert_Action. All remaining
- -- generated code is added to list Stmts.
-
- procedure Initialize_Record_Component
- (Rec_Comp : Node_Id;
- Comp_Typ : Entity_Id;
- Init_Expr : Node_Id;
- Stmts : List_Id);
- -- Perform the initialization of record component Rec_Comp. Comp_Typ
- -- is the component type. Init_Expr is the initialization expression
- -- of the record component. All generated code is added to list Stmts.
-
function Is_Int_Range_Bounds (Bounds : Node_Id) return Boolean;
-- Check whether Bounds is a range node and its lower and higher bounds
-- are integers literals.
@@ -3119,236 +2802,6 @@ package body Exp_Aggr is
end loop;
end Init_Stored_Discriminants;
- --------------------------------------
- -- Initialize_Ctrl_Record_Component --
- --------------------------------------
-
- procedure Initialize_Ctrl_Record_Component
- (Rec_Comp : Node_Id;
- Comp_Typ : Entity_Id;
- Init_Expr : Node_Id;
- Stmts : List_Id)
- is
- Init_Expr_Q : constant Node_Id := Unqualify (Init_Expr);
-
- Fin_Call : Node_Id;
- Hook_Clear : Node_Id;
-
- In_Place_Expansion : Boolean;
- -- Flag set when a nonlimited controlled function call requires
- -- in-place expansion.
-
- begin
- -- Perform a preliminary analysis and resolution to determine what
- -- the initialization expression denotes. Unanalyzed function calls
- -- may appear as identifiers or indexed components.
-
- if Nkind (Init_Expr_Q) in N_Function_Call
- | N_Identifier
- | N_Indexed_Component
- and then not Analyzed (Init_Expr)
- then
- Preanalyze_And_Resolve (Init_Expr, Comp_Typ);
- end if;
-
- In_Place_Expansion :=
- Nkind (Init_Expr_Q) = N_Function_Call
- and then not Is_Build_In_Place_Result_Type (Comp_Typ);
-
- -- The initialization expression is a controlled function call.
- -- Perform in-place removal of side effects to avoid creating a
- -- transient scope.
-
- -- This in-place expansion is not performed for limited transient
- -- objects because the initialization is already done in place.
-
- if In_Place_Expansion then
-
- -- Suppress the removal of side effects by general analysis
- -- because this behavior is emulated here. This avoids the
- -- generation of a transient scope, which leads to out-of-order
- -- adjustment and finalization.
-
- Set_No_Side_Effect_Removal (Init_Expr);
-
- -- Install all hook-related declarations and prepare the clean up
- -- statements. The generated code follows the initialization order
- -- of individual components and discriminants, rather than being
- -- inserted prior to the aggregate. This ensures that a transient
- -- component which mentions a discriminant has proper visibility
- -- of the discriminant.
-
- Process_Transient_Component
- (Loc => Loc,
- Comp_Typ => Comp_Typ,
- Init_Expr => Init_Expr,
- Fin_Call => Fin_Call,
- Hook_Clear => Hook_Clear,
- Stmts => Stmts);
- end if;
-
- -- Use the noncontrolled component initialization circuitry to
- -- assign the result of the function call to the record component.
- -- This also performs tag adjustment and [deep] adjustment of the
- -- record component.
-
- Initialize_Record_Component
- (Rec_Comp => Rec_Comp,
- Comp_Typ => Comp_Typ,
- Init_Expr => Init_Expr,
- Stmts => Stmts);
-
- -- At this point the record component is fully initialized. Complete
- -- the processing of the controlled record component by finalizing
- -- the transient function result.
-
- if In_Place_Expansion then
- Process_Transient_Component_Completion
- (Loc => Loc,
- Aggr => N,
- Fin_Call => Fin_Call,
- Hook_Clear => Hook_Clear,
- Stmts => Stmts);
- end if;
- end Initialize_Ctrl_Record_Component;
-
- ---------------------------------
- -- Initialize_Record_Component --
- ---------------------------------
-
- procedure Initialize_Record_Component
- (Rec_Comp : Node_Id;
- Comp_Typ : Entity_Id;
- Init_Expr : Node_Id;
- Stmts : List_Id)
- is
- Exceptions_OK : constant Boolean :=
- not Restriction_Active (No_Exception_Propagation);
-
- Finalization_OK : constant Boolean := Needs_Finalization (Comp_Typ);
-
- Full_Typ : constant Entity_Id := Underlying_Type (Comp_Typ);
- Adj_Call : Node_Id;
- Blk_Stmts : List_Id;
- Init_Stmt : Node_Id;
-
- begin
- pragma Assert (Nkind (Init_Expr) in N_Subexpr);
-
- -- Protect the initialization statements from aborts. Generate:
-
- -- Abort_Defer;
-
- if Finalization_OK and Abort_Allowed then
- if Exceptions_OK then
- Blk_Stmts := New_List;
- else
- Blk_Stmts := Stmts;
- end if;
-
- Append_To (Blk_Stmts, Build_Runtime_Call (Loc, RE_Abort_Defer));
-
- -- Otherwise aborts are not allowed. All generated code is added
- -- directly to the input list.
-
- else
- Blk_Stmts := Stmts;
- end if;
-
- -- Initialize the record component. Generate:
-
- -- Rec_Comp := Init_Expr;
-
- -- Note that the initialization expression is NOT replicated because
- -- only a single component may be initialized by it.
-
- Init_Stmt :=
- Make_OK_Assignment_Statement (Loc,
- Name => New_Copy_Tree (Rec_Comp),
- Expression => Init_Expr);
- Set_No_Ctrl_Actions (Init_Stmt);
-
- Append_To (Blk_Stmts, Init_Stmt);
-
- -- Adjust the tag due to a possible view conversion. Generate:
-
- -- Rec_Comp._tag := Full_TypeP;
-
- if Tagged_Type_Expansion and then Is_Tagged_Type (Comp_Typ) then
- Append_To (Blk_Stmts,
- Make_OK_Assignment_Statement (Loc,
- Name =>
- Make_Selected_Component (Loc,
- Prefix => New_Copy_Tree (Rec_Comp),
- Selector_Name =>
- New_Occurrence_Of
- (First_Tag_Component (Full_Typ), Loc)),
-
- Expression =>
- Unchecked_Convert_To (RTE (RE_Tag),
- New_Occurrence_Of
- (Node (First_Elmt (Access_Disp_Table (Full_Typ))),
- Loc))));
- end if;
-
- -- Adjust the component. Generate:
-
- -- [Deep_]Adjust (Rec_Comp);
-
- if Finalization_OK
- and then not Is_Limited_Type (Comp_Typ)
- and then not Is_Build_In_Place_Function_Call (Init_Expr)
- then
- Adj_Call :=
- Make_Adjust_Call
- (Obj_Ref => New_Copy_Tree (Rec_Comp),
- Typ => Comp_Typ);
-
- -- Guard against a missing [Deep_]Adjust when the component type
- -- was not properly frozen.
-
- if Present (Adj_Call) then
- Append_To (Blk_Stmts, Adj_Call);
- end if;
- end if;
-
- -- Complete the protection of the initialization statements
-
- if Finalization_OK and Abort_Allowed then
-
- -- Wrap the initialization statements in a block to catch a
- -- potential exception. Generate:
-
- -- begin
- -- Abort_Defer;
- -- Rec_Comp := Init_Expr;
- -- Rec_Comp._tag := Full_TypP;
- -- [Deep_]Adjust (Rec_Comp);
- -- at end
- -- Abort_Undefer_Direct;
- -- end;
-
- if Exceptions_OK then
- Append_To (Stmts,
- Build_Abort_Undefer_Block (Loc,
- Stmts => Blk_Stmts,
- Context => N));
-
- -- Otherwise exceptions are not propagated. Generate:
-
- -- Abort_Defer;
- -- Rec_Comp := Init_Expr;
- -- Rec_Comp._tag := Full_TypP;
- -- [Deep_]Adjust (Rec_Comp);
- -- Abort_Undefer;
-
- else
- Append_To (Blk_Stmts,
- Build_Runtime_Call (Loc, RE_Abort_Undefer));
- end if;
- end if;
- end Initialize_Record_Component;
-
-------------------------
-- Is_Int_Range_Bounds --
-------------------------
@@ -3828,8 +3281,9 @@ package body Exp_Aggr is
Prefix => New_Copy_Tree (Target),
Selector_Name => New_Occurrence_Of (Selector, Loc));
- Initialize_Record_Component
- (Rec_Comp => Comp_Expr,
+ Initialize_Simple_Component
+ (N => N,
+ Comp => Comp_Expr,
Comp_Typ => Etype (Selector),
Init_Expr => Get_Simple_Init_Val
(Typ => Etype (Selector),
@@ -4062,56 +3516,12 @@ package body Exp_Aggr is
end;
else
- -- Handle an initialization expression of a controlled type
- -- in case it denotes a function call. In general such a
- -- scenario will produce a transient scope, but this will
- -- lead to wrong order of initialization, adjustment, and
- -- finalization in the context of aggregates.
-
- -- Target.Comp := Ctrl_Func_Call;
-
- -- begin -- scope
- -- Trans_Obj : ... := Ctrl_Func_Call; -- object
- -- Target.Comp := Trans_Obj;
- -- Finalize (Trans_Obj);
- -- end
- -- Target.Comp._tag := ...;
- -- Adjust (Target.Comp);
-
- -- In the example above, the call to Finalize occurs too
- -- early and as a result it may leave the record component
- -- in a bad state. Finalization of the transient object
- -- should really happen after adjustment.
-
- -- To avoid this scenario, perform in-place side-effect
- -- removal of the function call. This eliminates the
- -- transient property of the function result and ensures
- -- correct order of actions.
-
- -- Res : ... := Ctrl_Func_Call;
- -- Target.Comp := Res;
- -- Target.Comp._tag := ...;
- -- Adjust (Target.Comp);
- -- Finalize (Res);
-
- if Needs_Finalization (Comp_Type)
- and then Nkind (Expr_Q) /= N_Aggregate
- then
- Initialize_Ctrl_Record_Component
- (Rec_Comp => Comp_Expr,
- Comp_Typ => Etype (Selector),
- Init_Expr => Expr_Q,
- Stmts => L);
-
- -- Otherwise perform single component initialization
-
- else
- Initialize_Record_Component
- (Rec_Comp => Comp_Expr,
- Comp_Typ => Etype (Selector),
- Init_Expr => Expr_Q,
- Stmts => L);
- end if;
+ Initialize_Component
+ (N => N,
+ Comp => Comp_Expr,
+ Comp_Typ => Etype (Selector),
+ Init_Expr => Expr_Q,
+ Stmts => L);
end if;
end if;
@@ -9025,6 +8435,316 @@ package body Exp_Aggr is
return False;
end Has_Default_Init_Comps;
+ --------------------------
+ -- Initialize_Component --
+ --------------------------
+
+ procedure Initialize_Component
+ (N : Node_Id;
+ Comp : Node_Id;
+ Comp_Typ : Entity_Id;
+ Init_Expr : Node_Id;
+ Stmts : List_Id) is
+ begin
+ -- Handle an initialization expression of a controlled type in
+ -- case it denotes a function call. In general such a scenario
+ -- will produce a transient scope, but this will lead to wrong
+ -- order of initialization, adjustment, and finalization in the
+ -- context of aggregates.
+
+ -- Comp := Ctrl_Func_Call;
+
+ -- begin -- scope
+ -- Trans_Obj : ... := Ctrl_Func_Call; -- object
+ -- Comp := Trans_Obj;
+ -- Finalize (Trans_Obj);
+ -- end;
+ -- Comp._tag := ...;
+ -- Adjust (Comp (1));
+
+ -- In the example above, the call to Finalize occurs too early
+ -- and as a result it may leave the array component in a bad
+ -- state. Finalization of the transient object should really
+ -- happen after adjustment.
+
+ -- To avoid this scenario, perform in-place side-effect removal
+ -- of the function call. This eliminates the transient property
+ -- of the function result and ensures correct order of actions.
+
+ -- Res : ... := Ctrl_Func_Call;
+ -- Comp := Res;
+ -- Comp._tag := ...;
+ -- Adjust (Comp);
+ -- Finalize (Res);
+
+ if Present (Comp_Typ)
+ and then Needs_Finalization (Comp_Typ)
+ and then Nkind (Unqualify (Init_Expr)) /= N_Aggregate
+ then
+ Initialize_Controlled_Component
+ (N => N,
+ Comp => Comp,
+ Comp_Typ => Comp_Typ,
+ Init_Expr => Init_Expr,
+ Stmts => Stmts);
+
+ -- Otherwise perform simple component initialization
+
+ else
+ Initialize_Simple_Component
+ (N => N,
+ Comp => Comp,
+ Comp_Typ => Comp_Typ,
+ Init_Expr => Init_Expr,
+ Stmts => Stmts);
+ end if;
+ end Initialize_Component;
+
+ -------------------------------------
+ -- Initialize_Controlled_Component --
+ -------------------------------------
+
+ procedure Initialize_Controlled_Component
+ (N : Node_Id;
+ Comp : Node_Id;
+ Comp_Typ : Entity_Id;
+ Init_Expr : Node_Id;
+ Stmts : List_Id)
+ is
+ Init_Expr_Q : constant Node_Id := Unqualify (Init_Expr);
+ Loc : constant Source_Ptr := Sloc (N);
+
+ Fin_Call : Node_Id;
+ Hook_Clear : Node_Id;
+
+ In_Place_Expansion : Boolean;
+ -- Flag set when a nonlimited controlled function call requires
+ -- in-place expansion.
+
+ begin
+ -- Perform a preliminary analysis and resolution to determine what
+ -- the initialization expression denotes. Unanalyzed function calls
+ -- may appear as identifiers or indexed components.
+
+ if Nkind (Init_Expr_Q) in N_Function_Call
+ | N_Identifier
+ | N_Indexed_Component
+ and then not Analyzed (Init_Expr)
+ then
+ Preanalyze_And_Resolve (Init_Expr, Comp_Typ);
+ end if;
+
+ In_Place_Expansion :=
+ Nkind (Init_Expr_Q) = N_Function_Call
+ and then not Is_Build_In_Place_Result_Type (Comp_Typ);
+
+ -- The initialization expression is a controlled function call.
+ -- Perform in-place removal of side effects to avoid creating a
+ -- transient scope.
+
+ -- This in-place expansion is not performed for limited transient
+ -- objects because the initialization is already done in place.
+
+ if In_Place_Expansion then
+
+ -- Suppress the removal of side effects by general analysis
+ -- because this behavior is emulated here. This avoids the
+ -- generation of a transient scope, which leads to out-of-order
+ -- adjustment and finalization.
+
+ Set_No_Side_Effect_Removal (Init_Expr);
+
+ -- Install all hook-related declarations and prepare the clean up
+ -- statements. The generated code follows the initialization order
+ -- of individual components and discriminants, rather than being
+ -- inserted prior to the aggregate. This ensures that a transient
+ -- component which mentions a discriminant has proper visibility
+ -- of the discriminant.
+
+ Process_Transient_Component
+ (Loc => Loc,
+ Comp_Typ => Comp_Typ,
+ Init_Expr => Init_Expr,
+ Fin_Call => Fin_Call,
+ Hook_Clear => Hook_Clear,
+ Stmts => Stmts);
+ end if;
+
+ -- Use the simple component initialization circuitry to assign the
+ -- result of the function call to the component. This also performs
+ -- tag adjustment and [deep] adjustment of the component.
+
+ Initialize_Simple_Component
+ (N => N,
+ Comp => Comp,
+ Comp_Typ => Comp_Typ,
+ Init_Expr => Init_Expr,
+ Stmts => Stmts);
+
+ -- At this point the component is fully initialized. Complete the
+ -- processing by finalizing the transient function result.
+
+ if In_Place_Expansion then
+ Process_Transient_Component_Completion
+ (Loc => Loc,
+ Aggr => N,
+ Fin_Call => Fin_Call,
+ Hook_Clear => Hook_Clear,
+ Stmts => Stmts);
+ end if;
+ end Initialize_Controlled_Component;
+
+ ---------------------------------
+ -- Initialize_Simple_Component --
+ ---------------------------------
+
+ procedure Initialize_Simple_Component
+ (N : Node_Id;
+ Comp : Node_Id;
+ Comp_Typ : Node_Id;
+ Init_Expr : Node_Id;
+ Stmts : List_Id)
+ is
+ Exceptions_OK : constant Boolean :=
+ not Restriction_Active (No_Exception_Propagation);
+ Finalization_OK : constant Boolean :=
+ Present (Comp_Typ)
+ and then Needs_Finalization (Comp_Typ);
+ Full_Typ : constant Entity_Id := Underlying_Type (Comp_Typ);
+ Loc : constant Source_Ptr := Sloc (N);
+
+ Adj_Call : Node_Id;
+ Blk_Stmts : List_Id;
+ Init_Stmt : Node_Id;
+
+ begin
+ pragma Assert (Nkind (Init_Expr) in N_Subexpr);
+
+ -- Protect the initialization statements from aborts. Generate:
+
+ -- Abort_Defer;
+
+ if Finalization_OK and Abort_Allowed then
+ if Exceptions_OK then
+ Blk_Stmts := New_List;
+ else
+ Blk_Stmts := Stmts;
+ end if;
+
+ Append_To (Blk_Stmts, Build_Runtime_Call (Loc, RE_Abort_Defer));
+
+ -- Otherwise aborts are not allowed. All generated code is added
+ -- directly to the input list.
+
+ else
+ Blk_Stmts := Stmts;
+ end if;
+
+ -- Initialize the component. Generate:
+
+ -- Comp := Init_Expr;
+
+ -- Note that the initialization expression is not duplicated because
+ -- either only a single component may be initialized by it (record)
+ -- or it has already been duplicated if need be (array).
+
+ Init_Stmt :=
+ Make_OK_Assignment_Statement (Loc,
+ Name => New_Copy_Tree (Comp),
+ Expression => Relocate_Node (Init_Expr));
+ Set_No_Ctrl_Actions (Init_Stmt);
+
+ Append_To (Blk_Stmts, Init_Stmt);
+
+ -- Adjust the tag due to a possible view conversion. Generate:
+
+ -- Comp._tag := Full_TypeP;
+
+ if Tagged_Type_Expansion
+ and then Present (Comp_Typ)
+ and then Is_Tagged_Type (Comp_Typ)
+ then
+ Append_To (Blk_Stmts,
+ Make_OK_Assignment_Statement (Loc,
+ Name =>
+ Make_Selected_Component (Loc,
+ Prefix => New_Copy_Tree (Comp),
+ Selector_Name =>
+ New_Occurrence_Of
+ (First_Tag_Component (Full_Typ), Loc)),
+
+ Expression =>
+ Unchecked_Convert_To (RTE (RE_Tag),
+ New_Occurrence_Of
+ (Node (First_Elmt (Access_Disp_Table (Full_Typ))),
+ Loc))));
+ end if;
+
+ -- Adjust the component. In the case of an array aggregate, controlled
+ -- subaggregates are not considered because each of their individual
+ -- elements will receive an adjustment of its own. Generate:
+
+ -- [Deep_]Adjust (Comp);
+
+ if Finalization_OK
+ and then not Is_Limited_Type (Comp_Typ)
+ and then not Is_Build_In_Place_Function_Call (Init_Expr)
+ and then not
+ (Is_Array_Type (Etype (N))
+ and then Is_Array_Type (Comp_Typ)
+ and then Needs_Finalization (Component_Type (Comp_Typ))
+ and then Nkind (Unqualify (Init_Expr)) = N_Aggregate)
+ then
+ Adj_Call :=
+ Make_Adjust_Call
+ (Obj_Ref => New_Copy_Tree (Comp),
+ Typ => Comp_Typ);
+
+ -- Guard against a missing [Deep_]Adjust when the component type
+ -- was not properly frozen.
+
+ if Present (Adj_Call) then
+ Append_To (Blk_Stmts, Adj_Call);
+ end if;
+ end if;
+
+ -- Complete the protection of the initialization statements
+
+ if Finalization_OK and Abort_Allowed then
+
+ -- Wrap the initialization statements in a block to catch a
+ -- potential exception. Generate:
+
+ -- begin
+ -- Abort_Defer;
+ -- Comp := Init_Expr;
+ -- Comp._tag := Full_TypP;
+ -- [Deep_]Adjust (Comp);
+ -- at end
+ -- Abort_Undefer_Direct;
+ -- end;
+
+ if Exceptions_OK then
+ Append_To (Stmts,
+ Build_Abort_Undefer_Block (Loc,
+ Stmts => Blk_Stmts,
+ Context => N));
+
+ -- Otherwise exceptions are not propagated. Generate:
+
+ -- Abort_Defer;
+ -- Comp := Init_Expr;
+ -- Comp._tag := Full_TypP;
+ -- [Deep_]Adjust (Comp);
+ -- Abort_Undefer;
+
+ else
+ Append_To (Blk_Stmts,
+ Build_Runtime_Call (Loc, RE_Abort_Undefer));
+ end if;
+ end if;
+ end Initialize_Simple_Component;
+
----------------------------------------
-- Is_Build_In_Place_Aggregate_Return --
----------------------------------------
--
2.40.0
^ permalink raw reply [flat|nested] only message in thread
only message in thread, other threads:[~2023-06-13 7:37 UTC | newest]
Thread overview: (only message) (download: mbox.gz / follow: Atom feed)
-- links below jump to the message on this page --
2023-06-13 7:37 [COMMITTED] ada: Factor common processing in expansion of aggregates Marc Poulhiès
This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).