From mboxrd@z Thu Jan 1 00:00:00 1970 Return-Path: Received: from mail-wm1-x334.google.com (mail-wm1-x334.google.com [IPv6:2a00:1450:4864:20::334]) by sourceware.org (Postfix) with ESMTPS id 39597385B529 for ; Thu, 5 Jan 2023 14:41:10 +0000 (GMT) DMARC-Filter: OpenDMARC Filter v1.4.2 sourceware.org 39597385B529 Authentication-Results: sourceware.org; dmarc=pass (p=none dis=none) header.from=adacore.com Authentication-Results: sourceware.org; spf=pass smtp.mailfrom=adacore.com Received: by mail-wm1-x334.google.com with SMTP id l26so26580958wme.5 for ; Thu, 05 Jan 2023 06:41:10 -0800 (PST) DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=adacore.com; s=google; h=content-transfer-encoding:mime-version:message-id:date:subject:cc :to:from:from:to:cc:subject:date:message-id:reply-to; bh=PI/9m9BlNFL0hCX/BCBN/7ifjhERbh4I8OqwkEKaVuI=; b=aZmXDo/mBunZvlSIohETHUfgJeFZK9gkF6aAvEPrrhOuJ9Zb/7XOyov9kSLhncg7hA nE14nv/Ljdcfdl5nC8Rs01YvexUPonk5Oq4QDQcLG0Vtwih/de4+jUl6Vjnk0eh6F0Pk uR5Qu5vZFYkzy7K1eLZAEkvctU4BPd16mro60m6vhvJJcDQ85lDnUK7n4/pXDBbMn+Hm pW21rTY48yOpUEGB2vXnQabMykMKHHMM9A+Z6X2/mgLhiInN1F5Iw9TwUqMHc0yfnyP2 oa/dO1c/6KBI/We6fbEiGZk0HHpVctZT1rDkuz1bcfMUfhElz5limhtj9WW/9yXsnecy J0rQ== X-Google-DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=1e100.net; s=20210112; h=content-transfer-encoding:mime-version:message-id:date:subject:cc :to:from:x-gm-message-state:from:to:cc:subject:date:message-id :reply-to; bh=PI/9m9BlNFL0hCX/BCBN/7ifjhERbh4I8OqwkEKaVuI=; b=VBSNbVyzOZQRFiqyKicmyDGRk8sYAhiMjFpBJwEXyUXMJCpGv/fxvJha3nxzGOeAVZ PixoIZ+0Avcx1wqKrmJ3iBoKcw5UmgG68v3zuCXGc5WPNzbsPgBqpkTiaFreZ/kHlpWE 00xHH/DTQyk/zM9cFnHaJj0Tn6uZM5mhETdwjqkO68g/kEU/6LbmEYzQEUOxeWiv9Zbv ho/ZlZloa35kdj03zxKe7uId6XrjZ+YdHmByzAng0nam9tu9fO76Es54UjxBOvV6MJkH wywqXoGS4B85k3jywS5V/CjfpxHhdQNXmhzDfslOJ6TeGICAoYoXJkJnc1fCVrE7qp5M SqfA== X-Gm-Message-State: AFqh2krlRsCGkt7Yo9P5dQtP778rVEhxbc07k39TJR08BR16xgHGSapR hoioPe+DybgXivN0+KJfNTGz+9O7TQktCJ3btjc= X-Google-Smtp-Source: AMrXdXtQDo2+KNL9CwcqmvN+VlzLf11Uz7kowicBbHz3y2rWcjVDDP3rWT8eVKLmip8UH/N5LdLpcQ== X-Received: by 2002:a05:600c:4e14:b0:3c6:c6c9:d75e with SMTP id b20-20020a05600c4e1400b003c6c6c9d75emr44720228wmq.0.1672929669725; Thu, 05 Jan 2023 06:41:09 -0800 (PST) Received: from poulhies-Precision-5550.lan (static-176-191-105-132.ftth.abo.bbox.fr. [176.191.105.132]) by smtp.gmail.com with ESMTPSA id f19-20020a05600c155300b003d98a7aa12csm3022329wmg.16.2023.01.05.06.41.08 (version=TLS1_3 cipher=TLS_AES_256_GCM_SHA384 bits=256/256); Thu, 05 Jan 2023 06:41:09 -0800 (PST) From: =?UTF-8?q?Marc=20Poulhi=C3=A8s?= To: gcc-patches@gcc.gnu.org Cc: Eric Botcazou Subject: [COMMITTED] ada: Clean up interface handling in Expand_N_Object_Declaration Date: Thu, 5 Jan 2023 15:41:07 +0100 Message-Id: <20230105144107.156577-1-poulhies@adacore.com> X-Mailer: git-send-email 2.34.1 MIME-Version: 1.0 Content-Transfer-Encoding: 8bit X-Spam-Status: No, score=-13.6 required=5.0 tests=BAYES_00,DKIM_SIGNED,DKIM_VALID,DKIM_VALID_AU,DKIM_VALID_EF,GIT_PATCH_0,RCVD_IN_DNSWL_NONE,SPF_HELO_NONE,SPF_PASS,TXREP autolearn=ham autolearn_force=no version=3.4.6 X-Spam-Checker-Version: SpamAssassin 3.4.6 (2021-04-09) on server2.sourceware.org List-Id: From: Eric Botcazou 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 ; -- 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