From patchwork Mon Jan 16 14:49:11 2023 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: =?utf-8?q?Marc_Poulhi=C3=A8s?= X-Patchwork-Id: 44187 Return-Path: Delivered-To: ouuuleilei@gmail.com Received: by 2002:adf:eb09:0:0:0:0:0 with SMTP id s9csp1231228wrn; Mon, 16 Jan 2023 06:51:24 -0800 (PST) X-Google-Smtp-Source: AMrXdXuVSDzb/q7r4+vPojUTHnqlbxOUIj8AjMW1L5coqmZYadtmaAO0Rrw5c1amNpv5aZ+snj7n X-Received: by 2002:a17:907:2c61:b0:86e:fccc:bc19 with SMTP id ib1-20020a1709072c6100b0086efcccbc19mr7267959ejc.43.1673880684453; Mon, 16 Jan 2023 06:51:24 -0800 (PST) ARC-Seal: i=1; a=rsa-sha256; t=1673880684; cv=none; d=google.com; s=arc-20160816; b=HVrxAuM4Obq2JbIBtH8KkofOl0k0yqfUaDlZUzrHl9I3Sm4NO9ESRZ2GWfgbzHLL3d FaSPxU/lS0ezLwJX//Zkn0wZj50NFpewcL4gUnyxsnFltkdywuj3vtHBtA8JBXUXhf8I WgibQspGdRM9vo85gOf/NPhC2sN6BmFyDGwgurcdWWygdAueYutmB3qbiO+xLT0ja6sH 41/DRTsjAgFyTP0S4WoI6+sZLL2L2yHKAxJAR1dWzfDo2e/vcHBSd4Vf85Ccw//hN+Ij D90b4aJsN6TKm0/sggmnXeQMQIqlwKAczNCf+3/XHkqrFIETna6G/H4++1KqJpvsWIel REzA== ARC-Message-Signature: i=1; a=rsa-sha256; c=relaxed/relaxed; d=google.com; s=arc-20160816; h=sender:errors-to:reply-to:from:list-subscribe:list-help:list-post :list-archive:list-unsubscribe:list-id:precedence :content-transfer-encoding:mime-version:message-id:date:subject:cc :to:dmarc-filter:delivered-to:dkim-signature:dkim-filter; bh=fbstfY0sWDGZEH4BrfAo/TAWP7nkcgk9JxVjTj7wmx8=; b=wZ8K1STIC92sFXeJ8s/DKuVIqk8KlsrlLyAErldUKno3N5x+KK9+mmY4sGpU70gL3i wWK4zeS0Fl7vtjSencgC95a7sCSoT00Uv9zS+FBEpgg2xmgOXF3CmfcT3X0QSh+8/TVy 5iTbL36QJ5E2mPrprX3qe7qKcFFPcd12j++iprtUtGWS25qgK24MfbJ3Ovyy2lBzDkAM q8fTm516yRTPVELF7udJryUzdaUL4qnR/Lucx31BpYcbt+fOUOCMrwqOBRrX4uG1is3j spOzMNcNNsnnoEsvcw1yYroCwMk6dly2fCo5UbiJNRiQoQHIYnkJ6o4mqIKDj8Co0dtr hK+Q== ARC-Authentication-Results: i=1; mx.google.com; dkim=pass header.i=@gcc.gnu.org header.s=default header.b=Aan9UwMW; spf=pass (google.com: domain of gcc-patches-bounces+ouuuleilei=gmail.com@gcc.gnu.org designates 8.43.85.97 as permitted sender) smtp.mailfrom="gcc-patches-bounces+ouuuleilei=gmail.com@gcc.gnu.org"; dmarc=pass (p=NONE sp=NONE dis=NONE) header.from=gnu.org Received: from sourceware.org (ip-8-43-85-97.sourceware.org. [8.43.85.97]) by mx.google.com with ESMTPS id sg18-20020a170907a41200b008650ce2977bsi16279466ejc.641.2023.01.16.06.51.24 for (version=TLS1_3 cipher=TLS_AES_256_GCM_SHA384 bits=256/256); Mon, 16 Jan 2023 06:51:24 -0800 (PST) Received-SPF: pass (google.com: domain of gcc-patches-bounces+ouuuleilei=gmail.com@gcc.gnu.org designates 8.43.85.97 as permitted sender) client-ip=8.43.85.97; Authentication-Results: mx.google.com; dkim=pass header.i=@gcc.gnu.org header.s=default header.b=Aan9UwMW; spf=pass (google.com: domain of gcc-patches-bounces+ouuuleilei=gmail.com@gcc.gnu.org designates 8.43.85.97 as permitted sender) smtp.mailfrom="gcc-patches-bounces+ouuuleilei=gmail.com@gcc.gnu.org"; dmarc=pass (p=NONE sp=NONE dis=NONE) header.from=gnu.org Received: from server2.sourceware.org (localhost [IPv6:::1]) by sourceware.org (Postfix) with ESMTP id 2236F3889E29 for ; Mon, 16 Jan 2023 14:50:05 +0000 (GMT) DKIM-Filter: OpenDKIM Filter v2.11.0 sourceware.org 2236F3889E29 DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=gcc.gnu.org; s=default; t=1673880605; bh=fbstfY0sWDGZEH4BrfAo/TAWP7nkcgk9JxVjTj7wmx8=; h=To:Cc:Subject:Date:List-Id:List-Unsubscribe:List-Archive: List-Post:List-Help:List-Subscribe:From:Reply-To:From; b=Aan9UwMWKErMeAptyK/9Q1IGw7gUDS/GyNx5y0uRDb7NybQvFrVddpuzqKnaRa1hV IBNEWj5/SJ7MTvrCTSv1eORqcRTQrd6P13DaDgPRIJ+Dyhb+nXcxCCyCI1MuTNFOsv UL6fahvV+FtNCV2Dlju+We12OFrL4K4PNFPTKI58= X-Original-To: gcc-patches@gcc.gnu.org Delivered-To: gcc-patches@gcc.gnu.org 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 Received: by mail-wm1-x332.google.com with SMTP id m5-20020a05600c4f4500b003db03b2559eso261722wmq.5 for ; Mon, 16 Jan 2023 06:49:15 -0800 (PST) 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-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) 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 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 X-BeenThere: gcc-patches@gcc.gnu.org X-Mailman-Version: 2.1.29 Precedence: list List-Id: Gcc-patches mailing list List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , X-Patchwork-Original-From: =?utf-8?q?Marc_Poulhi=C3=A8s_via_Gcc-patches?= From: =?utf-8?q?Marc_Poulhi=C3=A8s?= Reply-To: =?utf-8?q?Marc_Poulhi=C3=A8s?= Errors-To: gcc-patches-bounces+ouuuleilei=gmail.com@gcc.gnu.org Sender: "Gcc-patches" X-getmail-retrieved-from-mailbox: =?utf-8?q?INBOX?= X-GMAIL-THRID: =?utf-8?q?1755191112294879858?= X-GMAIL-MSGID: =?utf-8?q?1755191112294879858?= 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