From patchwork Fri Jul 29 06:26:10 2022 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Alexandre Oliva X-Patchwork-Id: 289 Return-Path: Delivered-To: ouuuleilei@gmail.com Received: by 2002:a05:6a10:b5d6:b0:2b9:3548:2db5 with SMTP id v22csp646693pxt; Thu, 28 Jul 2022 23:27:44 -0700 (PDT) X-Google-Smtp-Source: AGRyM1vYDOJIe1SdRBGN7ym1zEsxPd9jHxE6qXnskSyqu9VJJkHNEk56iVGoVvg18I0ZbAUgqGR2 X-Received: by 2002:a05:6402:270c:b0:43a:d5f4:c4fa with SMTP id y12-20020a056402270c00b0043ad5f4c4famr2075315edd.107.1659076064119; Thu, 28 Jul 2022 23:27:44 -0700 (PDT) ARC-Seal: i=1; a=rsa-sha256; t=1659076064; cv=none; d=google.com; s=arc-20160816; b=qZKnTqofFg+Qm9kC6vtNagFRc+J6V5ePXHopvNsj8sPb+6Mz7Gu2fJWq+564uGw/F7 KnwAk+gA1eOmLUwMO3eGz5SVMGm2TGHuwbi0S1TqTo23fWS37b4WvekIDmUPqtL8d+sF v56zQR52yWk4i//vtDIExtW39lIDib3/KSks5qIzXuGV87WpdgD7Zj6BT5bnMJP7UVOo cs7LNZ9WfXym98FXky+C+p9EI4TWzPJ/F4mW2+m9Cqs0XYP7bgR2Z53haKgVdeB9yr1/ JTW6/o4Wxu2fijEOaTI3LBKJkw5L1VwjbAIqOgjNHsPKI1xTS6Yci2g9MmHHfyo9TxD9 GVXQ== ARC-Message-Signature: i=1; a=rsa-sha256; c=relaxed/relaxed; d=google.com; s=arc-20160816; h=sender:errors-to:cc:reply-to:from:list-subscribe:list-help :list-post:list-archive:list-unsubscribe:list-id:precedence :mime-version:user-agent:message-id:in-reply-to:date:references :organization:subject:to:dmarc-filter:delivered-to:dkim-signature :dkim-filter; bh=DxSUzm9pniuBT3G5NARu/GYZwV0Gdhop86ueEGMcKR0=; b=nr+Azfx3czG5UvYBVfRH/0/1GMLbvdqi6CFjqBQMw8L+bmTfereaZg7t0P3RNsMD/X UvI40AOP9ELGj0rXdlrcDHP4O6RyWVbczZa7P3qbVEAKEGugOaekZgPeKQ/fcfnkDNQn smmJJiyNAt0aAuKeiK+rMSfqwBbReX9LM8X7btzDkD7lJLVvrREsF/+oRGxIzjAKUlsq 6EqH4v7M4WKQvZjHJ0+DAL744wgtwJoq1sJjkW8yEOFUJwJWXuL/Ezkj205XrvKcJX1u WQK5s8iZzmVtrv55wXbAMMg7N+PKtCQq0E8xLFRXev8YfDJrG0N8aW2RNblhQei4kdcX z4wg== ARC-Authentication-Results: i=1; mx.google.com; dkim=pass header.i=@gcc.gnu.org header.s=default header.b=nRzKflsX; 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 (server2.sourceware.org. [8.43.85.97]) by mx.google.com with ESMTPS id n6-20020a5099c6000000b0043bb69a32d6si1767951edb.561.2022.07.28.23.27.43 for (version=TLS1_3 cipher=TLS_AES_256_GCM_SHA384 bits=256/256); Thu, 28 Jul 2022 23:27:44 -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=@gcc.gnu.org header.s=default header.b=nRzKflsX; 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 C5273385383D for ; Fri, 29 Jul 2022 06:27:07 +0000 (GMT) DKIM-Filter: OpenDKIM Filter v2.11.0 sourceware.org C5273385383D DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=gcc.gnu.org; s=default; t=1659076027; bh=DxSUzm9pniuBT3G5NARu/GYZwV0Gdhop86ueEGMcKR0=; h=To:Subject:References:Date:In-Reply-To:List-Id:List-Unsubscribe: List-Archive:List-Post:List-Help:List-Subscribe:From:Reply-To:Cc: From; b=nRzKflsXHd+MAtCK39SSIhpKU2jJeeSpG0l/TydlxGO7TY43mFHgJBdSrJ30WjUwK Zn0iMFgsobWTjcpvEhLDKh1zXIuhOTEZd2zVIhnhyYTUT8RRp5Zk0Ai1kNWjOiyds7 pyrQ9iCYhCTs35oC2opAh3o7X6PssRMWxNkWgTyo= X-Original-To: gcc-patches@gcc.gnu.org Delivered-To: gcc-patches@gcc.gnu.org Received: from rock.gnat.com (rock.gnat.com [205.232.38.15]) by sourceware.org (Postfix) with ESMTPS id 7A91F3852764 for ; Fri, 29 Jul 2022 06:26:21 +0000 (GMT) DMARC-Filter: OpenDMARC Filter v1.4.1 sourceware.org 7A91F3852764 Received: from localhost (localhost.localdomain [127.0.0.1]) by filtered-rock.gnat.com (Postfix) with ESMTP id EAC581168D2; Fri, 29 Jul 2022 02:26:20 -0400 (EDT) X-Virus-Scanned: Debian amavisd-new at gnat.com Received: from rock.gnat.com ([127.0.0.1]) by localhost (rock.gnat.com [127.0.0.1]) (amavisd-new, port 10024) with LMTP id VyfG802psjF0; Fri, 29 Jul 2022 02:26:20 -0400 (EDT) Received: from free.home (tron.gnat.com [IPv6:2620:20:4000:0:46a8:42ff:fe0e:e294]) (using TLSv1.2 with cipher ECDHE-RSA-AES256-GCM-SHA384 (256/256 bits)) (No client certificate requested) by rock.gnat.com (Postfix) with ESMTPS id 561BA1168CD; Fri, 29 Jul 2022 02:26:20 -0400 (EDT) Received: from livre (livre.home [172.31.160.2]) by free.home (8.15.2/8.15.2) with ESMTPS id 26T6QAP81851979 (version=TLSv1.2 cipher=ECDHE-RSA-AES256-GCM-SHA384 bits=256 verify=NOT); Fri, 29 Jul 2022 03:26:10 -0300 To: gcc-patches@gcc.gnu.org Subject: [PATCH v2 04/10] Introduce strub: tests for C++ and Ada Organization: Free thinker, does not speak for AdaCore References: Date: Fri, 29 Jul 2022 03:26:10 -0300 In-Reply-To: (Alexandre Oliva's message of "Fri, 29 Jul 2022 03:16:41 -0300") Message-ID: User-Agent: Gnus/5.13 (Gnus v5.13) Emacs/25.2 (gnu/linux) MIME-Version: 1.0 X-Scanned-By: MIMEDefang 2.84 X-Spam-Status: No, score=-12.3 required=5.0 tests=BAYES_00, GIT_PATCH_0, KAM_DMARC_STATUS, 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: Alexandre Oliva via Gcc-patches From: Alexandre Oliva Reply-To: Alexandre Oliva Cc: Jan Hubicka , Jim Wilson , Graham Markall 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?1739667343139227355?= X-GMAIL-MSGID: =?utf-8?q?1739667343139227355?= for gcc/testsuite/ChangeLog * g++.dg/strub-run1.C: New. * g++.dg/torture/strub-init1.C: New. * g++.dg/torture/strub-init2.C: New. * g++.dg/torture/strub-init3.C: New. * gnat.dg/strub_attr.adb, gnat.dg/strub_attr.ads: New. * gnat.dg/strub_ind.adb, gnat.dg/strub_ind.ads: New. diff --git a/gcc/testsuite/g++.dg/strub-run1.C b/gcc/testsuite/g++.dg/strub-run1.C new file mode 100644 index 0000000000000..0d367fb83d09d --- /dev/null +++ b/gcc/testsuite/g++.dg/strub-run1.C @@ -0,0 +1,19 @@ +// { dg-do run } +// { dg-options "-fstrub=internal" } + +// Check that we don't get extra copies. + +struct T { + T &self; + void check () const { if (&self != this) __builtin_abort (); } + T() : self (*this) { check (); } + T(const T& ck) : self (*this) { ck.check (); check (); } + ~T() { check (); } +}; + +T foo (T q) { q.check (); return T(); } +T bar (T p) { p.check (); return foo (p); } + +int main () { + bar (T()).check (); +} diff --git a/gcc/testsuite/g++.dg/torture/strub-init1.C b/gcc/testsuite/g++.dg/torture/strub-init1.C new file mode 100644 index 0000000000000..c226ab10ff651 --- /dev/null +++ b/gcc/testsuite/g++.dg/torture/strub-init1.C @@ -0,0 +1,13 @@ +/* { dg-do compile } */ +/* { dg-options "-fstrub=strict -fdump-ipa-strub" } */ + +extern int __attribute__((__strub__)) initializer (); + +int f() { + static int x = initializer (); + return x; +} + +/* { dg-final { scan-ipa-dump "strub_enter" "strub" } } */ +/* { dg-final { scan-ipa-dump "strub_leave" "strub" } } */ +/* { dg-final { scan-ipa-dump-not "strub_update" "strub" } } */ diff --git a/gcc/testsuite/g++.dg/torture/strub-init2.C b/gcc/testsuite/g++.dg/torture/strub-init2.C new file mode 100644 index 0000000000000..a7911f1fa7212 --- /dev/null +++ b/gcc/testsuite/g++.dg/torture/strub-init2.C @@ -0,0 +1,14 @@ +/* { dg-do compile } */ +/* { dg-options "-fstrub=strict -fdump-ipa-strub" } */ + +extern int __attribute__((__strub__)) initializer (); + +static int x = initializer (); + +int f() { + return x; +} + +/* { dg-final { scan-ipa-dump "strub_enter" "strub" } } */ +/* { dg-final { scan-ipa-dump "strub_leave" "strub" } } */ +/* { dg-final { scan-ipa-dump-not "strub_update" "strub" } } */ diff --git a/gcc/testsuite/g++.dg/torture/strub-init3.C b/gcc/testsuite/g++.dg/torture/strub-init3.C new file mode 100644 index 0000000000000..6ebebcd01e8ea --- /dev/null +++ b/gcc/testsuite/g++.dg/torture/strub-init3.C @@ -0,0 +1,13 @@ +/* { dg-do compile } */ +/* { dg-options "-fstrub=strict -fdump-ipa-strub" } */ + +extern int __attribute__((__strub__)) initializer (); + +int f() { + int x = initializer (); + return x; +} + +/* { dg-final { scan-ipa-dump "strub_enter" "strub" } } */ +/* { dg-final { scan-ipa-dump "strub_leave" "strub" } } */ +/* { dg-final { scan-ipa-dump-not "strub_update" "strub" } } */ diff --git a/gcc/testsuite/gnat.dg/strub_access.adb b/gcc/testsuite/gnat.dg/strub_access.adb new file mode 100644 index 0000000000000..29e6996ecf61c --- /dev/null +++ b/gcc/testsuite/gnat.dg/strub_access.adb @@ -0,0 +1,21 @@ +-- { dg-do compile } +-- { dg-options "-fstrub=relaxed -fdump-ipa-strubm" } + +-- The main subprogram doesn't read from the automatic variable, but +-- being an automatic variable, its presence should be enough for the +-- procedure to get strub enabled. + +procedure Strub_Access is + type Strub_Int is new Integer; + pragma Machine_Attribute (Strub_Int, "strub"); + + X : aliased Strub_Int := 0; + + function F (P : access Strub_Int) return Strub_Int is (P.all); + +begin + X := F (X'Access); +end Strub_Access; + +-- { dg-final { scan-ipa-dump-times "\[(\]strub \[(\]internal\[)\]\[)\]" 1 "strubm" } } +-- { dg-final { scan-ipa-dump-times "\[(\]strub \[(\]at-calls-opt\[)\]\[)\]" 1 "strubm" } } diff --git a/gcc/testsuite/gnat.dg/strub_access1.adb b/gcc/testsuite/gnat.dg/strub_access1.adb new file mode 100644 index 0000000000000..dae4706016436 --- /dev/null +++ b/gcc/testsuite/gnat.dg/strub_access1.adb @@ -0,0 +1,16 @@ +-- { dg-do compile } +-- { dg-options "-fstrub=relaxed" } + +-- Check that we reject 'Access of a strub variable whose type does +-- not carry a strub modifier. + +procedure Strub_Access1 is + X : aliased Integer := 0; + pragma Machine_Attribute (X, "strub"); + + function F (P : access Integer) return Integer is (P.all); + +begin + X := F (X'Unchecked_access); -- OK. + X := F (X'Access); -- { dg-error "target access type drops .strub. mode" } +end Strub_Access1; diff --git a/gcc/testsuite/gnat.dg/strub_attr.adb b/gcc/testsuite/gnat.dg/strub_attr.adb new file mode 100644 index 0000000000000..10445d7cf8451 --- /dev/null +++ b/gcc/testsuite/gnat.dg/strub_attr.adb @@ -0,0 +1,37 @@ +-- { dg-do compile } +-- { dg-options "-fstrub=strict -fdump-ipa-strubm -fdump-ipa-strub" } + +package body Strub_Attr is + E : exception; + + procedure P (X : Integer) is + begin + raise E; + end; + + function F (X : Integer) return Integer is + begin + return X * X; + end; + + function G return Integer is (F (X)); + -- function G return Integer is (FP (X)); + -- Calling G would likely raise an exception, because although FP + -- carries the strub at-calls attribute needed to call F, the + -- attribute is dropped from the type used for the call proper. +end Strub_Attr; + +-- { dg-final { scan-ipa-dump-times "\[(\]strub \[(\]internal\[)\]\[)\]" 2 "strubm" } } +-- { dg-final { scan-ipa-dump-times "\[(\]strub \[(\]at-calls\[)\]\[)\]" 0 "strubm" } } +-- { dg-final { scan-ipa-dump-times "\[(\]strub\[)\]" 1 "strubm" } } + +-- { dg-final { scan-ipa-dump-times "strub.watermark_ptr" 6 "strub" } } +-- We have 1 at-calls subprogram (F) and 2 wrapped (P and G). +-- For each of them, there's one match for the wrapped signature, +-- and one for the update call. + +-- { dg-final { scan-ipa-dump-times "strub.watermark" 27 "strub" } } +-- The 6 matches above, plus: +-- 5*2: wm var decl, enter, call, leave and clobber for each wrapper; +-- 2*1: an extra leave and clobber for the exception paths in the wrappers. +-- 7*1: for the F call in G, including EH path. diff --git a/gcc/testsuite/gnat.dg/strub_attr.ads b/gcc/testsuite/gnat.dg/strub_attr.ads new file mode 100644 index 0000000000000..a94c23bf41833 --- /dev/null +++ b/gcc/testsuite/gnat.dg/strub_attr.ads @@ -0,0 +1,12 @@ +package Strub_Attr is + procedure P (X : Integer); + pragma Machine_Attribute (P, "strub", "internal"); + + function F (X : Integer) return Integer; + pragma Machine_Attribute (F, "strub"); + + X : Integer := 0; + pragma Machine_Attribute (X, "strub"); + + function G return Integer; +end Strub_Attr; diff --git a/gcc/testsuite/gnat.dg/strub_disp.adb b/gcc/testsuite/gnat.dg/strub_disp.adb new file mode 100644 index 0000000000000..3dbcc4a357cba --- /dev/null +++ b/gcc/testsuite/gnat.dg/strub_disp.adb @@ -0,0 +1,64 @@ +-- { dg-do compile } + +procedure Strub_Disp is + package Foo is + type A is tagged null record; + + procedure P (I : Integer; X : A); + pragma Machine_Attribute (P, "strub", "at-calls"); + + function F (X : access A) return Integer; + + type B is new A with null record; + + overriding + procedure P (I : Integer; X : B); -- { dg-error "requires the same .strub. mode" } + + overriding + function F (X : access B) return Integer; + pragma Machine_Attribute (F, "strub", "at-calls"); -- { dg-error "requires the same .strub. mode" } + + end Foo; + + package body Foo is + procedure P (I : Integer; X : A) is + begin + null; + end; + + function F (X : access A) return Integer is (0); + + overriding + procedure P (I : Integer; X : B) is + begin + P (I, A (X)); + end; + + overriding + function F (X : access B) return Integer is (1); + end Foo; + + use Foo; + + procedure Q (X : A'Class) is + begin + P (-1, X); + end; + + XA : aliased A; + XB : aliased B; + I : Integer := 0; + XC : access A'Class; +begin + Q (XA); + Q (XB); + + I := I + F (XA'Access); + I := I + F (XB'Access); + + XC := XA'Access; + I := I + F (XC); + + XC := XB'Access; + I := I + F (XC); +end Strub_Disp; diff --git a/gcc/testsuite/gnat.dg/strub_disp1.adb b/gcc/testsuite/gnat.dg/strub_disp1.adb new file mode 100644 index 0000000000000..09756a74b7d81 --- /dev/null +++ b/gcc/testsuite/gnat.dg/strub_disp1.adb @@ -0,0 +1,79 @@ +-- { dg-do compile } +-- { dg-options "-fdump-ipa-strub" } + +-- Check that at-calls dispatching calls are transformed. + +procedure Strub_Disp1 is + package Foo is + type A is tagged null record; + + procedure P (I : Integer; X : A); + pragma Machine_Attribute (P, "strub", "at-calls"); + + function F (X : access A) return Integer; + pragma Machine_Attribute (F, "strub", "at-calls"); + + type B is new A with null record; + + overriding + procedure P (I : Integer; X : B); + pragma Machine_Attribute (P, "strub", "at-calls"); + + overriding + function F (X : access B) return Integer; + pragma Machine_Attribute (F, "strub", "at-calls"); + + end Foo; + + package body Foo is + procedure P (I : Integer; X : A) is + begin + null; + end; + + function F (X : access A) return Integer is (0); + + overriding + procedure P (I : Integer; X : B) is + begin + P (I, A (X)); -- strub-at-calls non-dispatching call + end; + + overriding + function F (X : access B) return Integer is (1); + end Foo; + + use Foo; + + procedure Q (X : A'Class) is + begin + P (-1, X); -- strub-at-calls dispatching call. + end; + + XA : aliased A; + XB : aliased B; + I : Integer := 0; + XC : access A'Class; +begin + Q (XA); + Q (XB); + + I := I + F (XA'Access); -- strub-at-calls non-dispatching call + I := I + F (XB'Access); -- strub-at-calls non-dispatching call + + XC := XA'Access; + I := I + F (XC); -- strub-at-calls dispatching call. + + XC := XB'Access; + I := I + F (XC); -- strub-at-calls dispatching call. +end Strub_Disp1; + +-- { dg-final { scan-ipa-dump-times "\[(\]strub \[(\]at-calls\[)\]\[)\]" 4 "strub" } } + +-- Count the strub-at-calls non-dispatching calls +-- (+ 2 each, for the matching prototypes) +-- { dg-final { scan-ipa-dump-times "foo\.p \[(\]\[^\n\]*watermark" 3 "strub" } } +-- { dg-final { scan-ipa-dump-times "foo\.f \[(\]\[^\n\]*watermark" 4 "strub" } } + +-- Count the strub-at-calls dispatching calls. +-- { dg-final { scan-ipa-dump-times "_\[0-9\]* \[(\]\[^\n\]*watermark" 3 "strub" } } diff --git a/gcc/testsuite/gnat.dg/strub_ind.adb b/gcc/testsuite/gnat.dg/strub_ind.adb new file mode 100644 index 0000000000000..da56acaa957d2 --- /dev/null +++ b/gcc/testsuite/gnat.dg/strub_ind.adb @@ -0,0 +1,33 @@ +-- { dg-do compile } +-- { dg-options "-fstrub=strict" } + +-- This is essentially the same test as strub_attr.adb, +-- but applying attributes to access types as well. +-- That doesn't quite work yet, so we get an error we shouldn't get. + +package body Strub_Ind is + E : exception; + + function G return Integer; + + procedure P (X : Integer) is + begin + raise E; + end; + + function F (X : Integer) return Integer is + begin + return X * X; + end; + + function G return Integer is (FP (X)); + + type GT is access function return Integer; + + type GT_SAC is access function return Integer; + pragma Machine_Attribute (GT_SAC, "strub", "at-calls"); + + GP : GT_SAC := GT_SAC (GT'(G'Access)); -- { dg-error "incompatible" } + -- pragma Machine_Attribute (GP, "strub", "at-calls"); + +end Strub_Ind; diff --git a/gcc/testsuite/gnat.dg/strub_ind.ads b/gcc/testsuite/gnat.dg/strub_ind.ads new file mode 100644 index 0000000000000..99a65fc24b1ec --- /dev/null +++ b/gcc/testsuite/gnat.dg/strub_ind.ads @@ -0,0 +1,17 @@ +package Strub_Ind is + procedure P (X : Integer); + pragma Machine_Attribute (P, "strub", "internal"); + + function F (X : Integer) return Integer; + pragma Machine_Attribute (F, "strub"); + + X : Integer := 0; + pragma Machine_Attribute (X, "strub"); + + type FT is access function (X : Integer) return Integer; + pragma Machine_Attribute (FT, "strub", "at-calls"); + + FP : FT := F'Access; + -- pragma Machine_Attribute (FP, "strub", "at-calls"); -- not needed + +end Strub_Ind; diff --git a/gcc/testsuite/gnat.dg/strub_ind1.adb b/gcc/testsuite/gnat.dg/strub_ind1.adb new file mode 100644 index 0000000000000..825e395e6819c --- /dev/null +++ b/gcc/testsuite/gnat.dg/strub_ind1.adb @@ -0,0 +1,41 @@ +-- { dg-do compile } +-- { dg-options "-fstrub=strict -fdump-ipa-strubm" } + +-- This is essentially the same test as strub_attr.adb, +-- but with an explicit conversion. + +package body Strub_Ind1 is + E : exception; + + type Strub_Int is New Integer; + pragma Machine_Attribute (Strub_Int, "strub"); + + function G return Integer; + pragma Machine_Attribute (G, "strub", "disabled"); + + procedure P (X : Integer) is + begin + raise E; + end; + + function G return Integer is (FP (X)); + + type GT is access function return Integer; + pragma Machine_Attribute (GT, "strub", "disabled"); + + type GT_SC is access function return Integer; + pragma Machine_Attribute (GT_SC, "strub", "callable"); + + GP : GT_SC := GT_SC (GT'(G'Access)); + -- pragma Machine_Attribute (GP, "strub", "callable"); -- not needed. + + function F (X : Integer) return Integer is + begin + return X * GP.all; + end; + +end Strub_Ind1; + +-- { dg-final { scan-ipa-dump-times "\[(\]strub \[(\]disabled\[)\]\[)\]" 1 "strubm" } } +-- { dg-final { scan-ipa-dump-times "\[(\]strub \[(\]internal\[)\]\[)\]" 1 "strubm" } } +-- { dg-final { scan-ipa-dump-times "\[(\]strub\[)\]" 1 "strubm" } } diff --git a/gcc/testsuite/gnat.dg/strub_ind1.ads b/gcc/testsuite/gnat.dg/strub_ind1.ads new file mode 100644 index 0000000000000..d3f1273b3a6b9 --- /dev/null +++ b/gcc/testsuite/gnat.dg/strub_ind1.ads @@ -0,0 +1,17 @@ +package Strub_Ind1 is + procedure P (X : Integer); + pragma Machine_Attribute (P, "strub", "internal"); + + function F (X : Integer) return Integer; + pragma Machine_Attribute (F, "strub"); + + X : aliased Integer := 0; + pragma Machine_Attribute (X, "strub"); + + type FT is access function (X : Integer) return Integer; + pragma Machine_Attribute (FT, "strub", "at-calls"); + + FP : FT := F'Access; + pragma Machine_Attribute (FP, "strub", "at-calls"); + +end Strub_Ind1; diff --git a/gcc/testsuite/gnat.dg/strub_ind2.adb b/gcc/testsuite/gnat.dg/strub_ind2.adb new file mode 100644 index 0000000000000..e918b39263117 --- /dev/null +++ b/gcc/testsuite/gnat.dg/strub_ind2.adb @@ -0,0 +1,34 @@ +-- { dg-do compile } +-- { dg-options "-fstrub=strict" } + +-- This is essentially the same test as strub_attr.adb, +-- but with an explicit conversion. + +package body Strub_Ind2 is + E : exception; + + function G return Integer; + pragma Machine_Attribute (G, "strub", "callable"); + + procedure P (X : Integer) is + begin + raise E; + end; + + function G return Integer is (FP (X)); + + type GT is access function return Integer; + pragma Machine_Attribute (GT, "strub", "callable"); + + type GT_SD is access function return Integer; + pragma Machine_Attribute (GT_SD, "strub", "disabled"); + + GP : GT_SD := GT_SD (GT'(G'Access)); + -- pragma Machine_Attribute (GP, "strub", "disabled"); -- not needed. + + function F (X : Integer) return Integer is + begin + return X * GP.all; -- { dg-error "using non-.strub. type" } + end; + +end Strub_Ind2; diff --git a/gcc/testsuite/gnat.dg/strub_ind2.ads b/gcc/testsuite/gnat.dg/strub_ind2.ads new file mode 100644 index 0000000000000..e13865ec49c38 --- /dev/null +++ b/gcc/testsuite/gnat.dg/strub_ind2.ads @@ -0,0 +1,17 @@ +package Strub_Ind2 is + procedure P (X : Integer); + pragma Machine_Attribute (P, "strub", "internal"); + + function F (X : Integer) return Integer; + pragma Machine_Attribute (F, "strub"); + + X : Integer := 0; + pragma Machine_Attribute (X, "strub"); + + type FT is access function (X : Integer) return Integer; + pragma Machine_Attribute (FT, "strub", "at-calls"); + + FP : FT := F'Access; + pragma Machine_Attribute (FP, "strub", "at-calls"); + +end Strub_Ind2; diff --git a/gcc/testsuite/gnat.dg/strub_intf.adb b/gcc/testsuite/gnat.dg/strub_intf.adb new file mode 100644 index 0000000000000..728b85572b719 --- /dev/null +++ b/gcc/testsuite/gnat.dg/strub_intf.adb @@ -0,0 +1,93 @@ +-- { dg-do compile } + +-- Check that strub mode mismatches between overrider and overridden +-- subprograms are reported. + +procedure Strub_Intf is + package Foo is + type TP is interface; + procedure P (I : Integer; X : TP) is abstract; + pragma Machine_Attribute (P, "strub", "at-calls"); -- { dg-error "requires the same .strub. mode" } + + type TF is interface; + function F (X : access TF) return Integer is abstract; + + type TX is interface; + procedure P (I : Integer; X : TX) is abstract; + + type TI is interface and TP and TF and TX; + -- When we freeze TI, we detect the mismatch between the + -- inherited P and another parent's P. Because TP appears + -- before TX, we inherit P from TP, and report the mismatch at + -- the pragma inherited from TP against TX's P. In contrast, + -- when we freeze TII below, since TX appears before TP, we + -- report the error at the line in which the inherited + -- subprogram is synthesized, namely the line below, against + -- the line of the pragma. + + type TII is interface and TX and TP and TF; -- { dg-error "requires the same .strub. mode" } + + function F (X : access TI) return Integer is abstract; + pragma Machine_Attribute (F, "strub", "at-calls"); -- { dg-error "requires the same .strub. mode" } + + type A is new TI with null record; + + procedure P (I : Integer; X : A); + pragma Machine_Attribute (P, "strub", "at-calls"); -- { dg-error "requires the same .strub. mode" } + + function F (X : access A) return Integer; -- { dg-error "requires the same .strub. mode" } + + type B is new TI with null record; + + overriding + procedure P (I : Integer; X : B); -- { dg-error "requires the same .strub. mode" } + + overriding + function F (X : access B) return Integer; + pragma Machine_Attribute (F, "strub", "at-calls"); -- { dg-error "requires the same .strub. mode" } + + end Foo; + + package body Foo is + procedure P (I : Integer; X : A) is + begin + null; + end; + + function F (X : access A) return Integer is (0); + + overriding + procedure P (I : Integer; X : B) is + begin + P (I, A (X)); + end; + + overriding + function F (X : access B) return Integer is (1); + + end Foo; + + use Foo; + + procedure Q (X : TX'Class) is + begin + P (-1, X); + end; + + XA : aliased A; + XB : aliased B; + I : Integer := 0; + XC : access TI'Class; +begin + Q (XA); + Q (XB); + + I := I + F (XA'Access); + I := I + F (XB'Access); + + XC := XA'Access; + I := I + F (XC); + + XC := XB'Access; + I := I + F (XC); +end Strub_Intf; diff --git a/gcc/testsuite/gnat.dg/strub_intf1.adb b/gcc/testsuite/gnat.dg/strub_intf1.adb new file mode 100644 index 0000000000000..aa68fcd2c0b0e --- /dev/null +++ b/gcc/testsuite/gnat.dg/strub_intf1.adb @@ -0,0 +1,86 @@ +-- { dg-do compile } +-- { dg-options "-fdump-ipa-strub" } + +-- Check that at-calls dispatching calls to interfaces are transformed. + +procedure Strub_Intf1 is + package Foo is + type TX is Interface; + procedure P (I : Integer; X : TX) is abstract; + pragma Machine_Attribute (P, "strub", "at-calls"); + function F (X : access TX) return Integer is abstract; + pragma Machine_Attribute (F, "strub", "at-calls"); + + type A is new TX with null record; + + procedure P (I : Integer; X : A); + pragma Machine_Attribute (P, "strub", "at-calls"); + + function F (X : access A) return Integer; + pragma Machine_Attribute (F, "strub", "at-calls"); + + type B is new TX with null record; + + overriding + procedure P (I : Integer; X : B); + pragma Machine_Attribute (P, "strub", "at-calls"); + + overriding + function F (X : access B) return Integer; + pragma Machine_Attribute (F, "strub", "at-calls"); + + end Foo; + + package body Foo is + procedure P (I : Integer; X : A) is + begin + null; + end; + + function F (X : access A) return Integer is (0); + + overriding + procedure P (I : Integer; X : B) is + begin + P (I, A (X)); + end; + + overriding + function F (X : access B) return Integer is (1); + + end Foo; + + use Foo; + + procedure Q (X : TX'Class) is + begin + P (-1, X); + end; + + XA : aliased A; + XB : aliased B; + I : Integer := 0; + XC : access TX'Class; +begin + Q (XA); + Q (XB); + + I := I + F (XA'Access); + I := I + F (XB'Access); + + XC := XA'Access; + I := I + F (XC); + + XC := XB'Access; + I := I + F (XC); +end Strub_Intf1; + +-- { dg-final { scan-ipa-dump-times "\[(\]strub \[(\]at-calls\[)\]\[)\]" 4 "strub" } } + +-- Count the strub-at-calls non-dispatching calls +-- (+ 2 each, for the matching prototypes) +-- { dg-final { scan-ipa-dump-times "foo\.p \[(\]\[^\n\]*watermark" 3 "strub" } } +-- { dg-final { scan-ipa-dump-times "foo\.f \[(\]\[^\n\]*watermark" 4 "strub" } } + +-- Count the strub-at-calls dispatching calls. +-- { dg-final { scan-ipa-dump-times "_\[0-9\]* \[(\]\[^\n\]*watermark" 3 "strub" } } diff --git a/gcc/testsuite/gnat.dg/strub_intf2.adb b/gcc/testsuite/gnat.dg/strub_intf2.adb new file mode 100644 index 0000000000000..e8880dbc43730 --- /dev/null +++ b/gcc/testsuite/gnat.dg/strub_intf2.adb @@ -0,0 +1,55 @@ +-- { dg-do compile } + +-- Check that strub mode mismatches between overrider and overridden +-- subprograms are reported even when the overriders for an +-- interface's subprograms are inherited from a type that is not a +-- descendent of the interface. + +procedure Strub_Intf2 is + package Foo is + type A is tagged null record; + + procedure P (I : Integer; X : A); + pragma Machine_Attribute (P, "strub", "at-calls"); -- { dg-error "requires the same .strub. mode" } + + function F (X : access A) return Integer; + + type TX is Interface; + + procedure P (I : Integer; X : TX) is abstract; + + function F (X : access TX) return Integer is abstract; + pragma Machine_Attribute (F, "strub", "at-calls"); + + type B is new A and TX with null record; -- { dg-error "requires the same .strub. mode" } + + end Foo; + + package body Foo is + procedure P (I : Integer; X : A) is + begin + null; + end; + + function F (X : access A) return Integer is (0); + + end Foo; + + use Foo; + + procedure Q (X : TX'Class) is + begin + P (-1, X); + end; + + XB : aliased B; + I : Integer := 0; + XC : access TX'Class; +begin + Q (XB); + + I := I + F (XB'Access); + + XC := XB'Access; + I := I + F (XC); +end Strub_Intf2; diff --git a/gcc/testsuite/gnat.dg/strub_renm.adb b/gcc/testsuite/gnat.dg/strub_renm.adb new file mode 100644 index 0000000000000..217367e712d82 --- /dev/null +++ b/gcc/testsuite/gnat.dg/strub_renm.adb @@ -0,0 +1,21 @@ +-- { dg-do compile } + +procedure Strub_Renm is + procedure P (X : Integer); + pragma Machine_Attribute (P, "strub", "at-calls"); + + function F return Integer; + pragma Machine_Attribute (F, "strub", "internal"); + + procedure Q (X : Integer) renames P; -- { dg-error "requires the same .strub. mode" } + + function G return Integer renames F; + pragma Machine_Attribute (G, "strub", "callable"); -- { dg-error "requires the same .strub. mode" } + + procedure P (X : Integer) is null; + function F return Integer is (0); + +begin + P (F); + Q (G); +end Strub_Renm; diff --git a/gcc/testsuite/gnat.dg/strub_renm1.adb b/gcc/testsuite/gnat.dg/strub_renm1.adb new file mode 100644 index 0000000000000..a11adbfb5a9d6 --- /dev/null +++ b/gcc/testsuite/gnat.dg/strub_renm1.adb @@ -0,0 +1,32 @@ +-- { dg-do compile } +-- { dg-options "-fstrub=relaxed -fdump-ipa-strub" } + +procedure Strub_Renm1 is + V : Integer := 0; + pragma Machine_Attribute (V, "strub"); + + procedure P (X : Integer); + pragma Machine_Attribute (P, "strub", "at-calls"); + + function F return Integer; + + procedure Q (X : Integer) renames P; + pragma Machine_Attribute (Q, "strub", "at-calls"); + + function G return Integer renames F; + pragma Machine_Attribute (G, "strub", "internal"); + + procedure P (X : Integer) is null; + function F return Integer is (0); + +begin + P (F); + Q (G); +end Strub_Renm1; + +-- This is for P; Q is an alias. +-- { dg-final { scan-ipa-dump-times "\[(\]strub \[(\]at-calls\[)\]\[)\]" 1 "strub" } } + +-- This is *not* for G, but for Strub_Renm1. +-- { dg-final { scan-ipa-dump-times "\[(\]strub \[(\]wrapped\[)\]\[)\]" 1 "strub" } } +-- { dg-final { scan-ipa-dump-times "\[(\]strub \[(\]wrapper\[)\]\[)\]" 1 "strub" } } diff --git a/gcc/testsuite/gnat.dg/strub_renm2.adb b/gcc/testsuite/gnat.dg/strub_renm2.adb new file mode 100644 index 0000000000000..c488c20826fdb --- /dev/null +++ b/gcc/testsuite/gnat.dg/strub_renm2.adb @@ -0,0 +1,32 @@ +-- { dg-do compile } +-- { dg-options "-fstrub=strict -fdump-ipa-strub" } + +procedure Strub_Renm2 is + V : Integer := 0; + pragma Machine_Attribute (V, "strub"); + + procedure P (X : Integer); + pragma Machine_Attribute (P, "strub", "at-calls"); + + function F return Integer; + + procedure Q (X : Integer) renames P; + pragma Machine_Attribute (Q, "strub", "at-calls"); + + type T is access function return Integer; + + type TC is access function return Integer; + pragma Machine_Attribute (TC, "strub", "callable"); + + FCptr : constant TC := TC (T'(F'Access)); + + function G return Integer renames FCptr.all; + pragma Machine_Attribute (G, "strub", "callable"); + + procedure P (X : Integer) is null; + function F return Integer is (0); + +begin + P (F); -- { dg-error "calling non-.strub." } + Q (G); -- ok, G is callable. +end Strub_Renm2; diff --git a/gcc/testsuite/gnat.dg/strub_var.adb b/gcc/testsuite/gnat.dg/strub_var.adb new file mode 100644 index 0000000000000..3d158de28031f --- /dev/null +++ b/gcc/testsuite/gnat.dg/strub_var.adb @@ -0,0 +1,16 @@ +-- { dg-do compile } +-- { dg-options "-fstrub=strict -fdump-ipa-strubm" } + +-- We don't read from the automatic variable, but being an automatic +-- variable, its presence should be enough for the procedure to get +-- strub enabled. + +with Strub_Attr; +procedure Strub_Var is + X : Integer := 0; + pragma Machine_Attribute (X, "strub"); +begin + X := Strub_Attr.F (0); +end Strub_Var; + +-- { dg-final { scan-ipa-dump-times "\[(\]strub \[(\]internal\[)\]\[)\]" 1 "strubm" } } diff --git a/gcc/testsuite/gnat.dg/strub_var1.adb b/gcc/testsuite/gnat.dg/strub_var1.adb new file mode 100644 index 0000000000000..6a504e09198b6 --- /dev/null +++ b/gcc/testsuite/gnat.dg/strub_var1.adb @@ -0,0 +1,20 @@ +-- { dg-do compile } + +with Strub_Attr; +procedure Strub_Var1 is + type TA -- { dg-warning "does not apply to elements" } + is array (1..2) of Integer; + pragma Machine_Attribute (TA, "strub"); + + A : TA := (0, 0); -- { dg-warning "does not apply to elements" } + + type TR is record -- { dg-warning "does not apply to fields" } + M, N : Integer; + end record; + pragma Machine_Attribute (TR, "strub"); + + R : TR := (0, 0); + +begin + A(2) := Strub_Attr.F (A(1)); +end Strub_Var1;