* [COMMITTED] ada: Factor out tag assignments from type in expander
@ 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>
They are performed in a few different places during expansion.
gcc/ada/
* exp_util.ads (Make_Tag_Assignment_From_Type): Declare.
* exp_util.adb (Make_Tag_Assignment_From_Type): New function.
* exp_aggr.adb (Build_Record_Aggr_Code): Call the above function.
(Initialize_Simple_Component): Likewise.
* exp_ch3.adb (Build_Record_Init_Proc.Build_Assignment): Likewise.
(Build_Record_Init_Proc.Build_Init_Procedure ): Likewise.
(Make_Tag_Assignment): Likewise. Rename local variable and call
Unqualify to go through qualified expressions.
* exp_ch4.adb (Expand_Allocator_Expression): Likewise.
Tested on x86_64-pc-linux-gnu, committed on master.
---
gcc/ada/exp_aggr.adb | 47 ++++-------------------------
gcc/ada/exp_ch3.adb | 72 +++++++++-----------------------------------
gcc/ada/exp_ch4.adb | 28 ++---------------
gcc/ada/exp_util.adb | 27 +++++++++++++++++
gcc/ada/exp_util.ads | 7 +++++
5 files changed, 57 insertions(+), 124 deletions(-)
diff --git a/gcc/ada/exp_aggr.adb b/gcc/ada/exp_aggr.adb
index 8c6c9f97429..c145d79f482 100644
--- a/gcc/ada/exp_aggr.adb
+++ b/gcc/ada/exp_aggr.adb
@@ -3095,22 +3095,9 @@ package body Exp_Aggr is
if Tagged_Type_Expansion then
Instr :=
- Make_OK_Assignment_Statement (Loc,
- Name =>
- Make_Selected_Component (Loc,
- Prefix => New_Copy_Tree (Target),
- Selector_Name =>
- New_Occurrence_Of
- (First_Tag_Component (Base_Type (Typ)), Loc)),
-
- Expression =>
- Unchecked_Convert_To (RTE (RE_Tag),
- New_Occurrence_Of
- (Node (First_Elmt
- (Access_Disp_Table (Base_Type (Typ)))),
- Loc)));
+ Make_Tag_Assignment_From_Type
+ (Loc, New_Copy_Tree (Target), Base_Type (Typ));
- Set_Assignment_OK (Name (Instr));
Append_To (Assign, Instr);
-- Ada 2005 (AI-251): If tagged type has progenitors we must
@@ -3629,19 +3616,8 @@ package body Exp_Aggr is
elsif Is_Tagged_Type (Typ) and then Tagged_Type_Expansion then
Instr :=
- Make_OK_Assignment_Statement (Loc,
- Name =>
- Make_Selected_Component (Loc,
- Prefix => New_Copy_Tree (Target),
- Selector_Name =>
- New_Occurrence_Of
- (First_Tag_Component (Base_Type (Typ)), Loc)),
-
- Expression =>
- Unchecked_Convert_To (RTE (RE_Tag),
- New_Occurrence_Of
- (Node (First_Elmt (Access_Disp_Table (Base_Type (Typ)))),
- Loc)));
+ Make_Tag_Assignment_From_Type
+ (Loc, New_Copy_Tree (Target), Base_Type (Typ));
Append_To (L, Instr);
@@ -8761,19 +8737,8 @@ package body Exp_Aggr is
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))));
+ Make_Tag_Assignment_From_Type
+ (Loc, New_Copy_Tree (Comp), Full_Typ));
end if;
-- Adjust the component. In the case of an array aggregate, controlled
diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb
index 91dcfa0f643..fbedc16ddd0 100644
--- a/gcc/ada/exp_ch3.adb
+++ b/gcc/ada/exp_ch3.adb
@@ -2150,21 +2150,10 @@ package body Exp_Ch3 is
and then Nkind (Exp_Q) /= N_Raise_Expression
then
Append_To (Res,
- Make_Assignment_Statement (Default_Loc,
- Name =>
- Make_Selected_Component (Default_Loc,
- Prefix =>
- New_Copy_Tree (Lhs, New_Scope => Proc_Id),
- Selector_Name =>
- New_Occurrence_Of
- (First_Tag_Component (Typ), Default_Loc)),
-
- Expression =>
- Unchecked_Convert_To (RTE (RE_Tag),
- New_Occurrence_Of
- (Node (First_Elmt (Access_Disp_Table (Underlying_Type
- (Typ)))),
- Default_Loc))));
+ Make_Tag_Assignment_From_Type
+ (Default_Loc,
+ New_Copy_Tree (Lhs, New_Scope => Proc_Id),
+ Underlying_Type (Typ)));
end if;
-- Adjust the component if controlled except if it is an aggregate
@@ -2791,17 +2780,8 @@ package body Exp_Ch3 is
-- Initialize the primary tag component
Init_Tags_List := New_List (
- Make_Assignment_Statement (Loc,
- Name =>
- Make_Selected_Component (Loc,
- Prefix => Make_Identifier (Loc, Name_uInit),
- Selector_Name =>
- New_Occurrence_Of
- (First_Tag_Component (Rec_Type), Loc)),
- Expression =>
- New_Occurrence_Of
- (Node
- (First_Elmt (Access_Disp_Table (Rec_Type))), Loc)));
+ Make_Tag_Assignment_From_Type
+ (Loc, Make_Identifier (Loc, Name_uInit), Rec_Type));
-- Ada 2005 (AI-251): Initialize the secondary tags components
-- located at fixed positions (tags whose position depends on
@@ -2880,17 +2860,8 @@ package body Exp_Ch3 is
-- Initialize the primary tag
Init_Tags_List := New_List (
- Make_Assignment_Statement (Loc,
- Name =>
- Make_Selected_Component (Loc,
- Prefix => Make_Identifier (Loc, Name_uInit),
- Selector_Name =>
- New_Occurrence_Of
- (First_Tag_Component (Rec_Type), Loc)),
- Expression =>
- New_Occurrence_Of
- (Node
- (First_Elmt (Access_Disp_Table (Rec_Type))), Loc)));
+ Make_Tag_Assignment_From_Type
+ (Loc, Make_Identifier (Loc, Name_uInit), Rec_Type));
-- Ada 2005 (AI-251): Initialize the secondary tags components
-- located at fixed positions (tags whose position depends on
@@ -12078,13 +12049,11 @@ package body Exp_Ch3 is
function Make_Tag_Assignment (N : Node_Id) return Node_Id is
Loc : constant Source_Ptr := Sloc (N);
- Def_If : constant Entity_Id := Defining_Identifier (N);
+ Def_Id : constant Entity_Id := Defining_Identifier (N);
Expr : constant Node_Id := Expression (N);
- Typ : constant Entity_Id := Etype (Def_If);
+ Typ : constant Entity_Id := Etype (Def_Id);
Full_Typ : constant Entity_Id := Underlying_Type (Typ);
- New_Ref : Node_Id;
-
begin
-- This expansion activity is called during analysis
@@ -12092,25 +12061,12 @@ package body Exp_Ch3 is
and then not Is_Class_Wide_Type (Typ)
and then not Is_CPP_Class (Typ)
and then Tagged_Type_Expansion
- and then Nkind (Expr) /= N_Aggregate
- and then (Nkind (Expr) /= N_Qualified_Expression
- or else Nkind (Expression (Expr)) /= N_Aggregate)
+ and then Nkind (Unqualify (Expr)) /= N_Aggregate
then
- New_Ref :=
- Make_Selected_Component (Loc,
- Prefix => New_Occurrence_Of (Def_If, Loc),
- Selector_Name =>
- New_Occurrence_Of (First_Tag_Component (Full_Typ), Loc));
-
- Set_Assignment_OK (New_Ref);
-
return
- Make_Assignment_Statement (Loc,
- Name => New_Ref,
- Expression =>
- Unchecked_Convert_To (RTE (RE_Tag),
- New_Occurrence_Of
- (Node (First_Elmt (Access_Disp_Table (Full_Typ))), Loc)));
+ Make_Tag_Assignment_From_Type
+ (Loc, New_Occurrence_Of (Def_Id, Loc), Full_Typ);
+
else
return Empty;
end if;
diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb
index 537d7a6311c..fdaeb50512f 100644
--- a/gcc/ada/exp_ch4.adb
+++ b/gcc/ada/exp_ch4.adb
@@ -567,7 +567,6 @@ package body Exp_Ch4 is
Adj_Call : Node_Id;
Aggr_In_Place : Boolean;
Node : Node_Id;
- Tag_Assign : Node_Id;
Temp : Entity_Id;
Temp_Decl : Node_Id;
@@ -923,30 +922,9 @@ package body Exp_Ch4 is
end if;
if Present (TagT) then
- declare
- Full_T : constant Entity_Id := Underlying_Type (TagT);
-
- begin
- Tag_Assign :=
- Make_Assignment_Statement (Loc,
- Name =>
- Make_Selected_Component (Loc,
- Prefix => TagR,
- Selector_Name =>
- New_Occurrence_Of
- (First_Tag_Component (Full_T), Loc)),
-
- Expression =>
- Unchecked_Convert_To (RTE (RE_Tag),
- New_Occurrence_Of
- (Elists.Node
- (First_Elmt (Access_Disp_Table (Full_T))), Loc)));
- end;
-
- -- The previous assignment has to be done in any case
-
- Set_Assignment_OK (Name (Tag_Assign));
- Insert_Action (N, Tag_Assign);
+ Insert_Action (N,
+ Make_Tag_Assignment_From_Type
+ (Loc, TagR, Underlying_Type (TagT)));
end if;
-- Generate an Adjust call if the object will be moved. In Ada 2005,
diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb
index da2d8137f6b..def027f2db6 100644
--- a/gcc/ada/exp_util.adb
+++ b/gcc/ada/exp_util.adb
@@ -10335,6 +10335,33 @@ package body Exp_Util is
Constraints => List_Constr));
end Make_Subtype_From_Expr;
+ -----------------------------------
+ -- Make_Tag_Assignment_From_Type --
+ -----------------------------------
+
+ function Make_Tag_Assignment_From_Type
+ (Loc : Source_Ptr;
+ Target : Node_Id;
+ Typ : Entity_Id) return Node_Id
+ is
+ Nam : constant Node_Id :=
+ Make_Selected_Component (Loc,
+ Prefix => Target,
+ Selector_Name =>
+ New_Occurrence_Of (First_Tag_Component (Typ), Loc));
+
+ begin
+ Set_Assignment_OK (Nam);
+
+ return
+ Make_Assignment_Statement (Loc,
+ Name => Nam,
+ Expression =>
+ Unchecked_Convert_To (RTE (RE_Tag),
+ New_Occurrence_Of
+ (Node (First_Elmt (Access_Disp_Table (Typ))), Loc)));
+ end Make_Tag_Assignment_From_Type;
+
-----------------------------
-- Make_Variant_Comparison --
-----------------------------
diff --git a/gcc/ada/exp_util.ads b/gcc/ada/exp_util.ads
index eef6800f371..06bd4141c27 100644
--- a/gcc/ada/exp_util.ads
+++ b/gcc/ada/exp_util.ads
@@ -925,6 +925,13 @@ package Exp_Util is
-- wide type. Set Related_Id to request an external name for the subtype
-- rather than an internal temporary.
+ function Make_Tag_Assignment_From_Type
+ (Loc : Source_Ptr;
+ Target : Node_Id;
+ Typ : Entity_Id) return Node_Id;
+ -- Return an assignment of the tag of tagged type Typ to prefix Target,
+ -- which must be a record object of a descendant of Typ.
+
function Make_Variant_Comparison
(Loc : Source_Ptr;
Typ : Entity_Id;
--
2.40.0
^ permalink raw reply [flat|nested] only message in thread
only message in thread, other threads:[~2023-06-13 7:38 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 out tag assignments from type in expander 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).