[v2,04/10] Introduce strub: tests for C++ and Ada

Message ID	orlescmo3h.fsf_-_@lxoliva.fsfla.org
State	New
Headers	show Return-Path: <gcc-patches-bounces+incoming=patchwork.ozlabs.org@gcc.gnu.org> DMARC-Filter: OpenDMARC Filter v1.4.1 sourceware.org 7A91F3852764 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: <ormtqpsbuc.fsf@lxoliva.fsfla.org> <orpmti5ikv.fsf@lxoliva.fsfla.org> <or35eko33q.fsf_-_@lxoliva.fsfla.org> Date: Fri, 29 Jul 2022 03:26:10 -0300 In-Reply-To: <or35eko33q.fsf_-_@lxoliva.fsfla.org> (Alexandre Oliva's message of "Fri, 29 Jul 2022 03:16:41 -0300") Message-ID: <orlescmo3h.fsf_-_@lxoliva.fsfla.org> User-Agent: Gnus/5.13 (Gnus v5.13) Emacs/25.2 (gnu/linux) MIME-Version: 1.0 Content-Type: text/plain Precedence: list From: Alexandre Oliva via Gcc-patches <gcc-patches@gcc.gnu.org> Reply-To: Alexandre Oliva <oliva@adacore.com> Cc: Jan Hubicka <hubicka@ucw.cz>, Jim Wilson <wilson@tuliptree.org>, Graham Markall <graham.markall@embecosm.com> Errors-To: gcc-patches-bounces+incoming=patchwork.ozlabs.org@gcc.gnu.org Sender: "Gcc-patches" <gcc-patches-bounces+incoming=patchwork.ozlabs.org@gcc.gnu.org>
Series	Introduce strub: machine-independent stack scrubbing \| expand [v2,00/10] Introduce strub: machine-independent stack scrubbing [v2,01/10] Introduce strub: documentation, and new command-line options [v2,02/10] Introduce strub: torture tests for C and C++ [v2,03/10] Introduce strub: non-torture tests for C and C++ [v2,04/10] Introduce strub: tests for C++ and Ada [v2,05/10] Introduce strub: builtins and runtime [v2,06/10] Introduce strub: attributes [v2,07/10] Introduce strub: infrastructure interfaces and adjustments [v2,08/10] Introduce strub: strub modes

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;

[v2,04/10] Introduce strub: tests for C++ and Ada

Commit Message

Patch