From mboxrd@z Thu Jan 1 00:00:00 1970 Return-Path: Received: from mail-wm1-x332.google.com (mail-wm1-x332.google.com [IPv6:2a00:1450:4864:20::332]) by sourceware.org (Postfix) with ESMTPS id 20594385439B for ; Mon, 16 Jan 2023 14:49:15 +0000 (GMT) DMARC-Filter: OpenDMARC Filter v1.4.2 sourceware.org 20594385439B 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-x332.google.com with SMTP id m5-20020a05600c4f4500b003db03b2559eso261722wmq.5 for ; Mon, 16 Jan 2023 06:49:15 -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=fbstfY0sWDGZEH4BrfAo/TAWP7nkcgk9JxVjTj7wmx8=; b=bR91kvdFN5kWk0s+Q1u9G7IxMXMa2U4N4aal0Gti2JwK81RIIr6PB7mr9JSa7QOtYm kQEOKkgHTV2j+CNOQr4Mf9kkMBeLhn0BMslkB7ztKq8655vP+lAopbTanVOXXw1kf7yX gdx8Re8zMXrQB1SKYG40ULocSnnILdcDfoI1QgIC9jTxPp0PIN1RC+569PcGw4eqsF3p xgE2vWOy97mwKY815aHyWKxIgpDigus8B5mXe3ZvfmO6gJA3mVxjLIxNeoA4D7P1+poV K3QjjoqORnKJ6qQLAsZkjHrSwVG7iLsGTVC9uK0zAsJsYwS2/00me8BaRgBWMmEp/PSW +SIw== 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=fbstfY0sWDGZEH4BrfAo/TAWP7nkcgk9JxVjTj7wmx8=; b=vL5zQOQWqAUnEeFXO89P4ndFvF/iXvWL/CnV/IEwB+AOsoQRd+6vTJS4/GS6Dlg6hK nNyvw5QSIxf5vkyv5ohE1pwh3bYXr8dhGdR+J63eMVq1lkI66PhFn+6ehRk/Sb2RbSYT VPDCRICJdrCt4WD+tdrXGsYsy165cSkDXHARWJX2eld0z8iZA0ibFF+ctg6X/Bo076tH hsBtchK4t2Pxjd50C0na04eJT8oYvtPP2aZiPuXVvGsHienk4DlBMucn/lYVXEHjy97C i4xy/TnXXC1/BFSrYZagzxr948k4yFAuSNwUxmZ81EH3soPfpdWTMP+ZKhdsEFObW/Se nKKg== X-Gm-Message-State: AFqh2kqrvRjNkYwhgFLf286fw8pXgI0oBUBdOKGTferqvOdXGwlCqPDv /39wZggtD8vsYU2I914Yliel7gm5sX8OlVtT X-Google-Smtp-Source: AMrXdXtU+LMoA6RuC2xO7/rXfD2/KKxq+C3YRSGJs2FIwrB4L/68gS9oI7U2/fauTfhGHc7VC84utw== X-Received: by 2002:a05:600c:154b:b0:3da:2a78:d7b4 with SMTP id f11-20020a05600c154b00b003da2a78d7b4mr7978561wmg.3.1673880553880; Mon, 16 Jan 2023 06:49:13 -0800 (PST) Received: from poulhies-Precision-5550.telnowedge.local (lmontsouris-659-1-24-67.w81-250.abo.wanadoo.fr. [81.250.175.67]) by smtp.gmail.com with ESMTPSA id o11-20020a05600c4fcb00b003c6f3f6675bsm41206892wmq.26.2023.01.16.06.49.13 (version=TLS1_3 cipher=TLS_AES_256_GCM_SHA384 bits=256/256); Mon, 16 Jan 2023 06:49:13 -0800 (PST) From: =?UTF-8?q?Marc=20Poulhi=C3=A8s?= To: gcc-patches@gcc.gnu.org Cc: Eric Botcazou Subject: [COMMITTED] ada: Use static references to tag in more cases for interface objects Date: Mon, 16 Jan 2023 15:49:11 +0100 Message-Id: <20230116144911.3171666-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.0 required=5.0 tests=BAYES_00,DKIM_SIGNED,DKIM_VALID,DKIM_VALID_AU,DKIM_VALID_EF,GIT_PATCH_0,KAM_ASCII_DIVIDERS,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 This extends the use of static references to the interface tag in more cases for (class-wide) interface objects, e.g. for initialization expressions that are qualified aggregates or nondispatching calls returning a specific tagged type implementing the interface. gcc/ada/ * exp_util.ads (Has_Tag_Of_Type): Declare. * exp_util.adb (Has_Tag_Of_Type): Move to package level. Recurse on qualified expressions. * exp_ch3.adb (Expand_N_Object_Declaration): Use a static reference to the interface tag in more cases for class-wide interface objects. Tested on x86_64-pc-linux-gnu, committed on master. --- gcc/ada/exp_ch3.adb | 72 +++++++++++++--------------- gcc/ada/exp_util.adb | 112 ++++++++++++++++++++++--------------------- gcc/ada/exp_util.ads | 4 ++ 3 files changed, 95 insertions(+), 93 deletions(-) diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb index bbb53fc6e49..6bc76aec5d1 100644 --- a/gcc/ada/exp_ch3.adb +++ b/gcc/ada/exp_ch3.adb @@ -7564,7 +7564,7 @@ package body Exp_Ch3 is Expr_Q := Expr; end if; - -- We may use a renaming if the initializing expression is a + -- We may use a renaming if the initialization expression is a -- captured function call that meets a few conditions. Rewrite_As_Renaming := Is_Renamable_Function_Call (Expr_Q); @@ -7621,41 +7621,6 @@ package body Exp_Ch3 is Obj_Id := Make_Temporary (Loc, 'D', Expr_Q); - -- Replace - -- CW : I'Class := Obj; - -- by - -- Dnn : Typ := Obj; - -- type Ityp is not null access I'Class; - -- Rnn : constant Ityp := Ityp (Dnn.I_Tag'Address); - -- CW : I'Class renames Rnn.all; - - 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) - or else not - Is_Variable_Size_Record (Etype (Expr_Typ))) - then - -- Copy the object - - Insert_Action (N, - Make_Object_Declaration (Loc, - Defining_Identifier => Obj_Id, - Object_Definition => - New_Occurrence_Of (Expr_Typ, Loc), - Expression => Relocate_Node (Expr_Q))); - - -- Statically reference the tag associated with the - -- interface - - Tag_Comp := - Make_Selected_Component (Loc, - Prefix => New_Occurrence_Of (Obj_Id, Loc), - Selector_Name => - New_Occurrence_Of - (Find_Interface_Tag (Expr_Typ, Iface), Loc)); - -- Replace -- IW : I'Class := Expr; -- by @@ -7665,7 +7630,7 @@ package body Exp_Ch3 is -- Ityp!(Displace (Dnn'Address, I'Tag)); -- IW : I'Class renames Rnn.all; - elsif Rewrite_As_Renaming then + if Rewrite_As_Renaming then New_Expr := Make_Explicit_Dereference (Loc, Unchecked_Convert_To (RTE (RE_Tag_Ptr), @@ -7697,6 +7662,37 @@ package body Exp_Ch3 is (Node (First_Elmt (Access_Disp_Table (Iface))), Loc))); + -- Replace + -- IW : I'Class := Expr; + -- by + -- Dnn : Typ := Expr; + -- type Ityp is not null access I'Class; + -- Rnn : constant Ityp := Ityp (Dnn.I_Tag'Address); + -- IW : I'Class renames Rnn.all; + + elsif Has_Tag_Of_Type (Expr_Q) + and then Interface_Present_In_Ancestor (Expr_Typ, Typ) + and then (Expr_Typ = Etype (Expr_Typ) + or else not + Is_Variable_Size_Record (Etype (Expr_Typ))) + then + Insert_Action (N, + Make_Object_Declaration (Loc, + Defining_Identifier => Obj_Id, + Object_Definition => + New_Occurrence_Of (Expr_Typ, Loc), + Expression => Relocate_Node (Expr_Q))); + + -- Statically reference the tag associated with the + -- interface + + Tag_Comp := + Make_Selected_Component (Loc, + Prefix => New_Occurrence_Of (Obj_Id, Loc), + Selector_Name => + New_Occurrence_Of + (Find_Interface_Tag (Expr_Typ, Iface), Loc)); + -- Replace -- IW : I'Class := Expr; -- by @@ -7977,7 +7973,7 @@ package body Exp_Ch3 is and then not (Is_Array_Type (Typ) and then Is_Constr_Subt_For_UN_Aliased (Typ)) - -- We may use a renaming if the initializing expression is a + -- We may use a renaming if the initialization expression is a -- captured function call that meets a few conditions. and then diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb index f6d91ca4a0e..80c01bf40fd 100644 --- a/gcc/ada/exp_util.adb +++ b/gcc/ada/exp_util.adb @@ -7186,6 +7186,63 @@ package body Exp_Util is end if; end Has_Access_Constraint; + --------------------- + -- Has_Tag_Of_Type -- + --------------------- + + function Has_Tag_Of_Type (Exp : Node_Id) return Boolean is + Typ : constant Entity_Id := Etype (Exp); + + begin + pragma Assert (Is_Tagged_Type (Typ)); + + -- The tag of an object of a class-wide type is that of its + -- initialization expression. + + if Is_Class_Wide_Type (Typ) then + return False; + end if; + + -- The tag of a stand-alone object of a specific tagged type T + -- identifies T. + + if Is_Entity_Name (Exp) + and then Ekind (Entity (Exp)) in E_Constant | E_Variable + then + return True; + + else + case Nkind (Exp) is + -- The tag of a component or an aggregate of a specific tagged + -- type T identifies T. + + when N_Indexed_Component + | N_Selected_Component + | N_Aggregate + => + return True; + + -- The tag of the result returned by a function whose result + -- type is a specific tagged type T identifies T. + + when N_Function_Call => + return True; + + when N_Explicit_Dereference => + return Is_Captured_Function_Call (Exp); + + -- For a tagged type, the operand of a qualified expression + -- shall resolve to be of the type of the expression. + + when N_Qualified_Expression => + return Has_Tag_Of_Type (Expression (Exp)); + + when others => + return False; + end case; + end if; + end Has_Tag_Of_Type; + -------------------- -- Homonym_Number -- -------------------- @@ -9491,61 +9548,6 @@ package body Exp_Util is Size_Attr : Node_Id; Size_Expr : Node_Id; - function Has_Tag_Of_Type (Exp : Node_Id) return Boolean; - -- Return True if expression Exp of a tagged type is known to statically - -- have the tag of this tagged type as specified by RM 3.9(19-25). - - --------------------- - -- Has_Tag_Of_Type -- - --------------------- - - function Has_Tag_Of_Type (Exp : Node_Id) return Boolean is - Typ : constant Entity_Id := Etype (Exp); - - begin - pragma Assert (Is_Tagged_Type (Typ)); - - -- The tag of an object of a class-wide type is that of its - -- initialization expression. - - if Is_Class_Wide_Type (Typ) then - return False; - end if; - - -- The tag of a stand-alone object of a specific tagged type T - -- identifies T. - - if Is_Entity_Name (Exp) - and then Ekind (Entity (Exp)) in E_Constant | E_Variable - then - return True; - - else - case Nkind (Exp) is - -- The tag of a component or an aggregate of a specific tagged - -- type T identifies T. - - when N_Indexed_Component - | N_Selected_Component - | N_Aggregate - => - return True; - - -- The tag of the result returned by a function whose result - -- type is a specific tagged type T identifies T. - - when N_Function_Call => - return True; - - when N_Explicit_Dereference => - return Is_Captured_Function_Call (Exp); - - when others => - return False; - end case; - end if; - end Has_Tag_Of_Type; - begin -- If the root type is already constrained, there are no discriminants -- in the expression. diff --git a/gcc/ada/exp_util.ads b/gcc/ada/exp_util.ads index 32f9c24814b..3dd10d77cea 100644 --- a/gcc/ada/exp_util.ads +++ b/gcc/ada/exp_util.ads @@ -732,6 +732,10 @@ package Exp_Util is function Has_Access_Constraint (E : Entity_Id) return Boolean; -- Given object or type E, determine if a discriminant is of an access type + function Has_Tag_Of_Type (Exp : Node_Id) return Boolean; + -- Return True if expression Exp of a tagged type is known to statically + -- have the tag of this tagged type as specified by RM 3.9(19-25). + function Homonym_Number (Subp : Entity_Id) return Pos; -- Here subp is the entity for a subprogram. This routine returns the -- homonym number used to disambiguate overloaded subprograms in the same -- 2.34.1