* [COMMITTED] ada: Clean up interface handling in Expand_N_Object_Declaration
@ 2023-01-05 14:41 Marc Poulhiès
0 siblings, 0 replies; only message in thread
From: Marc Poulhiès @ 2023-01-05 14:41 UTC (permalink / raw)
To: gcc-patches; +Cc: Eric Botcazou
From: Eric Botcazou <ebotcazou@adacore.com>
The code performing the expansion of objects with (class-wide) interface
type in Expand_N_Object_Declaration is fairly low-level, fiddling with the
homonym and entity chains, which is unnecessary.
gcc/ada/
* exp_ch3.adb (Expand_N_Object_Declaration): Rewrite the end of the
handling of objects with (class-wide) interface type by using the
same idiom as the other cases generating a renaming.
* exp_util.adb (Is_Displacement_Of_Object_Or_Function_Result): Tweak
pattern matching code and exclude special return objects.
(Requires_Cleanup_Actions): Adjust comment.
* exp_ch7.adb (Build_Finalizer): Likewise.
Tested on x86_64-pc-linux-gnu, committed on master.
---
gcc/ada/exp_ch3.adb | 155 ++++++++++++++++---------------------------
gcc/ada/exp_ch7.adb | 13 ++--
gcc/ada/exp_util.adb | 39 +++++++----
3 files changed, 93 insertions(+), 114 deletions(-)
diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb
index 23a910ecdba..fc4089dc123 100644
--- a/gcc/ada/exp_ch3.adb
+++ b/gcc/ada/exp_ch3.adb
@@ -7501,12 +7501,14 @@ package body Exp_Ch3 is
elsif Tagged_Type_Expansion then
declare
- Iface : constant Entity_Id := Root_Type (Typ);
- Expr_N : Node_Id := Expr;
- Expr_Typ : Entity_Id;
- New_Expr : Node_Id;
- Obj_Id : Entity_Id;
- Tag_Comp : Node_Id;
+ Iface : constant Entity_Id := Root_Type (Typ);
+
+ Expr_Typ : Entity_Id;
+ New_Expr : Node_Id;
+ Obj_Id : Entity_Id;
+ Ptr_Obj_Decl : Node_Id;
+ Ptr_Obj_Id : Entity_Id;
+ Tag_Comp : Node_Id;
begin
-- If the original node of the expression was a conversion
@@ -7516,26 +7518,27 @@ package body Exp_Ch3 is
-- component. This code must be kept synchronized with the
-- expansion done by routine Expand_Interface_Conversion
- if not Comes_From_Source (Expr_N)
- and then Nkind (Expr_N) = N_Explicit_Dereference
- and then Nkind (Original_Node (Expr_N)) = N_Type_Conversion
- and then Etype (Original_Node (Expr_N)) = Typ
+ if not Comes_From_Source (Expr)
+ and then Nkind (Expr) = N_Explicit_Dereference
+ and then Nkind (Original_Node (Expr)) = N_Type_Conversion
+ and then Etype (Original_Node (Expr)) = Typ
then
- Rewrite (Expr_N, Original_Node (Expression (N)));
+ Rewrite (Expr, Original_Node (Expression (N)));
end if;
-- Avoid expansion of redundant interface conversion
- if Is_Interface (Etype (Expr_N))
- and then Nkind (Expr_N) = N_Type_Conversion
- and then Etype (Expr_N) = Typ
+ if Is_Interface (Etype (Expr))
+ and then Nkind (Expr) = N_Type_Conversion
+ and then Etype (Expr) = Typ
then
- Expr_N := Expression (Expr_N);
- Set_Expression (N, Expr_N);
+ Expr_Q := Expression (Expr);
+ else
+ Expr_Q := Expr;
end if;
- Obj_Id := Make_Temporary (Loc, 'D', Expr_N);
- Expr_Typ := Base_Type (Etype (Expr_N));
+ Obj_Id := Make_Temporary (Loc, 'D', Expr_Q);
+ Expr_Typ := Base_Type (Etype (Expr_Q));
if Is_Class_Wide_Type (Expr_Typ) then
Expr_Typ := Root_Type (Expr_Typ);
@@ -7544,12 +7547,13 @@ package body Exp_Ch3 is
-- Replace
-- CW : I'Class := Obj;
-- by
- -- Tmp : T := Obj;
+ -- Tmp : Typ := Obj;
-- type Ityp is not null access I'Class;
- -- CW : I'Class renames Ityp (Tmp.I_Tag'Address).all;
+ -- Rnn : constant Ityp := Ityp (Tmp.I_Tag'Address);
+ -- CW : I'Class renames Rnn.all;
- if Comes_From_Source (Expr_N)
- and then Nkind (Expr_N) = N_Identifier
+ if Comes_From_Source (Expr_Q)
+ and then Is_Entity_Name (Expr_Q)
and then not Is_Interface (Expr_Typ)
and then Interface_Present_In_Ancestor (Expr_Typ, Typ)
and then (Expr_Typ = Etype (Expr_Typ)
@@ -7563,7 +7567,7 @@ package body Exp_Ch3 is
Defining_Identifier => Obj_Id,
Object_Definition =>
New_Occurrence_Of (Expr_Typ, Loc),
- Expression => Relocate_Node (Expr_N)));
+ Expression => Relocate_Node (Expr_Q)));
-- Statically reference the tag associated with the
-- interface
@@ -7582,8 +7586,9 @@ package body Exp_Ch3 is
-- implicit subtype CW is <Class_Wide_Subtype>;
-- Tmp : CW := CW!(Obj);
-- type Ityp is not null access I'Class;
- -- IW : I'Class renames
- -- Ityp!(Displace (Temp'Address, I'Tag)).all;
+ -- Rnn : constant Ityp :=
+ -- Ityp!(Displace (Tmp'Address, I'Tag));
+ -- IW : I'Class renames Rnn.all;
else
-- Generate the equivalent record type and update the
@@ -7593,10 +7598,10 @@ package body Exp_Ch3 is
(N => N,
Unc_Type => Typ,
Subtype_Indic => Obj_Def,
- Exp => Expr_N);
+ Exp => Expr_Q);
- if not Is_Interface (Etype (Expr_N)) then
- New_Expr := Relocate_Node (Expr_N);
+ if not Is_Interface (Etype (Expr_Q)) then
+ New_Expr := Relocate_Node (Expr_Q);
-- For interface types we use 'Address which displaces
-- the pointer to the base of the object (if required)
@@ -7607,7 +7612,7 @@ package body Exp_Ch3 is
Make_Explicit_Dereference (Loc,
Unchecked_Convert_To (RTE (RE_Tag_Ptr),
Make_Attribute_Reference (Loc,
- Prefix => Relocate_Node (Expr_N),
+ Prefix => Relocate_Node (Expr_Q),
Attribute_Name => Name_Address))));
end if;
@@ -7625,7 +7630,7 @@ package body Exp_Ch3 is
-- This case occurs when the initialization expression
-- has been previously expanded into a temporary object.
- else pragma Assert (not Comes_From_Source (Expr_Q));
+ else
Insert_Action (N,
Make_Object_Renaming_Declaration (Loc,
Defining_Identifier => Obj_Id,
@@ -7651,80 +7656,38 @@ package body Exp_Ch3 is
Loc)));
end if;
- Rewrite (N,
- Make_Object_Renaming_Declaration (Loc,
- Defining_Identifier => Make_Temporary (Loc, 'D'),
- Subtype_Mark => New_Occurrence_Of (Typ, Loc),
- Name =>
- Convert_Tag_To_Interface (Typ, Tag_Comp)));
-
- -- If the original entity comes from source, then mark the
- -- new entity as needing debug information, even though it's
- -- defined by a generated renaming that does not come from
- -- source, so that Materialize_Entity will be set on the
- -- entity when Debug_Renaming_Declaration is called during
- -- analysis.
-
- if Comes_From_Source (Def_Id) then
- Set_Debug_Info_Needed (Defining_Identifier (N));
- end if;
-
- Analyze (N, Suppress => All_Checks);
-
- -- Replace internal identifier of rewritten node by the
- -- identifier found in the sources. We also have to exchange
- -- entities containing their defining identifiers to ensure
- -- the correct replacement of the object declaration by this
- -- object renaming declaration because these identifiers
- -- were previously added by Enter_Name to the current scope.
- -- We must preserve the homonym chain of the source entity
- -- as well. We must also preserve the kind of the entity,
- -- which may be a constant. Preserve entity chain because
- -- itypes may have been generated already, and the full
- -- chain must be preserved for final freezing. Finally,
- -- preserve Comes_From_Source setting, so that debugging
- -- and cross-referencing information is properly kept, and
- -- preserve source location, to prevent spurious errors when
- -- entities are declared (they must have their own Sloc).
-
- declare
- New_Id : constant Entity_Id := Defining_Identifier (N);
- Next_Temp : constant Entity_Id := Next_Entity (New_Id);
- Save_CFS : constant Boolean :=
- Comes_From_Source (Def_Id);
- Save_SP : constant Node_Id := SPARK_Pragma (Def_Id);
- Save_SPI : constant Boolean :=
- SPARK_Pragma_Inherited (Def_Id);
-
- begin
- Link_Entities (New_Id, Next_Entity (Def_Id));
- Link_Entities (Def_Id, Next_Temp);
+ -- As explained in Exp_Disp, we use Convert_Tag_To_Interface
+ -- to do the final conversion, but we insert an intermediate
+ -- temporary before the dereference so that we can process
+ -- the expansion as part of the analysis of the declaration
+ -- of this temporary, and then rewrite manually the original
+ -- object as the simple renaming of this dereference.
- Set_Chars (Defining_Identifier (N), Chars (Def_Id));
- Set_Homonym (Defining_Identifier (N), Homonym (Def_Id));
- Mutate_Ekind (Defining_Identifier (N), Ekind (Def_Id));
- Set_Sloc (Defining_Identifier (N), Sloc (Def_Id));
+ Tag_Comp := Convert_Tag_To_Interface (Typ, Tag_Comp);
+ pragma Assert (Nkind (Tag_Comp) = N_Explicit_Dereference
+ and then
+ Nkind (Prefix (Tag_Comp)) = N_Unchecked_Type_Conversion);
- Set_Comes_From_Source (Def_Id, False);
+ Ptr_Obj_Id := Make_Temporary (Loc, 'R');
- -- ??? This is extremely dangerous!!! Exchanging entities
- -- is very low level, and as a result it resets flags and
- -- fields which belong to the original Def_Id. Several of
- -- these attributes are saved and restored, but there may
- -- be many more that need to be preserverd.
+ Ptr_Obj_Decl :=
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Ptr_Obj_Id,
+ Constant_Present => True,
+ Object_Definition =>
+ New_Occurrence_Of
+ (Entity (Subtype_Mark (Prefix (Tag_Comp))), Loc),
+ Expression => Prefix (Tag_Comp));
- Exchange_Entities (Defining_Identifier (N), Def_Id);
+ Insert_Action (N, Ptr_Obj_Decl, Suppress => All_Checks);
- -- Restore clobbered attributes
+ Set_Prefix (Tag_Comp, New_Occurrence_Of (Ptr_Obj_Id, Loc));
+ Expr_Q := Tag_Comp;
+ Set_Etype (Expr_Q, Typ);
- Set_Comes_From_Source (Def_Id, Save_CFS);
- Set_SPARK_Pragma (Def_Id, Save_SP);
- Set_SPARK_Pragma_Inherited (Def_Id, Save_SPI);
- end;
+ Rewrite_As_Renaming := True;
end;
- return;
-
else
return;
end if;
diff --git a/gcc/ada/exp_ch7.adb b/gcc/ada/exp_ch7.adb
index b20d7dbed5f..4cb26890ea2 100644
--- a/gcc/ada/exp_ch7.adb
+++ b/gcc/ada/exp_ch7.adb
@@ -2391,14 +2391,17 @@ package body Exp_Ch7 is
-- Detect a case where a source object has been initialized by
-- a controlled function call or another object which was later
- -- rewritten as a class-wide conversion of Ada.Tags.Displace.
+ -- rewritten as a class-wide conversion of Ada.Tags.Displace:
- -- Obj1 : CW_Type := Src_Obj;
- -- Obj2 : CW_Type := Function_Call (...);
+ -- Obj1 : CW_Type := Function_Call (...);
+ -- Obj2 : CW_Type := Src_Obj;
- -- Obj1 : CW_Type renames (... Ada.Tags.Displace (Src_Obj));
-- Tmp : ... := Function_Call (...)'reference;
- -- Obj2 : CW_Type renames (... Ada.Tags.Displace (Tmp));
+ -- Rnn : access CW_Type := (... Ada.Tags.Displace (Tmp));
+ -- Obj1 : CW_Type renames Rnn.all;
+
+ -- Rnn : access CW_Type := (...Ada.Tags.Displace (Src_Obj));
+ -- Obj2 : CW_Type renames Rnn.all;
elsif Is_Displacement_Of_Object_Or_Function_Result (Obj_Id) then
Processing_Actions (Has_No_Init => True);
diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb
index 9fbd6dfbd82..245c3cd9dc7 100644
--- a/gcc/ada/exp_util.adb
+++ b/gcc/ada/exp_util.adb
@@ -8339,8 +8339,9 @@ package body Exp_Util is
-- is rewritten into:
- -- Temp : ... := Function_Call (...)'reference;
- -- Obj : CW_Type renames (... Ada.Tags.Displace (Temp));
+ -- Tmp : ... := Function_Call (...)'reference;
+ -- Rnn : constant access CW_Type := (... Ada.Tags.Displace (Tmp));
+ -- Obj : CW_Type renames Rnn.all;
-- where the return type of the function and the class-wide type require
-- dispatch table pointer displacement.
@@ -8351,8 +8352,9 @@ package body Exp_Util is
-- is rewritten into:
- -- Temp : ... := Function_Call (Container, ...)'reference;
- -- Obj : CW_Type renames (... Ada.Tags.Displace (Temp));
+ -- Tmp : ... := Function_Call (Container, ...)'reference;
+ -- Rnn : constant access CW_Type := (... Ada.Tags.Displace (Tmp));
+ -- Obj : CW_Type renames Rnn.all;
-- where the container element type and the class-wide type require
-- dispatch table pointer dispacement.
@@ -8363,14 +8365,21 @@ package body Exp_Util is
-- is rewritten into:
- -- Obj : CW_Type renames (... Ada.Tags.Displace (Src_Obj));
+ -- Rnn : constant access CW_Type := (...Ada.Tags.Displace (Src_Obj));
+ -- Obj : CW_Type renames Rnn.all;
-- where the type of the source object and the class-wide type require
-- dispatch table pointer displacement.
if Nkind (Obj_Decl) = N_Object_Renaming_Declaration
and then Is_Class_Wide_Type (Obj_Typ)
- and then Is_Displace_Call (Renamed_Object (Obj_Id))
+ and then not Is_Special_Return_Object (Obj_Id)
+ and then Nkind (Renamed_Object (Obj_Id)) = N_Explicit_Dereference
+ and then Is_Entity_Name (Prefix (Renamed_Object (Obj_Id)))
+ and then Ekind (Entity (Prefix (Renamed_Object (Obj_Id)))) = E_Constant
+ and then
+ Is_Displace_Call
+ (Constant_Value (Entity (Prefix (Renamed_Object (Obj_Id)))))
and then Nkind (Orig_Decl) = N_Object_Declaration
and then Comes_From_Source (Orig_Decl)
then
@@ -8380,9 +8389,10 @@ package body Exp_Util is
Is_Controlled_Function_Call (Orig_Expr)
or else Is_Controlled_Indexing (Orig_Expr)
or else Is_Source_Object (Orig_Expr);
- end if;
- return False;
+ else
+ return False;
+ end if;
end Is_Displacement_Of_Object_Or_Function_Result;
------------------------------
@@ -12968,14 +12978,17 @@ package body Exp_Util is
-- Detect a case where a source object has been initialized by
-- a controlled function call or another object which was later
- -- rewritten as a class-wide conversion of Ada.Tags.Displace.
+ -- rewritten as a class-wide conversion of Ada.Tags.Displace:
- -- Obj1 : CW_Type := Src_Obj;
- -- Obj2 : CW_Type := Function_Call (...);
+ -- Obj1 : CW_Type := Function_Call (...);
+ -- Obj2 : CW_Type := Src_Obj;
- -- Obj1 : CW_Type renames (... Ada.Tags.Displace (Src_Obj));
-- Tmp : ... := Function_Call (...)'reference;
- -- Obj2 : CW_Type renames (... Ada.Tags.Displace (Tmp));
+ -- Rnn : access CW_Type := (... Ada.Tags.Displace (Tmp));
+ -- Obj1 : CW_Type renames Rnn.all;
+
+ -- Rnn : access CW_Type := (... Ada.Tags.Displace (Src_Obj));
+ -- Obj2 : CW_Type renames Rnn.all;
elsif Is_Displacement_Of_Object_Or_Function_Result (Obj_Id) then
return True;
--
2.34.1
^ permalink raw reply [flat|nested] only message in thread
only message in thread, other threads:[~2023-01-05 14:41 UTC | newest]
Thread overview: (only message) (download: mbox.gz / follow: Atom feed)
-- links below jump to the message on this page --
2023-01-05 14:41 [COMMITTED] ada: Clean up interface handling in Expand_N_Object_Declaration 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).