From mboxrd@z Thu Jan 1 00:00:00 1970 Return-Path: Received: by sourceware.org (Postfix, from userid 2140) id 35BEE3857803; Tue, 16 Nov 2021 05:12:57 +0000 (GMT) DKIM-Filter: OpenDKIM Filter v2.11.0 sourceware.org 35BEE3857803 Content-Type: text/plain; charset="us-ascii" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit From: Alexandre Oliva To: gcc-cvs@gcc.gnu.org Subject: [gcc(refs/users/aoliva/heads/strub)] improve integration of strub with type systems X-Act-Checkin: gcc X-Git-Author: Alexandre Oliva X-Git-Refname: refs/users/aoliva/heads/strub X-Git-Oldrev: f2fd95e38ed141aa87ced600c39b26014b38bd8e X-Git-Newrev: 59af930547b3050c7d42ac30def41ce7910eab6f Message-Id: <20211116051257.35BEE3857803@sourceware.org> Date: Tue, 16 Nov 2021 05:12:57 +0000 (GMT) X-BeenThere: gcc-cvs@gcc.gnu.org X-Mailman-Version: 2.1.29 Precedence: list List-Id: Gcc-cvs mailing list List-Unsubscribe: , List-Archive: List-Help: List-Subscribe: , X-List-Received-Date: Tue, 16 Nov 2021 05:12:57 -0000 https://gcc.gnu.org/g:59af930547b3050c7d42ac30def41ce7910eab6f commit 59af930547b3050c7d42ac30def41ce7910eab6f Author: Alexandre Oliva Date: Sat Oct 30 07:03:48 2021 -0300 improve integration of strub with type systems This is the GCC part of a patch that brings various improvements to the integration of strub modes into language type systems. The bulk of the functional changes is in GNAT, and this patch introduces several tests corresponding to those improvements. It also adds warnings for strub modes applied to composite data types, analogous to a change in GNAT's gcc-interfaces, and a fix for strub callability testing when the callee is known, but converted to a type with a different strub mode. for gcc/ChangeLog * c-family/c-attribs.c (handle_strub_attribute): Simplify check for pointer-to-function types. Warn when applied to composite types. * ipa-strub.c: Rename to... * ipa-strub.cc: ... this. (strub_callable_from_p): Take strub modes. (verify_strub): Use strub_callable_from_p for indirect calls. Check for type casts in direct calls. for gcc/testsuite/ChangeLog * c-c++-common/strub-var1.c: New. * gnat.dg/strub_access.adb: New. * gnat.dg/strub_access1.adb: New. * gnat.dg/strub_disp.adb: New. * gnat.dg/strub_disp1.adb: New. * gnat.dg/strub_ind.adb: Update. * gnat.dg/strub_ind.ads: Update. * gnat.dg/strub_ind1.adb: New. * gnat.dg/strub_ind1.ads: New. * gnat.dg/strub_ind2.adb: New. * gnat.dg/strub_ind2.ads: New. * gnat.dg/strub_intf.adb: New. * gnat.dg/strub_intf1.adb: New. * gnat.dg/strub_intf2.adb: New. * gnat.dg/strub_renm.adb: New. * gnat.dg/strub_renm1.adb: New. * gnat.dg/strub_renm2.adb: New. * gnat.dg/strub_var.adb: New. * gnat.dg/strub_var1.adb: New. TN: U611-048 Change-Id: If1d00e15c7c21eec752692e22fa0d31e5ad38b4a Diff: --- gcc/c-family/c-attribs.c | 20 +++++-- gcc/{ipa-strub.c => ipa-strub.cc} | 37 ++++++------- gcc/testsuite/c-c++-common/strub-var1.c | 24 +++++++++ gcc/testsuite/gnat.dg/strub_access.adb | 21 ++++++++ gcc/testsuite/gnat.dg/strub_access1.adb | 16 ++++++ gcc/testsuite/gnat.dg/strub_disp.adb | 64 +++++++++++++++++++++++ gcc/testsuite/gnat.dg/strub_disp1.adb | 79 ++++++++++++++++++++++++++++ gcc/testsuite/gnat.dg/strub_ind.adb | 29 ++++------ gcc/testsuite/gnat.dg/strub_ind.ads | 8 +-- gcc/testsuite/gnat.dg/strub_ind1.adb | 41 +++++++++++++++ gcc/testsuite/gnat.dg/strub_ind1.ads | 17 ++++++ gcc/testsuite/gnat.dg/strub_ind2.adb | 34 ++++++++++++ gcc/testsuite/gnat.dg/strub_ind2.ads | 17 ++++++ gcc/testsuite/gnat.dg/strub_intf.adb | 93 +++++++++++++++++++++++++++++++++ gcc/testsuite/gnat.dg/strub_intf1.adb | 86 ++++++++++++++++++++++++++++++ gcc/testsuite/gnat.dg/strub_intf2.adb | 55 +++++++++++++++++++ gcc/testsuite/gnat.dg/strub_renm.adb | 21 ++++++++ gcc/testsuite/gnat.dg/strub_renm1.adb | 32 ++++++++++++ gcc/testsuite/gnat.dg/strub_renm2.adb | 32 ++++++++++++ gcc/testsuite/gnat.dg/strub_var.adb | 16 ++++++ gcc/testsuite/gnat.dg/strub_var1.adb | 20 +++++++ 21 files changed, 714 insertions(+), 48 deletions(-) diff --git a/gcc/c-family/c-attribs.c b/gcc/c-family/c-attribs.c index ab44f9e38c4..82a75d3f0fc 100644 --- a/gcc/c-family/c-attribs.c +++ b/gcc/c-family/c-attribs.c @@ -1311,9 +1311,7 @@ handle_strub_attribute (tree *node, tree name, { bool enable = true; - if (args - && POINTER_TYPE_P (*node) - && FUNC_OR_METHOD_TYPE_P (TREE_TYPE (*node))) + if (args && FUNCTION_POINTER_TYPE_P (*node)) *node = TREE_TYPE (*node); if (args && FUNC_OR_METHOD_TYPE_P (*node)) @@ -1355,6 +1353,22 @@ handle_strub_attribute (tree *node, tree name, enable = false; } + /* Warn about unmet expectations that the strub attribute works like a + qualifier. ??? Could/should we extend it to the element/field types + here? */ + if (TREE_CODE (*node) == ARRAY_TYPE + || VECTOR_TYPE_P (*node) + || TREE_CODE (*node) == COMPLEX_TYPE) + warning (OPT_Wattributes, + "attribute %qE does not apply to elements" + " of non-scalar type %qT", + name, *node); + else if (RECORD_OR_UNION_TYPE_P (*node)) + warning (OPT_Wattributes, + "attribute %qE does not apply to fields" + " of aggregate type %qT", + name, *node); + /* If we see a strub-enabling attribute, and we're at the default setting, implicitly or explicitly, note that the attribute was seen, so that we can reduce the compile-time overhead to nearly zero when the strub feature is diff --git a/gcc/ipa-strub.c b/gcc/ipa-strub.cc similarity index 99% rename from gcc/ipa-strub.c rename to gcc/ipa-strub.cc index 367245a4d87..698d122c6b3 100644 --- a/gcc/ipa-strub.c +++ b/gcc/ipa-strub.cc @@ -1187,11 +1187,8 @@ set_strub_mode (cgraph_node *node) only be called from strub functions. */ static bool -strub_callable_from_p (cgraph_node *callee, cgraph_node *caller) +strub_callable_from_p (strub_mode caller_mode, strub_mode callee_mode) { - strub_mode caller_mode = get_strub_mode (caller); - strub_mode callee_mode = get_strub_mode (callee); - switch (caller_mode) { case STRUB_WRAPPED: @@ -1339,25 +1336,16 @@ verify_strub () FOR_EACH_FUNCTION_WITH_GIMPLE_BODY (node) { enum strub_mode caller_mode = get_strub_mode (node); - bool strub_context - = (caller_mode == STRUB_AT_CALLS - || caller_mode == STRUB_AT_CALLS_OPT - || caller_mode == STRUB_INTERNAL - || caller_mode == STRUB_WRAPPED - || caller_mode == STRUB_INLINABLE); for (cgraph_edge *e = node->indirect_calls; e; e = e->next_callee) { gcc_checking_assert (e->indirect_unknown_callee); - if (!strub_context) - continue; tree callee_fntype = gimple_call_fntype (e->call_stmt); enum strub_mode callee_mode = get_strub_mode_from_type (callee_fntype); - if (callee_mode == STRUB_DISABLED - || callee_mode == STRUB_INTERNAL) + if (!strub_callable_from_p (caller_mode, callee_mode)) error_at (gimple_location (e->call_stmt), "indirect non-% call in % context %qD", node->decl); @@ -1366,22 +1354,35 @@ verify_strub () for (cgraph_edge *e = node->callees; e; e = e->next_callee) { gcc_checking_assert (!e->indirect_unknown_callee); - if (!strub_callable_from_p (e->callee, node)) + + tree callee_fntype = gimple_call_fntype (e->call_stmt); + bool same_type_p = TREE_TYPE (e->callee->decl) == callee_fntype; + strub_mode callee_mode + = (same_type_p + ? get_strub_mode (e->callee) + : get_strub_mode_from_type (callee_fntype)); + + if (!strub_callable_from_p (caller_mode, callee_mode)) { - if (get_strub_mode (e->callee) == STRUB_INLINABLE) + if (callee_mode == STRUB_INLINABLE) error_at (gimple_location (e->call_stmt), "calling % % %qD" " in non-% context %qD", e->callee->decl, node->decl); else if (fndecl_built_in_p (e->callee->decl, BUILT_IN_APPLY_ARGS) - && get_strub_mode (node) == STRUB_INTERNAL) + && callee_mode == STRUB_INTERNAL) /* This is ok, it will be kept in the STRUB_WRAPPER, and removed from the STRUB_WRAPPED's strub context. */ continue; - else + else if (same_type_p) error_at (gimple_location (e->call_stmt), "calling non-% %qD in % context %qD", e->callee->decl, node->decl); + else + error_at (gimple_location (e->call_stmt), + "calling %qD using non-% type %qT" + " in % context %qD", + e->callee->decl, callee_fntype, node->decl); } } } diff --git a/gcc/testsuite/c-c++-common/strub-var1.c b/gcc/testsuite/c-c++-common/strub-var1.c new file mode 100644 index 00000000000..eb6250fd39c --- /dev/null +++ b/gcc/testsuite/c-c++-common/strub-var1.c @@ -0,0 +1,24 @@ +/* { dg-do compile } */ + +int __attribute__ ((strub)) x; +float __attribute__ ((strub)) f; +double __attribute__ ((strub)) d; + +/* The attribute applies to the type of the declaration, i.e., to the pointer + variable p, not to the pointed-to integer. */ +int __attribute__ ((strub)) * +p = &x; /* { dg-message "incompatible|invalid conversion" } */ + +typedef int __attribute__ ((strub)) strub_int; +strub_int *q = &x; /* Now this is compatible. */ + +int __attribute__ ((strub)) +a[2]; /* { dg-warning "does not apply to elements" } */ + +int __attribute__ ((vector_size (4 * sizeof (int)))) + __attribute__ ((strub)) +v; /* { dg-warning "does not apply to elements" } */ + +struct s { + int i, j; +} __attribute__ ((strub)) w; /* { dg-warning "does not apply to fields" } */ diff --git a/gcc/testsuite/gnat.dg/strub_access.adb b/gcc/testsuite/gnat.dg/strub_access.adb new file mode 100644 index 00000000000..29e6996ecf6 --- /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 00000000000..dae47060164 --- /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_disp.adb b/gcc/testsuite/gnat.dg/strub_disp.adb new file mode 100644 index 00000000000..3dbcc4a357c --- /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 00000000000..09756a74b7d --- /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 index d08341a23b3..da56acaa957 100644 --- a/gcc/testsuite/gnat.dg/strub_ind.adb +++ b/gcc/testsuite/gnat.dg/strub_ind.adb @@ -1,5 +1,5 @@ -- { dg-do compile } --- { dg-options "-fstrub=strict -fdump-ipa-strubm" } +-- { dg-options "-fstrub=strict" } -- This is essentially the same test as strub_attr.adb, -- but applying attributes to access types as well. @@ -8,6 +8,8 @@ package body Strub_Ind is E : exception; + function G return Integer; + procedure P (X : Integer) is begin raise E; @@ -18,27 +20,14 @@ package body Strub_Ind is return X * X; end; - function G return Integer is (FP (X)); -- { dg-bogus "non-.strub." "" { xfail *-*-* } } - -- 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. - + function G return Integer is (FP (X)); type GT is access function return Integer; - pragma Machine_Attribute (GT, "strub", "at-calls"); - -- The pragma above seems to have no effect. - GP : GT := G'Access; -- { dg-warning "incompatible" "" { xfail *-*-* } } - pragma Machine_Attribute (GP, "strub", "at-calls"); - -- The pragma above does modify GP's type, - -- but dereferencing it uses an unmodified copy of the type. - -- The initializer should be diagnosed: - -- GT should only reference functions with at-calls strub. + type GT_SAC is access function return Integer; + pragma Machine_Attribute (GT_SAC, "strub", "at-calls"); -end Strub_Ind; + GP : GT_SAC := GT_SAC (GT'(G'Access)); -- { dg-error "incompatible" } + -- pragma Machine_Attribute (GP, "strub", "at-calls"); --- { 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" } } - --- No "strub" dump checking because of the bogus error above. +end Strub_Ind; diff --git a/gcc/testsuite/gnat.dg/strub_ind.ads b/gcc/testsuite/gnat.dg/strub_ind.ads index 53dede60eac..99a65fc24b1 100644 --- a/gcc/testsuite/gnat.dg/strub_ind.ads +++ b/gcc/testsuite/gnat.dg/strub_ind.ads @@ -8,16 +8,10 @@ package Strub_Ind is X : Integer := 0; pragma Machine_Attribute (X, "strub"); - function G return Integer; - type FT is access function (X : Integer) return Integer; pragma Machine_Attribute (FT, "strub", "at-calls"); - -- The pragma above seems to get discarded in GNAT; Gigi doesn't see it. FP : FT := F'Access; - pragma Machine_Attribute (FP, "strub", "at-calls"); - -- The pragma above does modify FP's type, - -- but a call with it gets it converted to its Ada type, - -- that is cached by the translator as the unmodified type. + -- 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 00000000000..825e395e681 --- /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 00000000000..d3f1273b3a6 --- /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 00000000000..e918b392631 --- /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 00000000000..e13865ec49c --- /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 00000000000..728b85572b7 --- /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 00000000000..aa68fcd2c0b --- /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 00000000000..e8880dbc437 --- /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 00000000000..217367e712d --- /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 00000000000..a11adbfb5a9 --- /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 00000000000..c488c20826f --- /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 00000000000..3d158de2803 --- /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 00000000000..6a504e09198 --- /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;