* [Ada] Bad handling of array sliding in aggregate
@ 2021-04-29 8:03 Pierre-Marie de Rodat
0 siblings, 0 replies; only message in thread
From: Pierre-Marie de Rodat @ 2021-04-29 8:03 UTC (permalink / raw)
To: gcc-patches; +Cc: Arnaud Charlet
[-- Attachment #1: Type: text/plain, Size: 1384 bytes --]
In the case of an aggregate containing controlled array components,
if sliding of the indexes is involved, the components are prematurely
finalized without a corresponding initialization.
Also fix a latent bug in Exp_Aggr.Collect_Initialization_Statements
which was not always inserting Initialization_Statements properly when
the Node_After was empty (in the case of e.g. a single object
declaration). This is needed in order to take advantage of
Initialization_Statements in Expand_N_Object_Declaration: we scan
Initialization_Statements and if a call to xxxSA is found, it means we
need to initialize the corresponding array component before it gets
prematurely adjusted.
Tested on x86_64-pc-linux-gnu, committed on trunk
gcc/ada/
* exp_aggr.adb (Collect_Initialization_Statements): Removed.
(Convert_Aggr_In_Object_Decl, Expand_Array_Aggregate): Fix
creation and insertion of Initialization_Statements. Do not set
Initialization_Statements when a transient scope is involved.
Move processing of Array_Slice here. Ensure that an object with
an Array_Slice call gets its array component initialized. Add
comments.
* exp_ch7.adb: Update comments.
(Store_Actions_In_Scope): Deal properly with an empty list which
might now be generated by Convert_Aggr_In_Object_Decl.
* exp_ch3.adb: Update comments.
(Expand_N_Object_Declaration): Remove processing of Array_Slice.
[-- Attachment #2: patch.diff --]
[-- Type: text/x-diff, Size: 9974 bytes --]
diff --git a/gcc/ada/exp_aggr.adb b/gcc/ada/exp_aggr.adb
--- a/gcc/ada/exp_aggr.adb
+++ b/gcc/ada/exp_aggr.adb
@@ -78,15 +78,6 @@ package body Exp_Aggr is
type Case_Table_Type is array (Nat range <>) of Case_Bounds;
-- Table type used by Check_Case_Choices procedure
- procedure Collect_Initialization_Statements
- (Obj : Entity_Id;
- N : Node_Id;
- Node_After : Node_Id);
- -- If Obj is not frozen, collect actions inserted after N until, but not
- -- including, Node_After, for initialization of Obj, and move them to an
- -- expression with actions, which becomes the Initialization_Statements for
- -- Obj.
-
procedure Expand_Delta_Array_Aggregate (N : Node_Id; Deltas : List_Id);
procedure Expand_Delta_Record_Aggregate (N : Node_Id; Deltas : List_Id);
procedure Expand_Container_Aggregate (N : Node_Id);
@@ -4210,40 +4201,6 @@ package body Exp_Aggr is
return L;
end Build_Record_Aggr_Code;
- ---------------------------------------
- -- Collect_Initialization_Statements --
- ---------------------------------------
-
- procedure Collect_Initialization_Statements
- (Obj : Entity_Id;
- N : Node_Id;
- Node_After : Node_Id)
- is
- Loc : constant Source_Ptr := Sloc (N);
- Init_Actions : constant List_Id := New_List;
- Init_Node : Node_Id;
- Comp_Stmt : Node_Id;
-
- begin
- -- Nothing to do if Obj is already frozen, as in this case we known we
- -- won't need to move the initialization statements about later on.
-
- if Is_Frozen (Obj) then
- return;
- end if;
-
- Init_Node := N;
- while Next (Init_Node) /= Node_After loop
- Append_To (Init_Actions, Remove_Next (Init_Node));
- end loop;
-
- if not Is_Empty_List (Init_Actions) then
- Comp_Stmt := Make_Compound_Statement (Loc, Actions => Init_Actions);
- Insert_Action_After (Init_Node, Comp_Stmt);
- Set_Initialization_Statements (Obj, Comp_Stmt);
- end if;
- end Collect_Initialization_Statements;
-
-------------------------------
-- Convert_Aggr_In_Allocator --
-------------------------------
@@ -4314,6 +4271,8 @@ package body Exp_Aggr is
Typ : constant Entity_Id := Etype (Aggr);
Occ : constant Node_Id := New_Occurrence_Of (Obj, Loc);
+ Has_Transient_Scope : Boolean := False;
+
function Discriminants_Ok return Boolean;
-- If the object type is constrained, the discriminants in the
-- aggregate must be checked against the discriminants of the subtype.
@@ -4405,7 +4364,7 @@ package body Exp_Aggr is
-- the finalization list of the return must be moved to the caller's
-- finalization list to complete the return.
- -- However, if the aggregate is limited, it is built in place, and the
+ -- Similarly if the aggregate is limited, it is built in place, and the
-- controlled components are not assigned to intermediate temporaries
-- so there is no need for a transient scope in this case either.
@@ -4414,13 +4373,60 @@ package body Exp_Aggr is
and then not Is_Limited_Type (Typ)
then
Establish_Transient_Scope (Aggr, Manage_Sec_Stack => False);
+ Has_Transient_Scope := True;
end if;
declare
- Node_After : constant Node_Id := Next (N);
+ Stmts : constant List_Id := Late_Expansion (Aggr, Typ, Occ);
+ Stmt : Node_Id;
+ Param : Node_Id;
+
begin
- Insert_Actions_After (N, Late_Expansion (Aggr, Typ, Occ));
- Collect_Initialization_Statements (Obj, N, Node_After);
+ -- If Obj is already frozen or if N is wrapped in a transient scope,
+ -- Stmts do not need to be saved in Initialization_Statements since
+ -- there is no freezing issue.
+
+ if Is_Frozen (Obj) or else Has_Transient_Scope then
+ Insert_Actions_After (N, Stmts);
+ else
+ Stmt := Make_Compound_Statement (Sloc (N), Actions => Stmts);
+ Insert_Action_After (N, Stmt);
+
+ -- Insert_Action_After may freeze Obj in which case we should
+ -- remove the compound statement just created and simply insert
+ -- Stmts after N.
+
+ if Is_Frozen (Obj) then
+ Remove (Stmt);
+ Insert_Actions_After (N, Stmts);
+ else
+ Set_Initialization_Statements (Obj, Stmt);
+ end if;
+ end if;
+
+ -- If Typ has controlled components and a call to a Slice_Assign
+ -- procedure is part of the initialization statements, then we
+ -- need to initialize the array component since Slice_Assign will
+ -- need to adjust it.
+
+ if Has_Controlled_Component (Typ) then
+ Stmt := First (Stmts);
+
+ while Present (Stmt) loop
+ if Nkind (Stmt) = N_Procedure_Call_Statement
+ and then Get_TSS_Name (Entity (Name (Stmt)))
+ = TSS_Slice_Assign
+ then
+ Param := First (Parameter_Associations (Stmt));
+ Insert_Actions
+ (Stmt,
+ Build_Initialization_Call
+ (Sloc (N), New_Copy_Tree (Param), Etype (Param)));
+ end if;
+
+ Next (Stmt);
+ end loop;
+ end if;
end;
Set_No_Initialization (N);
@@ -6793,6 +6799,7 @@ package body Exp_Aggr is
-- 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
@@ -6800,18 +6807,18 @@ package body Exp_Aggr is
and then Comes_From_Source (Parent (N))
and then Tmp = Defining_Entity (Parent (N)))
then
- declare
- Node_After : constant Node_Id := Next (Parent_Node);
-
- begin
+ if Parent_Kind /= N_Object_Declaration or else Is_Frozen (Tmp) then
Insert_Actions_After (Parent_Node, Aggr_Code);
-
- if Parent_Kind = N_Object_Declaration then
- Collect_Initialization_Statements
- (Obj => Tmp, N => Parent_Node, Node_After => Node_After);
- end if;
- end;
-
+ 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;
diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb
--- a/gcc/ada/exp_ch3.adb
+++ b/gcc/ada/exp_ch3.adb
@@ -124,7 +124,7 @@ package body Exp_Ch3 is
-- Build assignment procedure for one-dimensional arrays of controlled
-- types. Other array and slice assignments are expanded in-line, but
-- the code expansion for controlled components (when control actions
- -- are active) can lead to very large blocks that GCC3 handles poorly.
+ -- are active) can lead to very large blocks that GCC handles poorly.
procedure Build_Untagged_Equality (Typ : Entity_Id);
-- AI05-0123: Equality on untagged records composes. This procedure
@@ -4168,7 +4168,7 @@ package body Exp_Ch3 is
-- Generates the following subprogram:
- -- procedure Assign
+ -- procedure array_typeSA
-- (Source, Target : Array_Type,
-- Left_Lo, Left_Hi : Index;
-- Right_Lo, Right_Hi : Index;
@@ -4178,7 +4178,6 @@ package body Exp_Ch3 is
-- Ri1 : Index;
-- begin
-
-- if Left_Hi < Left_Lo then
-- return;
-- end if;
@@ -4204,7 +4203,7 @@ package body Exp_Ch3 is
-- Ri1 := Index'succ (Ri1);
-- end if;
-- end loop;
- -- end Assign;
+ -- end array_typeSA;
procedure Build_Slice_Assignment (Typ : Entity_Id) is
Loc : constant Source_Ptr := Sloc (Typ);
@@ -6561,7 +6560,7 @@ package body Exp_Ch3 is
if Needs_Finalization (Typ) and then not No_Initialization (N) then
Obj_Init :=
Make_Init_Call
- (Obj_Ref => New_Occurrence_Of (Def_Id, Loc),
+ (Obj_Ref => New_Object_Reference,
Typ => Typ);
end if;
@@ -6977,11 +6976,7 @@ package body Exp_Ch3 is
else
-- Obtain actual expression from qualified expression
- if Nkind (Expr) = N_Qualified_Expression then
- Expr_Q := Expression (Expr);
- else
- Expr_Q := Expr;
- end if;
+ Expr_Q := Unqualify (Expr);
-- When we have the appropriate type of aggregate in the expression
-- (it has been determined during analysis of the aggregate by
diff --git a/gcc/ada/exp_ch7.adb b/gcc/ada/exp_ch7.adb
--- a/gcc/ada/exp_ch7.adb
+++ b/gcc/ada/exp_ch7.adb
@@ -153,9 +153,6 @@ package body Exp_Ch7 is
procedure Set_Node_To_Be_Wrapped (N : Node_Id);
-- Set the field Node_To_Be_Wrapped of the current scope
- -- ??? The entire comment needs to be rewritten
- -- ??? which entire comment?
-
procedure Store_Actions_In_Scope (AK : Scope_Action_Kind; L : List_Id);
-- Shared processing for Store_xxx_Actions_In_Scope
@@ -9841,7 +9838,7 @@ package body Exp_Ch7 is
Actions : List_Id renames SE.Actions_To_Be_Wrapped (AK);
begin
- if No (Actions) then
+ if Is_Empty_List (Actions) then
Actions := L;
if Is_List_Member (SE.Node_To_Be_Wrapped) then
^ permalink raw reply [flat|nested] only message in thread
only message in thread, other threads:[~2021-04-29 8:03 UTC | newest]
Thread overview: (only message) (download: mbox.gz / follow: Atom feed)
-- links below jump to the message on this page --
2021-04-29 8:03 [Ada] Bad handling of array sliding in aggregate Pierre-Marie de Rodat
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).