From patchwork Tue Sep 19 12:08:12 2023 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 8bit X-Patchwork-Submitter: =?utf-8?q?Marc_Poulhi=C3=A8s?= X-Patchwork-Id: 141846 Return-Path: Delivered-To: ouuuleilei@gmail.com Received: by 2002:a05:612c:172:b0:3f2:4152:657d with SMTP id h50csp3333746vqi; Tue, 19 Sep 2023 05:09:00 -0700 (PDT) X-Google-Smtp-Source: AGHT+IFyhrBPt/pZ4aBunm1giQ2Va2JVJItHGU1AmY4E+F5Itm9bxBydM4lDhlSlUv2d5Phceuhx X-Received: by 2002:a17:907:2cd4:b0:9ae:38d0:ef52 with SMTP id hg20-20020a1709072cd400b009ae38d0ef52mr680294ejc.29.1695125340094; Tue, 19 Sep 2023 05:09:00 -0700 (PDT) ARC-Seal: i=1; a=rsa-sha256; t=1695125340; cv=none; d=google.com; s=arc-20160816; b=NoXbdz1h4WRNc/JQm3AdPEvu9eDPXfqeGvI2nuLnlzoSR3dItKtk1TRlwe6OE1r63g WKYOkHw8GDC4IctFcw0sGzXCIrWFyzmiCG9ke9WQLXMI/axk5Pf2AwxR57MCHMiO3J7M J3wPYr6hzIsEvYkmacPD57SYTzyxCgIHZTNkiV3JkEwvdAn1b1IGxZW2WRMADNwINCz8 Mg2jleC39chR6111pyvYTmn9FReV7BVqPeLyfZgLLSRV3PVLINXFpOQUT4au/g4L/fDI adFwlfoVvLwbk3VS0/h6ZrK8U/03IefdoEWRi2JnWsqnUh8MDYenbb4CyrPEkWrie4yT o42A== ARC-Message-Signature: i=1; a=rsa-sha256; c=relaxed/relaxed; d=google.com; s=arc-20160816; h=errors-to:list-subscribe:list-help:list-post:list-archive :list-unsubscribe:list-id:precedence:content-transfer-encoding :mime-version:references:in-reply-to:message-id:date:subject:cc:to :from:dkim-signature:dmarc-filter:delivered-to; bh=uSqIXkqlakdIWZ8mLIyJtxtSxmg4n6Jom92C8G7XLps=; fh=nRuFZvg1F/8NiKrHPvXrq+tEB8dBG18X2XJ8M/DVeaQ=; b=g7hqomMkJWsl23XUag576vrT707jPktatBHZx0Ccvw7PlNGMT05OyPnM/p6e/TRQ+Y LSSZXJV2qT099yQRbvADUeq/S316t1Nl/E/+bsZAWnFOsrc5376C94xqg35asCUuP5dX KDHNWqKfcam0aZ8HDArYOzR2rMQoCbDAR0Xb45doz2IEJF9/mzk8B4s1NL+mZ7Kt3nQ+ oWPnkdA7HijORpdlveo/ajN7l844uSg/kiEi5lPICjV9xXPlLBIvu2oNaUEJkCpQO3RX eGfhOhtPaHYOTFDYpTJS2UHU8iANjA0L+AQO/VdkQeOIsMLOhZ+BgSp5vmresAJnaIYk KAmw== ARC-Authentication-Results: i=1; mx.google.com; dkim=pass header.i=@adacore.com header.s=google header.b=frdJgsNr; 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=adacore.com Received: from server2.sourceware.org (ip-8-43-85-97.sourceware.org. [8.43.85.97]) by mx.google.com with ESMTPS id um7-20020a170906cf8700b0099e0e2e5318si9381421ejb.926.2023.09.19.05.08.59 for (version=TLS1_3 cipher=TLS_AES_256_GCM_SHA384 bits=256/256); Tue, 19 Sep 2023 05:09:00 -0700 (PDT) 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=@adacore.com header.s=google header.b=frdJgsNr; 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=adacore.com Received: from server2.sourceware.org (localhost [IPv6:::1]) by sourceware.org (Postfix) with ESMTP id E17533856DD0 for ; Tue, 19 Sep 2023 12:08:51 +0000 (GMT) X-Original-To: gcc-patches@gcc.gnu.org Delivered-To: gcc-patches@gcc.gnu.org Received: from mail-wm1-x32b.google.com (mail-wm1-x32b.google.com [IPv6:2a00:1450:4864:20::32b]) by sourceware.org (Postfix) with ESMTPS id DC1393858D3C for ; Tue, 19 Sep 2023 12:08:23 +0000 (GMT) DMARC-Filter: OpenDMARC Filter v1.4.2 sourceware.org DC1393858D3C 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-x32b.google.com with SMTP id 5b1f17b1804b1-403012f27e1so59901315e9.1 for ; Tue, 19 Sep 2023 05:08:23 -0700 (PDT) DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=adacore.com; s=google; t=1695125302; x=1695730102; darn=gcc.gnu.org; h=content-transfer-encoding:mime-version:references:in-reply-to :message-id:date:subject:cc:to:from:from:to:cc:subject:date :message-id:reply-to; bh=uSqIXkqlakdIWZ8mLIyJtxtSxmg4n6Jom92C8G7XLps=; b=frdJgsNrNh1iDoBO+uouuN3Fq/pETVflThNJ+odahWaXoYaeOvjkwa8jpT/mKXMhIS GUFybirpUAFmSnJ2Vf++ork9QIBxK5uFsHMWPhQhEfBC2viNgjo8GBf1p8T3oqBOg7Lc frIOxsCpz6tEfzI9toPkiYc+kN3X2Ky0m9BuosobI1ncdX8wumKYv3dKoM9I+2a2WgW/ IL/HYWxW+Kkwx7kf3Kme+Isabm9m63JSam79InU6eRquBRlGlBAnIkha2eMtO7deDT1x yYNKb8vhOFkESGfx4zUXcPmADMMK2NpGE73mGza7HEPiQ4Cpxdm3xh2P4YpA6IcNebZo 83EQ== X-Google-DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=1e100.net; s=20230601; t=1695125302; x=1695730102; h=content-transfer-encoding:mime-version:references:in-reply-to :message-id:date:subject:cc:to:from:x-gm-message-state:from:to:cc :subject:date:message-id:reply-to; bh=uSqIXkqlakdIWZ8mLIyJtxtSxmg4n6Jom92C8G7XLps=; b=AUUQtFB4XMZnWHdwAZI80TGy91PghzpUoSpe7HqKZhwmKcptrVXOODOOA5w+yMvR56 J0nn+TWR5bTaI4BMYFYYw9g/+IG7MZOziXJRPLiQ74Nt0kXeorfiUaGlbNTHxdLGtAvP Gn+IFfEksuQnPdqIdzMJRH77kVUaalf0ANkcN7cbTsGMXw0emXEEA/+FVVH2L4bOEr56 19mm6aBBg4b5x8DGvjb751uO8n0KoE77QhvkQPWkakQMYwomOz6pHgJ81+u3OVzmVc5o /T1dLWq/bGoTKu+qPGJCR29baiXWItO9V8rMyjjVe0NzsD97eNnSmbuTVo+yXx11qy+P RkCQ== X-Gm-Message-State: AOJu0Yy6dPadmWtoss044BuJI3g5irzdC3BpFbAdeF5UFEdBsjpsMWOQ bRtaUGzZeFXXv4Lo/bS5fajh7w== X-Received: by 2002:a7b:c40b:0:b0:401:be70:53b6 with SMTP id k11-20020a7bc40b000000b00401be7053b6mr10368667wmi.15.1695125302286; Tue, 19 Sep 2023 05:08:22 -0700 (PDT) Received: from localhost.localdomain ([2001:861:3382:1a90:d64c:aec5:913b:4c80]) by smtp.gmail.com with ESMTPSA id l14-20020a1c790e000000b003fe4ca8decdsm17871274wme.31.2023.09.19.05.08.21 (version=TLS1_3 cipher=TLS_AES_256_GCM_SHA384 bits=256/256); Tue, 19 Sep 2023 05:08:21 -0700 (PDT) From: =?utf-8?q?Marc_Poulhi=C3=A8s?= To: richard@annexi-strayline.com Cc: baird@adacore.com, charlet@adacore.com, dismukes@adacore.com, ebotcazou@adacore.com, gcc-patches@gcc.gnu.org, poulhies@adacore.com Subject: [COMMITTED] ada: TSS finalize address subprogram generation for constrained... Date: Tue, 19 Sep 2023 14:08:12 +0200 Message-Id: <20230919120812.2277126-1-poulhies@adacore.com> X-Mailer: git-send-email 2.40.0 In-Reply-To: <010d018aab817c4a-b788c011-b652-407f-9d03-8b3e321c55ba-000000@ca-central-1.amazonses.com> References: <010d018aab817c4a-b788c011-b652-407f-9d03-8b3e321c55ba-000000@ca-central-1.amazonses.com> MIME-Version: 1.0 X-Spam-Status: No, score=-13.7 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 X-BeenThere: gcc-patches@gcc.gnu.org X-Mailman-Version: 2.1.30 Precedence: list List-Id: Gcc-patches mailing list List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: gcc-patches-bounces+ouuuleilei=gmail.com@gcc.gnu.org X-getmail-retrieved-from-mailbox: INBOX X-GMAIL-THRID: 1777467748346830681 X-GMAIL-MSGID: 1777467748346830681 From: Richard Wai ...subtypes of unconstrained synchronized private extensions should take care to designate the corresponding record of the underlying concurrent type. When generating TSS finalize address subprograms for class-wide types of constrained root types, it follows the parent chain looking for the first "non-constrained" type. It is possible that such a type is a private extension with the “synchronized” keyword, in which case the underlying type is a concurrent type. When that happens, the designated type of the finalize address subprogram should be the corresponding record’s class-wide-type. gcc/ada/ChangeLog: * exp_ch3.adb (Expand_Freeze_Class_Wide_Type): Expanded comments explaining why TSS Finalize_Address is not generated for concurrent class-wide types. * exp_ch7.adb (Make_Finalize_Address_Stmts): Handle cases where the underlying non-constrained parent type is a concurrent type, and adjust the designated type to be the corresponding record’s class-wide type. gcc/testsuite/ChangeLog: * gnat.dg/sync_tag_finalize.adb: New test. Signed-off-by: Richard Wai --- gcc/ada/exp_ch3.adb | 4 ++ gcc/ada/exp_ch7.adb | 28 +++++++++- gcc/testsuite/gnat.dg/sync_tag_finalize.adb | 60 +++++++++++++++++++++ 3 files changed, 90 insertions(+), 2 deletions(-) create mode 100644 gcc/testsuite/gnat.dg/sync_tag_finalize.adb diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb index 04c3ad8c631..bb015986200 100644 --- a/gcc/ada/exp_ch3.adb +++ b/gcc/ada/exp_ch3.adb @@ -5000,6 +5000,10 @@ package body Exp_Ch3 is -- Do not create TSS routine Finalize_Address for concurrent class-wide -- types. Ignore C, C++, CIL and Java types since it is assumed that the -- non-Ada side will handle their destruction. + -- + -- Concurrent Ada types are functionally represented by an associated + -- "corresponding record type" (typenameV), which owns the actual TSS + -- finalize bodies for the type (and technically class-wide type). elsif Is_Concurrent_Type (Root) or else Is_C_Derivation (Root) diff --git a/gcc/ada/exp_ch7.adb b/gcc/ada/exp_ch7.adb index aa16c707887..4ea5e6ede64 100644 --- a/gcc/ada/exp_ch7.adb +++ b/gcc/ada/exp_ch7.adb @@ -8512,7 +8512,8 @@ package body Exp_Ch7 is Is_Empty_Elmt_List (Discriminant_Constraint (Root_Type (Typ))) then declare - Parent_Typ : Entity_Id; + Parent_Typ : Entity_Id; + Parent_Utyp : Entity_Id; begin -- Climb the parent type chain looking for a non-constrained type @@ -8533,7 +8534,30 @@ package body Exp_Ch7 is Parent_Typ := Underlying_Record_View (Parent_Typ); end if; - Desig_Typ := Class_Wide_Type (Underlying_Type (Parent_Typ)); + Parent_Utyp := Underlying_Type (Parent_Typ); + + -- Handle views created for a synchronized private extension with + -- known, non-defaulted discriminants. In that case, parent_typ + -- will be the private extension, as it is the first "non + -- -constrained" type in the parent chain. Unfortunately, the + -- underlying type, being a protected or task type, is not the + -- "real" type needing finalization. Rather, the "corresponding + -- record type" should be the designated type here. In fact, TSS + -- finalizer generation is specifically skipped for the nominal + -- class-wide type of (the full view of) a concurrent type (see + -- exp_ch7.Expand_Freeze_Class_Wide_Type). If we don't designate + -- the underlying record (Tprot_typeVC), we will end up trying to + -- dispatch to prot_typeVDF from an incorrectly designated + -- Tprot_typeC, which is, of course, not actually a member of + -- prot_typeV'Class, and thus incompatible. + + if Ekind (Parent_Utyp) in Concurrent_Kind + and then Present (Corresponding_Record_Type (Parent_Utyp)) + then + Parent_Utyp := Corresponding_Record_Type (Parent_Utyp); + end if; + + Desig_Typ := Class_Wide_Type (Parent_Utyp); end; -- General case diff --git a/gcc/testsuite/gnat.dg/sync_tag_finalize.adb b/gcc/testsuite/gnat.dg/sync_tag_finalize.adb new file mode 100644 index 00000000000..6dffd4a102c --- /dev/null +++ b/gcc/testsuite/gnat.dg/sync_tag_finalize.adb @@ -0,0 +1,60 @@ +-- In previous versions of GNAT there was a curious bug that caused +-- compilation to fail in the case of a synchronized private extension +-- with non-default discriminants, where the creation of a constrained object +-- (and thus subtype) caused the TSS deep finalize machinery of the internal +-- class-wide constratined subtype (TConstrainedC) to construct a malformed +-- TSS finalize address body. The issue was that the machinery climbs +-- the type parent chain looking for a "non-constrained" type to use as a +-- designated (class-wide) type for a dispatching call to a higher TSS DF +-- subprogram. When there is a discriminated synchronized private extension +-- with known, non-default discriminants (thus unconstrained/indefinite), +-- that search ends up at that private extension declaration. Since the +-- underlying type is actually a concurrent type, class-wide TSS finalizers +-- are not built for the type, but rather the corresponding record type. The +-- TSS machinery that selects the designated type was prevsiously unaware of +-- this caveat, and thus selected an incompatible designated type, leading to +-- failed compilation. +-- +-- TL;DR: When creating a constrained subtype of a synchronized private +-- extension with known non-defaulted disciminants, the class-wide TSS +-- address finalization body for the constrained subtype should dispatch to +-- the corresponding record (class-wide) type deep finalize subprogram. + +-- { dg-do compile } + +procedure Sync_Tag_Finalize is + + package Ifaces is + + type Test_Interface is synchronized interface; + + procedure Interface_Action (Test: in out Test_Interface) is abstract; + + end Ifaces; + + + package Implementation is + type Test_Implementation + (Constraint: Positive) is + synchronized new Ifaces.Test_Interface with private; + + private + protected type Test_Implementation + (Constraint: Positive) + is new Ifaces.Test_Interface with + + overriding procedure Interface_Action; + + end Test_Implementation; + end Implementation; + + package body Implementation is + protected body Test_Implementation is + procedure Interface_Action is null; + end; + end Implementation; + + Constrained: Implementation.Test_Implementation(2); +begin + null; +end;