From mboxrd@z Thu Jan 1 00:00:00 1970 Return-Path: Received: by sourceware.org (Postfix, from userid 7871) id CB2B1385558F; Thu, 5 Jan 2023 14:39:31 +0000 (GMT) DKIM-Filter: OpenDKIM Filter v2.11.0 sourceware.org CB2B1385558F DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=gcc.gnu.org; s=default; t=1672929571; bh=PQgMFoVxzyIvokC/mhZSA8IVv4aQJfz8NhoXbDCXSbQ=; h=From:To:Subject:Date:From; b=d5QgEov9xqUUg4k7/Umb6fv1HAVinuoumOd+w9plhwuMJ8OufpVPFO9BuK74TDWJn qku2ajy6XQ8WNRhrN8hMpPp3cyg0swub+j82vxCtI4ODdnHFODjpkrrJ7a/IJ498gz MrTh9Pbms0bL0whRzBr0f63abK5+mWZz8FxJpjy8= MIME-Version: 1.0 Content-Transfer-Encoding: 7bit Content-Type: text/plain; charset="utf-8" From: Marc Poulhi?s To: gcc-cvs@gcc.gnu.org Subject: [gcc r13-5029] ada: Clean up interface handling in Expand_N_Object_Declaration X-Act-Checkin: gcc X-Git-Author: Eric Botcazou X-Git-Refname: refs/heads/master X-Git-Oldrev: 9ff806899bfa38ade0bddbdfb413ca3444425bcf X-Git-Newrev: 09e0175327d333360fbe45346c411a8bc7eee1f1 Message-Id: <20230105143931.CB2B1385558F@sourceware.org> Date: Thu, 5 Jan 2023 14:39:31 +0000 (GMT) List-Id: https://gcc.gnu.org/g:09e0175327d333360fbe45346c411a8bc7eee1f1 commit r13-5029-g09e0175327d333360fbe45346c411a8bc7eee1f1 Author: Eric Botcazou Date: Wed Dec 21 12:41:50 2022 +0100 ada: Clean up interface handling in Expand_N_Object_Declaration 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. Diff: --- 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 ; -- 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;