public inbox for gcc-cvs@sourceware.org
help / color / mirror / Atom feed
* [gcc(refs/users/aoliva/heads/testme)] Improve integration of strub with type systems
@ 2021-11-16 3:48 Alexandre Oliva
0 siblings, 0 replies; 6+ messages in thread
From: Alexandre Oliva @ 2021-11-16 3:48 UTC (permalink / raw)
To: gcc-cvs
https://gcc.gnu.org/g:cf168b3096ab6e0931e3f43ab71bf692d67ca2aa
commit cf168b3096ab6e0931e3f43ab71bf692d67ca2aa
Author: Alexandre Oliva <oliva@adacore.com>
Date: Sat Oct 30 07:06:41 2021 -0300
Improve integration of strub with type systems
This is a patch that complements changes to front-end and back-end,
adjusting the build system to build a newly-added package, and
improving handling of the strub attribute to warn on composite types.
[changelog]
* gcc-interface/Make-lang.in: (GNAT_ADA_OBJS): Add
ada/strub.o.
* gcc-interface/utils.c (handle_strub_attribute): Simplify
check for pointer-to-function types. Warn when applied to
composite types.
TN: U611-048
Change-Id: I05a28cbe8186a33d810a9d2adadc0aa4905c5ddc
Diff:
---
gcc/ada/gcc-interface/Make-lang.in | 1 +
gcc/ada/gcc-interface/utils.c | 20 +++++++++++++++++---
2 files changed, 18 insertions(+), 3 deletions(-)
diff --git a/gcc/ada/gcc-interface/Make-lang.in b/gcc/ada/gcc-interface/Make-lang.in
index ab5fb72623b..ae5158a5484 100644
--- a/gcc/ada/gcc-interface/Make-lang.in
+++ b/gcc/ada/gcc-interface/Make-lang.in
@@ -440,6 +440,7 @@ GNAT_ADA_OBJS = \
ada/sprint.o \
ada/stand.o \
ada/stringt.o \
+ ada/strub.o \
ada/style.o \
ada/styleg.o \
ada/stylesw.o \
diff --git a/gcc/ada/gcc-interface/utils.c b/gcc/ada/gcc-interface/utils.c
index fb9efb23eb9..54fb88a1ad7 100644
--- a/gcc/ada/gcc-interface/utils.c
+++ b/gcc/ada/gcc-interface/utils.c
@@ -6616,9 +6616,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))
@@ -6660,6 +6658,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
^ permalink raw reply [flat|nested] 6+ messages in thread
* [gcc(refs/users/aoliva/heads/testme)] Improve integration of strub with type systems
@ 2022-04-06 15:02 Alexandre Oliva
0 siblings, 0 replies; 6+ messages in thread
From: Alexandre Oliva @ 2022-04-06 15:02 UTC (permalink / raw)
To: gcc-cvs
https://gcc.gnu.org/g:23f3dd5793a29e1ac5642af2561a0b9582ccfea9
commit 23f3dd5793a29e1ac5642af2561a0b9582ccfea9
Author: Alexandre Oliva <oliva@adacore.com>
Date: Sat Oct 30 07:09:37 2021 -0300
Improve integration of strub with type systems
This patch brings various improvements to the integration of strub
modes into the Ada type system. Strub modes for subprograms are
promoted to subprogram types when applied to access-to-subprogram
objects and types, and promoted from subprograms to access types'
designated types. Matching strub modes are required for renaming,
overriding, interface implementation, and compatible strub modes are
required for conversions.
A complementary patch for the GCC interface introduces matching build
system changes, and warnings when strub modes are applied to composite
data objects or their types, and another complementary patch for GCC
does the same for C-family languages.
The GCC patch also fixes a strub callability error affecting
type-converted direct calls, and several tests to exercise the
newly-added features, and reverts strub annotations from public
subprograms, that would have caused their renamings to be rejected.
[changelog]
* MANIFEST.GNAT: Added...
* strub.adb, strub.ads: New files.
* exp_attr.adb (Access_Cases): Copy strub mode to subprogram type.
* exp_disp.adb (Expand_Dispatching_Call): Likewise.
* freeze.adb (Check_Inherited_Conditions): Check that strub modes
match overridden subprograms and interfaces.
(Freeze_All): Renaming declarations too.
* sem_attr.adb (Resolve_Attribute): Reject 'Access to
strub-annotated data object.
* sem_ch3.adb (Derive_Subprogram): Copy strub mode to
inherited subprogram.
* sem_prag.adb (Analyze_Pragma): Propagate Strub Machine_Attribute
from access-to-subprogram to subprogram type when required,
but not from access-to-data to data type. Mark the entity that
got the pragma as having a gigi rep item.
* sem_res.adb (Resolve): Reject implicit conversions that
would change strub modes.
(Resolve_Type_Conversions): Reject checked conversions
between incompatible strub modes.
* doc/gnat_rm/security_hardening_features.rst: Update.
* libgnat/a-except.ads (Raise_Exception): Revert strub-callable
annotation in public subprogram.
* libgnat/s-arit128.ads (Multiply_With_Ovflo_Check128): Likewise.
* libgnat/s-arit64.ads (Multiply_With_Ovflo_Check64): Likewise.
* libgnat/a-secsta.ads (SS_Allocate): Likewise.
(SS_Mark, SS_Release): Likewise.
TN: U611-048
Change-Id: I69191dec2186af26de1557b688c42e52bd986662
Diff:
---
.../doc/gnat_rm/security_hardening_features.rst | 60 +++-
gcc/ada/exp_attr.adb | 2 +
gcc/ada/exp_disp.adb | 2 +
gcc/ada/freeze.adb | 75 ++++-
gcc/ada/libgnat/a-except.ads | 7 +-
gcc/ada/libgnat/s-arit128.ads | 7 -
gcc/ada/libgnat/s-arit64.ads | 7 -
gcc/ada/libgnat/s-secsta.ads | 5 -
gcc/ada/sem_attr.adb | 22 ++
gcc/ada/sem_ch3.adb | 3 +
gcc/ada/sem_prag.adb | 27 +-
gcc/ada/sem_res.adb | 43 ++-
gcc/ada/strub.adb | 301 +++++++++++++++++++++
gcc/ada/strub.ads | 115 ++++++++
14 files changed, 630 insertions(+), 46 deletions(-)
diff --git a/gcc/ada/doc/gnat_rm/security_hardening_features.rst b/gcc/ada/doc/gnat_rm/security_hardening_features.rst
index cf76938d91d..bdcfd99ad86 100644
--- a/gcc/ada/doc/gnat_rm/security_hardening_features.rst
+++ b/gcc/ada/doc/gnat_rm/security_hardening_features.rst
@@ -73,20 +73,52 @@ Note that Ada secondary stacks are not scrubbed. The restriction
``No_Secondary_Stack`` avoids their use, and thus their accidental
preservation of data that should be scrubbed.
-Also note that the machine attribute is not integrated in the Ada type
-system. Though it may modify subprogram and variable interfaces, it
-is not fully reflected in Ada types, ``Access`` attributes, renaming
-and overriding. Every access type, renaming, and overriding and
-overridden dispatching operations that may refer to an entity with an
-attribute-modified interface must be annotated with the same
-interface-modifying attribute, or with an interface-compatible one.
-
-Even then, the pragma is currently only functional when applied to
-subprograms and scalar variables; other uses, such as directly on
-types and subtypes, may be silently ignored. Specifically, it is not
-currently recommended to rely on any effects this pragma might be
-expected to have when calling subprograms through access-to-subprogram
-variables.
+Attributes ``Access`` and ``Unconstrained_Access`` of variables and
+constants with ``strub`` enabled require types with ``strub`` enabled;
+there is no way to express an access-to-strub type otherwise.
+``Unchecked_Access`` bypasses this constraint, but the resulting
+access type designates a non-strub type.
+
+.. code-block:: ada
+
+ VI : Integer;
+ XsVI : access Integer := VI'Access; -- Error.
+ UXsVI : access Integer := VI'Unchecked_Access; -- OK,
+ -- UXsVI.all does not enable strub in the enclosing subprogram.
+
+ type Strub_Int is new Integer;
+ pragma Machine_Attribute (Strub_Int, "strub");
+ VSI : Strub_Int;
+ XsVSI : access Strub_Int := VSI'Access; -- OK.
+ -- XsVSI.all enables strub in the enclosing subprogram.
+
+
+Every access-to-subprogram type, renaming, and overriding and
+overridden dispatching operations that may refer to a subprogram with
+an attribute-modified interface must be annotated with the same
+interface-modifying attribute. Access-to-subprogram types can be
+explicitly converted to different strub modes, as long as they are
+interface-compatible (i.e., adding or removing ``at-calls`` is not
+allowed). For example, a ``strub``-``disabled`` subprogram can be
+turned ``callable`` through such an explicit conversion:
+
+.. code-block:: ada
+
+ type TBar is access procedure;
+
+ type TBar_Callable is access procedure;
+ pragma Machine_Attribute (TBar_Callable, "strub", "callable");
+
+ Bar_Callable_Ptr : constant TBar_Callable
+ := TBar_Callable (TBar'(Bar'Access));
+
+ procedure Bar_Callable renames Bar_Callable_Ptr.all;
+ pragma Machine_Attribute (Bar_Callable, "strub", "callable");
+
+Note that the renaming declaration is expanded to a full subprogram
+body, it won't be just an alias. Only if it is inlined will it be as
+efficient as a call by dereferencing the access-to-subprogram constant
+Bar_Callable_Ptr.
.. Hardened Conditionals:
diff --git a/gcc/ada/exp_attr.adb b/gcc/ada/exp_attr.adb
index bc7e045f51b..5374dd4d7e9 100644
--- a/gcc/ada/exp_attr.adb
+++ b/gcc/ada/exp_attr.adb
@@ -67,6 +67,7 @@ with Sinfo.Utils; use Sinfo.Utils;
with Snames; use Snames;
with Stand; use Stand;
with Stringt; use Stringt;
+with Strub; use Strub;
with Tbuild; use Tbuild;
with Ttypes; use Ttypes;
with Uintp; use Uintp;
@@ -2160,6 +2161,7 @@ package body Exp_Attr is
begin
Subp_Typ := Create_Itype (E_Subprogram_Type, N);
+ Copy_Strub_Mode (Subp_Typ, Subp);
Set_Etype (Subp_Typ, Etype (Subp));
Set_Returns_By_Ref (Subp_Typ, Returns_By_Ref (Subp));
diff --git a/gcc/ada/exp_disp.adb b/gcc/ada/exp_disp.adb
index f06a4c4ea76..f2d20af52d0 100644
--- a/gcc/ada/exp_disp.adb
+++ b/gcc/ada/exp_disp.adb
@@ -66,6 +66,7 @@ with Sinfo.Utils; use Sinfo.Utils;
with Snames; use Snames;
with Stand; use Stand;
with Stringt; use Stringt;
+with Strub; use Strub;
with SCIL_LL; use SCIL_LL;
with Tbuild; use Tbuild;
@@ -846,6 +847,7 @@ package body Exp_Disp is
end if;
Subp_Typ := Create_Itype (E_Subprogram_Type, Call_Node);
+ Copy_Strub_Mode (Subp_Typ, Subp);
Subp_Ptr_Typ := Create_Itype (E_Access_Subprogram_Type, Call_Node);
Set_Etype (Subp_Typ, Res_Typ);
Set_Returns_By_Ref (Subp_Typ, Returns_By_Ref (Subp));
diff --git a/gcc/ada/freeze.adb b/gcc/ada/freeze.adb
index de04a08ae8a..7ed44f591fc 100644
--- a/gcc/ada/freeze.adb
+++ b/gcc/ada/freeze.adb
@@ -69,6 +69,7 @@ with Sinfo.Utils; use Sinfo.Utils;
with Snames; use Snames;
with Stand; use Stand;
with Stringt; use Stringt;
+with Strub; use Strub;
with Targparm; use Targparm;
with Tbuild; use Tbuild;
with Ttypes; use Ttypes;
@@ -1790,6 +1791,10 @@ package body Freeze is
return Result;
end Needs_Wrapper;
+ Ifaces_List : Elist_Id := No_Elist;
+ Ifaces_Listed : Boolean := False;
+ -- Cache the list of interface operations inherited by R
+
-- Start of processing for Check_Inherited_Conditions
begin
@@ -1823,11 +1828,10 @@ package body Freeze is
while Present (Op_Node) loop
Prim := Node (Op_Node);
- if Present (Overridden_Operation (Prim))
+ Par_Prim := Overridden_Operation (Prim);
+ if Present (Par_Prim)
and then Comes_From_Source (Prim)
then
- Par_Prim := Overridden_Operation (Prim);
-
-- When the primitive is an LSP wrapper we climb to the parent
-- primitive that has the inherited contract.
@@ -1837,6 +1841,11 @@ package body Freeze is
Par_Prim := LSP_Subprogram (Par_Prim);
end if;
+ -- Check that overrider and overridden operations have
+ -- the same strub mode.
+
+ Check_Same_Strub_Mode (Prim, Par_Prim);
+
-- Analyze the contract items of the overridden operation, before
-- they are rewritten as pragmas.
@@ -1852,6 +1861,54 @@ package body Freeze is
end if;
end if;
+ -- Go over operations inherited from interfaces and check
+ -- them for strub mode compatibility as well.
+
+ if Has_Interfaces (R)
+ and then Is_Dispatching_Operation (Prim)
+ and then Find_Dispatching_Type (Prim) = R
+ then
+ declare
+ Elmt : Elmt_Id;
+ Iface_Elmt : Elmt_Id;
+ Iface : Entity_Id;
+ Iface_Prim : Entity_Id;
+
+ begin
+ -- Collect the interfaces only once. We haven't
+ -- finished freezing yet, so we can't use the faster
+ -- search from Sem_Disp.Covered_Interface_Primitives.
+
+ if not Ifaces_Listed then
+ Collect_Interfaces (R, Ifaces_List);
+ Ifaces_Listed := True;
+ end if;
+
+ Iface_Elmt := First_Elmt (Ifaces_List);
+ while Present (Iface_Elmt) loop
+ Iface := Node (Iface_Elmt);
+
+ Elmt := First_Elmt (Primitive_Operations (Iface));
+ while Present (Elmt) loop
+ Iface_Prim := Node (Elmt);
+
+ if Iface_Prim /= Par_Prim
+ and then Chars (Iface_Prim) = Chars (Prim)
+ and then Comes_From_Source (Iface_Prim)
+ and then (Is_Interface_Conformant
+ (R, Iface_Prim, Prim))
+ then
+ Check_Same_Strub_Mode (Prim, Iface_Prim);
+ end if;
+
+ Next_Elmt (Elmt);
+ end loop;
+
+ Next_Elmt (Iface_Elmt);
+ end loop;
+ end;
+ end if;
+
Next_Elmt (Op_Node);
end loop;
@@ -2503,6 +2560,18 @@ package body Freeze is
Process_Default_Expressions (E, After);
end if;
+ -- Check subprogram renamings for the same strub-mode.
+ -- Avoid rechecking dispatching operations, that's taken
+ -- care of in Check_Inherited_Conditions, that covers
+ -- inherited interface operations.
+
+ Item := Alias (E);
+ if Present (Item)
+ and then not Is_Dispatching_Operation (E)
+ then
+ Check_Same_Strub_Mode (E, Item);
+ end if;
+
if not Has_Completion (E) then
Decl := Unit_Declaration_Node (E);
diff --git a/gcc/ada/libgnat/a-except.ads b/gcc/ada/libgnat/a-except.ads
index 4411e5b1c47..af87d6624a9 100644
--- a/gcc/ada/libgnat/a-except.ads
+++ b/gcc/ada/libgnat/a-except.ads
@@ -184,14 +184,9 @@ private
-- Raise_Exception_Always if it can determine this is the case. The Export
-- allows this routine to be accessed from Pure units.
- -- Make these callable from strub contexts.
pragma Machine_Attribute (Raise_Exception_Always,
"strub", "callable");
- pragma Machine_Attribute (Raise_Exception,
- "strub", "callable");
- -- This property should arguably be visible to callers, but let's
- -- keep it private for now. In practice, it doesn't matter, since
- -- it's only checked in the back end.
+ -- Make it callable from strub contexts
procedure Raise_From_Controlled_Operation (X : Exception_Occurrence);
pragma No_Return (Raise_From_Controlled_Operation);
diff --git a/gcc/ada/libgnat/s-arit128.ads b/gcc/ada/libgnat/s-arit128.ads
index b71fcd35d9a..fe043a97afb 100644
--- a/gcc/ada/libgnat/s-arit128.ads
+++ b/gcc/ada/libgnat/s-arit128.ads
@@ -167,11 +167,4 @@ is
-- then Q is the rounded quotient. The remainder R is not affected by the
-- setting of the Round flag.
-private
- -- Make it callable from strub contexts.
- -- There is a matching setting in trans.c,
- -- for calls issued by Gigi.
- pragma Machine_Attribute (Multiply_With_Ovflo_Check128,
- "strub", "callable");
-
end System.Arith_128;
diff --git a/gcc/ada/libgnat/s-arit64.ads b/gcc/ada/libgnat/s-arit64.ads
index 7ea58a48517..c4bebeb0e4e 100644
--- a/gcc/ada/libgnat/s-arit64.ads
+++ b/gcc/ada/libgnat/s-arit64.ads
@@ -179,11 +179,4 @@ is
Round : Boolean) renames Double_Divide64;
-- Renamed procedure to preserve compatibility with earlier versions
-private
- -- Make it callable from strub contexts.
- -- There is a matching setting in trans.c,
- -- for calls issued by Gigi.
- pragma Machine_Attribute (Multiply_With_Ovflo_Check64,
- "strub", "callable");
-
end System.Arith_64;
diff --git a/gcc/ada/libgnat/s-secsta.ads b/gcc/ada/libgnat/s-secsta.ads
index eaaba35e752..b75f1a3a264 100644
--- a/gcc/ada/libgnat/s-secsta.ads
+++ b/gcc/ada/libgnat/s-secsta.ads
@@ -438,9 +438,4 @@ private
function Get_Stack_Info (Stack : SS_Stack_Ptr) return Stack_Info;
-- Obtain the information attributes of secondary stack Stack
- pragma Machine_Attribute (SS_Allocate, "strub", "callable");
- pragma Machine_Attribute (SS_Mark, "strub", "callable");
- pragma Machine_Attribute (SS_Release, "strub", "callable");
- -- Enable these to be called from within strub contexts.
-
end System.Secondary_Stack;
diff --git a/gcc/ada/sem_attr.adb b/gcc/ada/sem_attr.adb
index 169a9d1a358..33179aa2f87 100644
--- a/gcc/ada/sem_attr.adb
+++ b/gcc/ada/sem_attr.adb
@@ -74,6 +74,7 @@ with Sinfo.Utils; use Sinfo.Utils;
with Sinput; use Sinput;
with System;
with Stringt; use Stringt;
+with Strub; use Strub;
with Style;
with Stylesw; use Stylesw;
with Targparm; use Targparm;
@@ -11315,6 +11316,27 @@ package body Sem_Attr is
Resolve (P);
end if;
+ -- Refuse to compute access to variables and constants when that
+ -- would drop the strub mode associated with them, unless they're
+ -- unchecked conversions. We don't have to do this when the types
+ -- of the data objects are annotated: then the access type
+ -- designates the annotated type, and there's no loss. Only when
+ -- the variable is annotated directly that the pragma gets
+ -- attached to the variable, rather than to its type, and then,
+ -- expressing an access-to-annotated-type type to hold the 'Access
+ -- result is not possible without resorting to that very annotated
+ -- type.
+
+ if Attr_Id /= Attribute_Unchecked_Access
+ and then Comes_From_Source (N)
+ and then Is_Entity_Name (P)
+ and then Explicit_Strub_Mode (Entity (P)) = Enabled
+ and then
+ Explicit_Strub_Mode (Designated_Type (Btyp)) = Unspecified
+ then
+ Error_Msg_F ("target access type drops `strub` mode from &", P);
+ end if;
+
-- X'Access is illegal if X denotes a constant and the access type
-- is access-to-variable. Same for 'Unchecked_Access. The rule
-- does not apply to 'Unrestricted_Access. If the reference is a
diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb
index d3c75229402..2e207c16e23 100644
--- a/gcc/ada/sem_ch3.adb
+++ b/gcc/ada/sem_ch3.adb
@@ -79,6 +79,7 @@ with Sinfo.Nodes; use Sinfo.Nodes;
with Sinfo.Utils; use Sinfo.Utils;
with Sinput; use Sinput;
with Snames; use Snames;
+with Strub; use Strub;
with Targparm; use Targparm;
with Tbuild; use Tbuild;
with Ttypes; use Ttypes;
@@ -16075,6 +16076,8 @@ package body Sem_Ch3 is
Set_Alias (New_Subp, Actual_Subp);
end if;
+ Copy_Strub_Mode (New_Subp, Alias (New_Subp));
+
-- Derived subprograms of a tagged type must inherit the convention
-- of the parent subprogram (a requirement of AI-117). Derived
-- subprograms of untagged types simply get convention Ada by default.
diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb
index 728b1c3a963..f9169eeedd7 100644
--- a/gcc/ada/sem_prag.adb
+++ b/gcc/ada/sem_prag.adb
@@ -84,6 +84,7 @@ with Sinfo.Utils; use Sinfo.Utils;
with Sinfo.CN; use Sinfo.CN;
with Sinput; use Sinput;
with Stringt; use Stringt;
+with Strub; use Strub;
with Stylesw; use Stylesw;
with Table;
with Targparm; use Targparm;
@@ -19494,7 +19495,29 @@ package body Sem_Prag is
Check_Arg_Is_OK_Static_Expression (Arg2, Standard_String);
Def_Id := Entity (Get_Pragma_Arg (Arg1));
- if Is_Access_Type (Def_Id) then
+ -- Apply the pragma to the designated type, rather than to the
+ -- access type, unless it's a strub annotation. We wish to enable
+ -- objects of access type, as well as access types themselves, to
+ -- be annotated, so that reading the access objects (as oposed to
+ -- the designated data) automatically enables stack
+ -- scrubbing. That said, as in the attribute handler that
+ -- processes the pragma turned into a compiler attribute, a strub
+ -- annotation that must be associated with a subprogram type (for
+ -- holding an explicit strub mode), when applied to an
+ -- access-to-subprogram, gets promoted to the subprogram type. We
+ -- might be tempted to leave it alone here, since the C attribute
+ -- handler will adjust it, but then GNAT would convert the
+ -- annotated subprogram types to naked ones before using them,
+ -- cancelling out their intended effects.
+
+ if Is_Access_Type (Def_Id)
+ and then (not Strub_Pragma_P (N)
+ or else
+ (Present (Arg3)
+ and then
+ Ekind (Designated_Type
+ (Def_Id)) = E_Subprogram_Type))
+ then
Def_Id := Designated_Type (Def_Id);
end if;
@@ -19512,7 +19535,7 @@ package body Sem_Prag is
if Rep_Item_Too_Late (Def_Id, N) then
return;
else
- Set_Has_Gigi_Rep_Item (Entity (Get_Pragma_Arg (Arg1)));
+ Set_Has_Gigi_Rep_Item (Def_Id);
end if;
end Machine_Attribute;
diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb
index ed94036c9b6..4f66b715778 100644
--- a/gcc/ada/sem_res.adb
+++ b/gcc/ada/sem_res.adb
@@ -82,6 +82,7 @@ with Sinfo.CN; use Sinfo.CN;
with Snames; use Snames;
with Stand; use Stand;
with Stringt; use Stringt;
+with Strub; use Strub;
with Style; use Style;
with Targparm; use Targparm;
with Tbuild; use Tbuild;
@@ -3179,6 +3180,27 @@ package body Sem_Res is
-- Only one interpretation
else
+ -- Prevent implicit conversions between access-to-subprogram types
+ -- with different strub modes. Explicit conversions are acceptable in
+ -- some circumstances. We don't have to be concerned about data or
+ -- access-to-data types. Conversions between data types can safely
+ -- drop or add strub attributes from types, because strub effects are
+ -- associated with the locations rather than values. E.g., converting
+ -- a hypothetical Strub_Integer variable to Integer would load the
+ -- value from the variable, enabling stack scrabbing for the
+ -- enclosing subprogram, and then convert the value to Integer. As
+ -- for conversions between access-to-data types, that's no different
+ -- from any other case of type punning.
+
+ if Is_Access_Type (Typ)
+ and then Ekind (Designated_Type (Typ)) = E_Subprogram_Type
+ and then Is_Access_Type (Expr_Type)
+ and then Ekind (Designated_Type (Expr_Type)) = E_Subprogram_Type
+ then
+ Check_Same_Strub_Mode
+ (Designated_Type (Typ), Designated_Type (Expr_Type));
+ end if;
+
-- In Ada 2005, if we have something like "X : T := 2 + 2;", where
-- the "+" on T is abstract, and the operands are of universal type,
-- the above code will have (incorrectly) resolved the "+" to the
@@ -14204,7 +14226,15 @@ package body Sem_Res is
end;
end if;
- return True;
+ -- Check that the strub modes are compatible.
+ -- We wish to reject explicit conversions only for
+ -- incompatible modes.
+
+ return Conversion_Check
+ (Compatible_Strub_Modes
+ (Designated_Type (Target_Type),
+ Designated_Type (Opnd_Type)),
+ "incompatible `strub` modes");
-- Remote access to subprogram types
@@ -14230,7 +14260,16 @@ package body Sem_Res is
Designated_Type (Corresponding_Remote_Type (Opnd_Type)),
Err_Loc =>
N);
- return True;
+
+ -- Check that the strub modes are compatible.
+ -- We wish to reject explicit conversions only for
+ -- incompatible modes.
+
+ return Conversion_Check
+ (Compatible_Strub_Modes
+ (Designated_Type (Target_Type),
+ Designated_Type (Opnd_Type)),
+ "incompatible `strub` modes");
-- If it was legal in the generic, it's legal in the instance
diff --git a/gcc/ada/strub.adb b/gcc/ada/strub.adb
new file mode 100644
index 00000000000..485c2632ed3
--- /dev/null
+++ b/gcc/ada/strub.adb
@@ -0,0 +1,301 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- S T R U B --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 2021-2022, Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 3, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNAT; see file COPYING3. If not, go to --
+-- http://www.gnu.org/licenses for a complete copy of the license. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- Package containing utility procedures related to Stack Scrubbing
+
+with Atree; use Atree;
+with Einfo; use Einfo;
+with Einfo.Entities; use Einfo.Entities;
+with Errout; use Errout;
+with Namet; use Namet;
+with Nlists; use Nlists;
+with Sem_Eval; use Sem_Eval;
+with Sinfo; use Sinfo;
+with Sinfo.Nodes; use Sinfo.Nodes;
+with Sinfo.Utils; use Sinfo.Utils;
+with Snames; use Snames;
+with Stringt; use Stringt;
+
+package body Strub is
+ -----------------------
+ -- Local Subprograms --
+ -----------------------
+
+ function Find_Explicit_Strub_Pragma (Id : Entity_Id) return Node_Id;
+ -- Return a pragma Machine_Attribute (Id, "strub"[, "mode"]) node
+ -- if Id has one.
+
+ function Strub_Pragma_Arg (Item : Node_Id) return Node_Id is
+ (Get_Pragma_Arg
+ (Next (Next (First (Pragma_Argument_Associations (Item))))));
+ -- Return the pragma argument holding the strub mode associated
+ -- with Item, a subprogram, variable, constant, or type. Bear in
+ -- mind that strub pragmas with an explicit strub mode argument,
+ -- naming access-to-subprogram types, are applied to the
+ -- designated subprogram type.
+
+ function Strub_Pragma_Arg_To_String (Item : Node_Id) return String is
+ (To_String (Strval (Expr_Value_S (Item))));
+ -- Extract and return as a String the strub mode held in a node
+ -- returned by Strub_Pragma_Arg.
+
+ function Strub_Pragma_Mode
+ (Id : Entity_Id;
+ Item : Node_Id) return Strub_Mode;
+ -- Return the strub mode associated with Item expressed in Id.
+ -- Strub_Pragma_P (Id) must hold.
+
+ ---------------------------
+ -- Check_Same_Strub_Mode --
+ ---------------------------
+
+ procedure Check_Same_Strub_Mode
+ (Dest, Src : Entity_Id;
+ Report : Boolean := True)
+ is
+ Src_Strub_Mode : constant Strub_Mode := Explicit_Strub_Mode (Src);
+ Dest_Strub_Mode : constant Strub_Mode := Explicit_Strub_Mode (Dest);
+
+ begin
+ if Dest_Strub_Mode = Src_Strub_Mode then
+ return;
+ end if;
+
+ -- Internal is not part of the interface, it's an *internal*
+ -- implementation detail, so consider it equivalent to unspecified here.
+ -- ??? -fstrub=relaxed|strict makes them interface-equivalent to
+ -- Callable or Disabled, respectively, but we don't look at that flag in
+ -- the front-end, and it seems undesirable for that flag to affect
+ -- whether specifications are conformant. Maybe there should be some
+ -- means to specify Callable or Disabled along with Internal?
+
+ if Dest_Strub_Mode in Unspecified | Internal
+ and then Src_Strub_Mode in Unspecified | Internal
+ then
+ return;
+ end if;
+
+ if not Report then
+ return;
+ end if;
+
+ if Src_Strub_Mode /= Unspecified then
+ Error_Msg_Sloc := Sloc (Find_Explicit_Strub_Pragma (Src));
+ else
+ Error_Msg_Sloc := Sloc (Src);
+ end if;
+ Error_Msg_Node_2 := Src;
+ Error_Msg_NE ("& requires the same `strub` mode as &#",
+ (if Dest_Strub_Mode /= Unspecified
+ then Find_Explicit_Strub_Pragma (Dest)
+ else Dest),
+ Dest);
+ end Check_Same_Strub_Mode;
+
+ ----------------------------
+ -- Compatible_Strub_Modes --
+ ----------------------------
+
+ function Compatible_Strub_Modes
+ (Dest, Src : Entity_Id) return Boolean
+ is
+ Src_Strub_Mode : constant Strub_Mode := Explicit_Strub_Mode (Src);
+ Dest_Strub_Mode : constant Strub_Mode := Explicit_Strub_Mode (Dest);
+
+ begin
+ return Src_Strub_Mode = Dest_Strub_Mode
+ or else At_Calls not in Src_Strub_Mode | Dest_Strub_Mode;
+ end Compatible_Strub_Modes;
+
+ ---------------------
+ -- Copy_Strub_Mode --
+ ---------------------
+
+ procedure Copy_Strub_Mode (Dest, Src : Entity_Id) is
+ Strub : Node_Id := Find_Explicit_Strub_Pragma (Src);
+ Src_Strub_Mode : constant Strub_Mode := Strub_Pragma_Mode (Src, Strub);
+
+ begin
+ pragma Assert (Explicit_Strub_Mode (Dest) = Unspecified);
+
+ -- Refrain from copying Internal to subprogram types.
+ -- It affects code generation for the subprogram,
+ -- but it has no effect on its type or interface.
+
+ if Src_Strub_Mode = Unspecified
+ or else (Ekind (Dest) = E_Subprogram_Type
+ and then Src_Strub_Mode = Internal)
+ then
+ return;
+ end if;
+
+ Strub := New_Copy (Strub);
+ Set_Next_Rep_Item (Strub, First_Rep_Item (Dest));
+ Set_First_Rep_Item (Dest, Strub);
+ Set_Has_Gigi_Rep_Item (Dest);
+ end Copy_Strub_Mode;
+
+ -------------------------
+ -- Explicit_Strub_Mode --
+ -------------------------
+
+ function Explicit_Strub_Mode (Id : Entity_Id) return Strub_Mode is
+ Item : constant Node_Id := Find_Explicit_Strub_Pragma (Id);
+
+ begin
+ return Strub_Pragma_Mode (Id, Item);
+ end Explicit_Strub_Mode;
+
+ --------------------------------
+ -- Find_Explicit_Strub_Pragma --
+ --------------------------------
+
+ function Find_Explicit_Strub_Pragma (Id : Entity_Id) return Node_Id is
+ Item : Node_Id;
+
+ begin
+ if not Has_Gigi_Rep_Item (Id) then
+ return Empty;
+ end if;
+
+ Item := First_Rep_Item (Id);
+ while Present (Item) loop
+ if Strub_Pragma_P (Item) then
+ return Item;
+ end if;
+ Item := Next_Rep_Item (Item);
+ end loop;
+
+ return Empty;
+ end Find_Explicit_Strub_Pragma;
+
+ -----------------------
+ -- Strub_Pragma_Mode --
+ -----------------------
+
+ function Strub_Pragma_Mode
+ (Id : Entity_Id;
+ Item : Node_Id) return Strub_Mode
+ is
+ Arg : Node_Id := Empty;
+
+ begin
+ -- ??? Enumeration literals, despite being conceptually functions, have
+ -- neither bodies nor stack frames, and it's not clear whether it would
+ -- make more sense to treat them as subprograms or as constants, but
+ -- they can be renamed as functions. Should we require all literals of
+ -- a type to have the same strub mode? Rule out their annotation?
+
+ if Ekind (Id) in E_Subprogram_Type
+ | Overloadable_Kind
+ | Generic_Subprogram_Kind
+ then
+ if Item = Empty then
+ return Unspecified;
+ end if;
+
+ Arg := Strub_Pragma_Arg (Item);
+ if Arg = Empty then
+ return At_Calls;
+ end if;
+
+ declare
+ Str : constant String := Strub_Pragma_Arg_To_String (Arg);
+ begin
+ if Str'Length /= 8 then
+ return Unspecified;
+ end if;
+
+ case Str (Str'First) is
+ when 'a' =>
+ if Str = "at-calls" then
+ return At_Calls;
+ end if;
+
+ when 'i' =>
+ if Str = "internal" then
+ return Internal;
+ end if;
+
+ when 'c' =>
+ if Str = "callable" then
+ return Callable;
+ end if;
+
+ when 'd' =>
+ if Str = "disabled" then
+ return Disabled;
+ end if;
+
+ when others =>
+ null;
+ end case;
+ return Unspecified;
+ end;
+
+ -- Access-to-subprogram types and variables can be treated just like
+ -- other access types, because the pragma logic has already promoted to
+ -- subprogram types any annotations applicable to them.
+
+ elsif Ekind (Id) in Type_Kind -- except E_Subprogram_Type, covered above
+ | Scalar_Kind
+ | Object_Kind
+ | Named_Kind
+ then
+ if Item = Empty then
+ return Unspecified;
+ end if;
+
+ Arg := Strub_Pragma_Arg (Item);
+ if Arg /= Empty then
+ -- A strub parameter is not applicable to variables,
+ -- and will be ignored.
+
+ return Unspecified;
+ end if;
+
+ return Enabled;
+
+ else
+ pragma Assert (Item = Empty);
+ return Not_Applicable;
+ end if;
+ end Strub_Pragma_Mode;
+
+ --------------------
+ -- Strub_Pragma_P --
+ --------------------
+
+ function Strub_Pragma_P
+ (Item : Node_Id) return Boolean is
+ (Nkind (Item) = N_Pragma
+ and then Pragma_Name (Item) = Name_Machine_Attribute
+ and then
+ Strub_Pragma_Arg_To_String
+ (Get_Pragma_Arg
+ (Next (First (Pragma_Argument_Associations (Item)))))
+ = "strub");
+
+end Strub;
diff --git a/gcc/ada/strub.ads b/gcc/ada/strub.ads
new file mode 100644
index 00000000000..3a67632a54a
--- /dev/null
+++ b/gcc/ada/strub.ads
@@ -0,0 +1,115 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- S T R U B --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 2021-2022, Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 3, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNAT; see file COPYING3. If not, go to --
+-- http://www.gnu.org/licenses for a complete copy of the license. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- Package containing utility procedures related to Stack Scrubbing
+
+with Types; use Types;
+
+package Strub is
+ type Strub_Mode is
+ (Disabled, -- Subprogram cannot be called from strub contexts
+ At_Calls, -- Subprogram strubbed by caller
+ Internal, -- Subprogram strubbed by wrapper
+ Callable, -- Subprogram safe to call despite no strub
+ Unspecified, -- Subprogram or data without strub annotation
+ Enabled, -- Data (variable or constant) that enables strub
+ Not_Applicable); -- Entities that are not strub-capable
+ -- This is the type that expresses decoded strub annotations
+
+ -- We compare strub modes in the following circumstances:
+
+ -- * subprogram definition vs specification
+ -- * overriding vs overridden dispatch subprograms
+ -- * implementation vs interface dispatch subprogram
+ -- * renaming vs renamed subprogram
+ -- * type resolution
+ -- * explicit conversions
+
+ -- Explicit conversions can convert between strub modes other than
+ -- at-calls (see Compatible_Strub_Modes), but for the other cases
+ -- above, we insist on identity of the strub modes (see
+ -- Check_Same_Strub_Mode). Anything else would be
+ -- troublesome.
+
+ -- E.g., overriding a callable subprogram with a strub-disabled
+ -- implementation would enable a subprogram that's unsafe to call
+ -- in strub contexts to be called through a dispatching
+ -- interface. An explicitly strub-disabled subprogram shall not be
+ -- called from strub contexts, and a callable overriding
+ -- subprogram would still seem not-callable, so accepting
+ -- different modes would be surprising.
+
+ -- We could relax the requirement for overriders from equality to
+ -- compatibility, with the understanding that the dispatching ABI
+ -- is what prevails. For renaming, however, if we don't require
+ -- equality, it would have to encompass an implicit conversion.
+
+ procedure Check_Same_Strub_Mode
+ (Dest, Src : Entity_Id;
+ Report : Boolean := True);
+ -- Check whether Dest and Src are subprograms or subprogram types
+ -- annotated (or not) with the same strub mode. If Report is
+ -- requested, and the strub modes are not equivalent, an error
+ -- message is issued. Unspecified and Internal are considered
+ -- equivalent, because Internal is an internal implementation
+ -- detail. Unspecified decays to Disabled or Callable depending on
+ -- -fstrub=(strict|relaxed), but this procedure does not take this
+ -- decay into account, which avoids turning strub-equivalent
+ -- declarations into incompatible ones at command-line changes.
+
+ function Compatible_Strub_Modes
+ (Dest, Src : Entity_Id) return Boolean;
+ -- Return True if Dest and Src are subprograms or subprogram types
+ -- annotated (or not) with ABI-compatible strub modes. At-calls is
+ -- incompatible to other strub modes, because the back end
+ -- internally modifies the signature of such subprograms, adding
+ -- hidden parameters. Calling a subprogram through an
+ -- access-to-subprogram object converted between strub-at-calls
+ -- and other strub modes should be deemed equivalent to
+ -- dereferencing an uninitialized access-to-data object, though
+ -- one-way conversions might seem to work in some circumstances.
+ --
+ -- Unspecified, Disabled, Internal and Callable
+ -- (access-to-)subprograms, on the other hand, can be safely but
+ -- explicitly converted to each other, because these strub modes
+ -- do not require signature changes; so it is possible to alter
+ -- the caller-side stack scrubbing semantics of the call (e.g. to
+ -- call a subprogram that isn't strub-callable from within a strub
+ -- context, or to prevent it from being called through an access
+ -- object) without any incompatibilities.
+
+ procedure Copy_Strub_Mode (Dest, Src : Entity_Id);
+ -- Copy the strub mode from Src to Dest, subprograms or subprogram
+ -- types. Dest is required to not have a strub mode already set.
+
+ function Explicit_Strub_Mode (Id : Entity_Id) return Strub_Mode;
+ -- Return the strub mode associated with Id, that should refer to
+ -- a subprogram, a data object, or a type.
+
+ function Strub_Pragma_P (Item : Node_Id) return Boolean;
+ -- Return True iff Item is a strub annotation, specifically, one
+ -- introduced by pragma Machine_Attribute (Entity, "strub"[, "mode"]).
+
+end Strub;
^ permalink raw reply [flat|nested] 6+ messages in thread
* [gcc(refs/users/aoliva/heads/testme)] Improve integration of strub with type systems
@ 2022-04-06 15:02 Alexandre Oliva
0 siblings, 0 replies; 6+ messages in thread
From: Alexandre Oliva @ 2022-04-06 15:02 UTC (permalink / raw)
To: gcc-cvs
https://gcc.gnu.org/g:070eb0d2fae5e12f4c795b7277149842e5965ced
commit 070eb0d2fae5e12f4c795b7277149842e5965ced
Author: Alexandre Oliva <oliva@adacore.com>
Date: Sat Oct 30 07:06:41 2021 -0300
Improve integration of strub with type systems
This is a patch that complements changes to front-end and back-end,
adjusting the build system to build a newly-added package, and
improving handling of the strub attribute to warn on composite types.
[changelog]
* gcc-interface/Make-lang.in: (GNAT_ADA_OBJS): Add
ada/strub.o.
* gcc-interface/utils.c (handle_strub_attribute): Simplify
check for pointer-to-function types. Warn when applied to
composite types.
TN: U611-048
Change-Id: I05a28cbe8186a33d810a9d2adadc0aa4905c5ddc
Diff:
---
gcc/ada/gcc-interface/Make-lang.in | 1 +
gcc/ada/gcc-interface/utils.cc | 20 +++++++++++++++++---
2 files changed, 18 insertions(+), 3 deletions(-)
diff --git a/gcc/ada/gcc-interface/Make-lang.in b/gcc/ada/gcc-interface/Make-lang.in
index 2af2ae76390..a8d8899d3c9 100644
--- a/gcc/ada/gcc-interface/Make-lang.in
+++ b/gcc/ada/gcc-interface/Make-lang.in
@@ -433,6 +433,7 @@ GNAT_ADA_OBJS = \
ada/sprint.o \
ada/stand.o \
ada/stringt.o \
+ ada/strub.o \
ada/style.o \
ada/styleg.o \
ada/stylesw.o \
diff --git a/gcc/ada/gcc-interface/utils.cc b/gcc/ada/gcc-interface/utils.cc
index a48fc6cdb2a..ecb7c3afdfe 100644
--- a/gcc/ada/gcc-interface/utils.cc
+++ b/gcc/ada/gcc-interface/utils.cc
@@ -6613,9 +6613,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))
@@ -6657,6 +6655,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
^ permalink raw reply [flat|nested] 6+ messages in thread
* [gcc(refs/users/aoliva/heads/testme)] improve integration of strub with type systems
@ 2022-04-06 15:02 Alexandre Oliva
0 siblings, 0 replies; 6+ messages in thread
From: Alexandre Oliva @ 2022-04-06 15:02 UTC (permalink / raw)
To: gcc-cvs
https://gcc.gnu.org/g:13c7b343004d1dbbf1198352738adeaad68e3662
commit 13c7b343004d1dbbf1198352738adeaad68e3662
Author: Alexandre Oliva <oliva@adacore.com>
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.cc | 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.cc b/gcc/c-family/c-attribs.cc
index 3e3a6958b23..775e25ae89a 100644
--- a/gcc/c-family/c-attribs.cc
+++ b/gcc/c-family/c-attribs.cc
@@ -1323,9 +1323,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))
@@ -1367,6 +1365,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-%<strub%> call in %<strub%> 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 %<always_inline%> %<strub%> %qD"
" in non-%<strub%> 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-%<strub%> %qD in %<strub%> context %qD",
e->callee->decl, node->decl);
+ else
+ error_at (gimple_location (e->call_stmt),
+ "calling %qD using non-%<strub%> type %qT"
+ " in %<strub%> 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;
^ permalink raw reply [flat|nested] 6+ messages in thread
* [gcc(refs/users/aoliva/heads/testme)] Improve integration of strub with type systems
@ 2021-11-16 3:48 Alexandre Oliva
0 siblings, 0 replies; 6+ messages in thread
From: Alexandre Oliva @ 2021-11-16 3:48 UTC (permalink / raw)
To: gcc-cvs
https://gcc.gnu.org/g:0daa3a3e258f18e4d24b2f5f2729f4e37fef87f7
commit 0daa3a3e258f18e4d24b2f5f2729f4e37fef87f7
Author: Alexandre Oliva <oliva@adacore.com>
Date: Sat Oct 30 07:09:37 2021 -0300
Improve integration of strub with type systems
This patch brings various improvements to the integration of strub
modes into the Ada type system. Strub modes for subprograms are
promoted to subprogram types when applied to access-to-subprogram
objects and types, and promoted from subprograms to access types'
designated types. Matching strub modes are required for renaming,
overriding, interface implementation, and compatible strub modes are
required for conversions.
A complementary patch for the GCC interface introduces matching build
system changes, and warnings when strub modes are applied to composite
data objects or their types, and another complementary patch for GCC
does the same for C-family languages.
The GCC patch also fixes a strub callability error affecting
type-converted direct calls, and several tests to exercise the
newly-added features, and reverts strub annotations from public
subprograms, that would have caused their renamings to be rejected.
[changelog]
* MANIFEST.GNAT: Added...
* strub.adb, strub.ads: New files.
* exp_attr.adb (Access_Cases): Copy strub mode to subprogram type.
* exp_disp.adb (Expand_Dispatching_Call): Likewise.
* freeze.adb (Check_Inherited_Conditions): Check that strub modes
match overridden subprograms and interfaces.
(Freeze_All): Renaming declarations too.
* sem_attr.adb (Resolve_Attribute): Reject 'Access to
strub-annotated data object.
* sem_ch3.adb (Derive_Subprogram): Copy strub mode to
inherited subprogram.
* sem_prag.adb (Analyze_Pragma): Propagate Strub Machine_Attribute
from access-to-subprogram to subprogram type when required,
but not from access-to-data to data type. Mark the entity that
got the pragma as having a gigi rep item.
* sem_res.adb (Resolve): Reject implicit conversions that
would change strub modes.
(Resolve_Type_Conversions): Reject checked conversions
between incompatible strub modes.
* doc/gnat_rm/security_hardening_features.rst: Update.
* libgnat/a-except.ads (Raise_Exception): Revert strub-callable
annotation in public subprogram.
* libgnat/s-arit128.ads (Multiply_With_Ovflo_Check128): Likewise.
* libgnat/s-arit64.ads (Multiply_With_Ovflo_Check64): Likewise.
* libgnat/a-secsta.ads (SS_Allocate): Likewise.
(SS_Mark, SS_Release): Likewise.
TN: U611-048
Change-Id: I69191dec2186af26de1557b688c42e52bd986662
Diff:
---
.../doc/gnat_rm/security_hardening_features.rst | 60 +++-
gcc/ada/exp_attr.adb | 2 +
gcc/ada/exp_disp.adb | 2 +
gcc/ada/freeze.adb | 75 ++++-
gcc/ada/libgnat/a-except.ads | 7 +-
gcc/ada/libgnat/s-arit128.ads | 7 -
gcc/ada/libgnat/s-arit64.ads | 7 -
gcc/ada/libgnat/s-secsta.ads | 5 -
gcc/ada/sem_attr.adb | 22 ++
gcc/ada/sem_ch3.adb | 3 +
gcc/ada/sem_prag.adb | 27 +-
gcc/ada/sem_res.adb | 43 ++-
gcc/ada/strub.adb | 301 +++++++++++++++++++++
gcc/ada/strub.ads | 115 ++++++++
14 files changed, 630 insertions(+), 46 deletions(-)
diff --git a/gcc/ada/doc/gnat_rm/security_hardening_features.rst b/gcc/ada/doc/gnat_rm/security_hardening_features.rst
index cf76938d91d..bdcfd99ad86 100644
--- a/gcc/ada/doc/gnat_rm/security_hardening_features.rst
+++ b/gcc/ada/doc/gnat_rm/security_hardening_features.rst
@@ -73,20 +73,52 @@ Note that Ada secondary stacks are not scrubbed. The restriction
``No_Secondary_Stack`` avoids their use, and thus their accidental
preservation of data that should be scrubbed.
-Also note that the machine attribute is not integrated in the Ada type
-system. Though it may modify subprogram and variable interfaces, it
-is not fully reflected in Ada types, ``Access`` attributes, renaming
-and overriding. Every access type, renaming, and overriding and
-overridden dispatching operations that may refer to an entity with an
-attribute-modified interface must be annotated with the same
-interface-modifying attribute, or with an interface-compatible one.
-
-Even then, the pragma is currently only functional when applied to
-subprograms and scalar variables; other uses, such as directly on
-types and subtypes, may be silently ignored. Specifically, it is not
-currently recommended to rely on any effects this pragma might be
-expected to have when calling subprograms through access-to-subprogram
-variables.
+Attributes ``Access`` and ``Unconstrained_Access`` of variables and
+constants with ``strub`` enabled require types with ``strub`` enabled;
+there is no way to express an access-to-strub type otherwise.
+``Unchecked_Access`` bypasses this constraint, but the resulting
+access type designates a non-strub type.
+
+.. code-block:: ada
+
+ VI : Integer;
+ XsVI : access Integer := VI'Access; -- Error.
+ UXsVI : access Integer := VI'Unchecked_Access; -- OK,
+ -- UXsVI.all does not enable strub in the enclosing subprogram.
+
+ type Strub_Int is new Integer;
+ pragma Machine_Attribute (Strub_Int, "strub");
+ VSI : Strub_Int;
+ XsVSI : access Strub_Int := VSI'Access; -- OK.
+ -- XsVSI.all enables strub in the enclosing subprogram.
+
+
+Every access-to-subprogram type, renaming, and overriding and
+overridden dispatching operations that may refer to a subprogram with
+an attribute-modified interface must be annotated with the same
+interface-modifying attribute. Access-to-subprogram types can be
+explicitly converted to different strub modes, as long as they are
+interface-compatible (i.e., adding or removing ``at-calls`` is not
+allowed). For example, a ``strub``-``disabled`` subprogram can be
+turned ``callable`` through such an explicit conversion:
+
+.. code-block:: ada
+
+ type TBar is access procedure;
+
+ type TBar_Callable is access procedure;
+ pragma Machine_Attribute (TBar_Callable, "strub", "callable");
+
+ Bar_Callable_Ptr : constant TBar_Callable
+ := TBar_Callable (TBar'(Bar'Access));
+
+ procedure Bar_Callable renames Bar_Callable_Ptr.all;
+ pragma Machine_Attribute (Bar_Callable, "strub", "callable");
+
+Note that the renaming declaration is expanded to a full subprogram
+body, it won't be just an alias. Only if it is inlined will it be as
+efficient as a call by dereferencing the access-to-subprogram constant
+Bar_Callable_Ptr.
.. Hardened Conditionals:
diff --git a/gcc/ada/exp_attr.adb b/gcc/ada/exp_attr.adb
index 19d8286a759..33ac8bde635 100644
--- a/gcc/ada/exp_attr.adb
+++ b/gcc/ada/exp_attr.adb
@@ -67,6 +67,7 @@ with Sinfo.Utils; use Sinfo.Utils;
with Snames; use Snames;
with Stand; use Stand;
with Stringt; use Stringt;
+with Strub; use Strub;
with Tbuild; use Tbuild;
with Ttypes; use Ttypes;
with Uintp; use Uintp;
@@ -2162,6 +2163,7 @@ package body Exp_Attr is
begin
Subp_Typ := Create_Itype (E_Subprogram_Type, N);
+ Copy_Strub_Mode (Subp_Typ, Subp);
Set_Etype (Subp_Typ, Etype (Subp));
Set_Returns_By_Ref (Subp_Typ, Returns_By_Ref (Subp));
diff --git a/gcc/ada/exp_disp.adb b/gcc/ada/exp_disp.adb
index 88f11b28dd5..de2ba7a562b 100644
--- a/gcc/ada/exp_disp.adb
+++ b/gcc/ada/exp_disp.adb
@@ -66,6 +66,7 @@ with Sinfo.Utils; use Sinfo.Utils;
with Snames; use Snames;
with Stand; use Stand;
with Stringt; use Stringt;
+with Strub; use Strub;
with SCIL_LL; use SCIL_LL;
with Tbuild; use Tbuild;
@@ -846,6 +847,7 @@ package body Exp_Disp is
end if;
Subp_Typ := Create_Itype (E_Subprogram_Type, Call_Node);
+ Copy_Strub_Mode (Subp_Typ, Subp);
Subp_Ptr_Typ := Create_Itype (E_Access_Subprogram_Type, Call_Node);
Set_Etype (Subp_Typ, Res_Typ);
Set_Returns_By_Ref (Subp_Typ, Returns_By_Ref (Subp));
diff --git a/gcc/ada/freeze.adb b/gcc/ada/freeze.adb
index 97a51db9d4b..726e20073fc 100644
--- a/gcc/ada/freeze.adb
+++ b/gcc/ada/freeze.adb
@@ -69,6 +69,7 @@ with Sinfo.Utils; use Sinfo.Utils;
with Snames; use Snames;
with Stand; use Stand;
with Stringt; use Stringt;
+with Strub; use Strub;
with Targparm; use Targparm;
with Tbuild; use Tbuild;
with Ttypes; use Ttypes;
@@ -1790,6 +1791,10 @@ package body Freeze is
return Result;
end Needs_Wrapper;
+ Ifaces_List : Elist_Id;
+ Ifaces_Listed : Boolean := False;
+ -- Cache the list of interface operations inherited by R
+
-- Start of processing for Check_Inherited_Conditions
begin
@@ -1823,11 +1828,10 @@ package body Freeze is
while Present (Op_Node) loop
Prim := Node (Op_Node);
- if Present (Overridden_Operation (Prim))
+ Par_Prim := Overridden_Operation (Prim);
+ if Present (Par_Prim)
and then Comes_From_Source (Prim)
then
- Par_Prim := Overridden_Operation (Prim);
-
-- When the primitive is an LSP wrapper we climb to the parent
-- primitive that has the inherited contract.
@@ -1837,6 +1841,11 @@ package body Freeze is
Par_Prim := LSP_Subprogram (Par_Prim);
end if;
+ -- Check that overrider and overridden operations have
+ -- the same strub mode.
+
+ Check_Same_Strub_Mode (Prim, Par_Prim);
+
-- Analyze the contract items of the overridden operation, before
-- they are rewritten as pragmas.
@@ -1852,6 +1861,54 @@ package body Freeze is
end if;
end if;
+ -- Go over operations inherited from interfaces and check
+ -- them for strub mode compatibility as well.
+
+ if Has_Interfaces (R)
+ and then Is_Dispatching_Operation (Prim)
+ and then Find_Dispatching_Type (Prim) = R
+ then
+ declare
+ Elmt : Elmt_Id;
+ Iface_Elmt : Elmt_Id;
+ Iface : Entity_Id;
+ Iface_Prim : Entity_Id;
+
+ begin
+ -- Collect the interfaces only once. We haven't
+ -- finished freezing yet, so we can't use the faster
+ -- search from Sem_Disp.Covered_Interface_Primitives.
+
+ if not Ifaces_Listed then
+ Collect_Interfaces (R, Ifaces_List);
+ Ifaces_Listed := True;
+ end if;
+
+ Iface_Elmt := First_Elmt (Ifaces_List);
+ while Present (Iface_Elmt) loop
+ Iface := Node (Iface_Elmt);
+
+ Elmt := First_Elmt (Primitive_Operations (Iface));
+ while Present (Elmt) loop
+ Iface_Prim := Node (Elmt);
+
+ if Iface_Prim /= Par_Prim
+ and then Chars (Iface_Prim) = Chars (Prim)
+ and then Comes_From_Source (Iface_Prim)
+ and then (Is_Interface_Conformant
+ (R, Iface_Prim, Prim))
+ then
+ Check_Same_Strub_Mode (Prim, Iface_Prim);
+ end if;
+
+ Next_Elmt (Elmt);
+ end loop;
+
+ Next_Elmt (Iface_Elmt);
+ end loop;
+ end;
+ end if;
+
Next_Elmt (Op_Node);
end loop;
@@ -2504,6 +2561,18 @@ package body Freeze is
Process_Default_Expressions (E, After);
end if;
+ -- Check subprogram renamings for the same strub-mode.
+ -- Avoid rechecking dispatching operations, that's taken
+ -- care of in Check_Inherited_Conditions, that covers
+ -- inherited interface operations.
+
+ Item := Alias (E);
+ if Present (Item)
+ and then not Is_Dispatching_Operation (E)
+ then
+ Check_Same_Strub_Mode (E, Item);
+ end if;
+
if not Has_Completion (E) then
Decl := Unit_Declaration_Node (E);
diff --git a/gcc/ada/libgnat/a-except.ads b/gcc/ada/libgnat/a-except.ads
index 1608e79eee4..b6c8bb579d4 100644
--- a/gcc/ada/libgnat/a-except.ads
+++ b/gcc/ada/libgnat/a-except.ads
@@ -184,14 +184,9 @@ private
-- Raise_Exception_Always if it can determine this is the case. The Export
-- allows this routine to be accessed from Pure units.
- -- Make these callable from strub contexts.
pragma Machine_Attribute (Raise_Exception_Always,
"strub", "callable");
- pragma Machine_Attribute (Raise_Exception,
- "strub", "callable");
- -- This property should arguably be visible to callers, but let's
- -- keep it private for now. In practice, it doesn't matter, since
- -- it's only checked in the back end.
+ -- Make it callable from strub contexts
procedure Raise_From_Controlled_Operation (X : Exception_Occurrence);
pragma No_Return (Raise_From_Controlled_Operation);
diff --git a/gcc/ada/libgnat/s-arit128.ads b/gcc/ada/libgnat/s-arit128.ads
index fa6fedcbc11..6213cfb569a 100644
--- a/gcc/ada/libgnat/s-arit128.ads
+++ b/gcc/ada/libgnat/s-arit128.ads
@@ -81,11 +81,4 @@ package System.Arith_128 is
-- then Q is the rounded quotient. The remainder R is not affected by the
-- setting of the Round flag.
-private
- -- Make it callable from strub contexts.
- -- There is a matching setting in trans.c,
- -- for calls issued by Gigi.
- pragma Machine_Attribute (Multiply_With_Ovflo_Check128,
- "strub", "callable");
-
end System.Arith_128;
diff --git a/gcc/ada/libgnat/s-arit64.ads b/gcc/ada/libgnat/s-arit64.ads
index ca71a2c4074..fbfd0f65468 100644
--- a/gcc/ada/libgnat/s-arit64.ads
+++ b/gcc/ada/libgnat/s-arit64.ads
@@ -180,11 +180,4 @@ is
Round : Boolean) renames Double_Divide64;
-- Renamed procedure to preserve compatibility with earlier versions
-private
- -- Make it callable from strub contexts.
- -- There is a matching setting in trans.c,
- -- for calls issued by Gigi.
- pragma Machine_Attribute (Multiply_With_Ovflo_Check64,
- "strub", "callable");
-
end System.Arith_64;
diff --git a/gcc/ada/libgnat/s-secsta.ads b/gcc/ada/libgnat/s-secsta.ads
index 6648c233d4c..7d6b1b9a90e 100644
--- a/gcc/ada/libgnat/s-secsta.ads
+++ b/gcc/ada/libgnat/s-secsta.ads
@@ -440,9 +440,4 @@ private
function Get_Stack_Info (Stack : SS_Stack_Ptr) return Stack_Info;
-- Obtain the information attributes of secondary stack Stack
- pragma Machine_Attribute (SS_Allocate, "strub", "callable");
- pragma Machine_Attribute (SS_Mark, "strub", "callable");
- pragma Machine_Attribute (SS_Release, "strub", "callable");
- -- Enable these to be called from within strub contexts.
-
end System.Secondary_Stack;
diff --git a/gcc/ada/sem_attr.adb b/gcc/ada/sem_attr.adb
index e1ee09e5500..2575ddfe86d 100644
--- a/gcc/ada/sem_attr.adb
+++ b/gcc/ada/sem_attr.adb
@@ -74,6 +74,7 @@ with Sinfo.Utils; use Sinfo.Utils;
with Sinput; use Sinput;
with System;
with Stringt; use Stringt;
+with Strub; use Strub;
with Style;
with Stylesw; use Stylesw;
with Targparm; use Targparm;
@@ -11294,6 +11295,27 @@ package body Sem_Attr is
Resolve (P);
end if;
+ -- Refuse to compute access to variables and constants when that
+ -- would drop the strub mode associated with them, unless they're
+ -- unchecked conversions. We don't have to do this when the types
+ -- of the data objects are annotated: then the access type
+ -- designates the annotated type, and there's no loss. Only when
+ -- the variable is annotated directly that the pragma gets
+ -- attached to the variable, rather than to its type, and then,
+ -- expressing an access-to-annotated-type type to hold the 'Access
+ -- result is not possible without resorting to that very annotated
+ -- type.
+
+ if Attr_Id /= Attribute_Unchecked_Access
+ and then Comes_From_Source (N)
+ and then Is_Entity_Name (P)
+ and then Explicit_Strub_Mode (Entity (P)) = Enabled
+ and then
+ Explicit_Strub_Mode (Designated_Type (Btyp)) = Unspecified
+ then
+ Error_Msg_F ("target access type drops `strub` mode from &", P);
+ end if;
+
-- X'Access is illegal if X denotes a constant and the access type
-- is access-to-variable. Same for 'Unchecked_Access. The rule
-- does not apply to 'Unrestricted_Access. If the reference is a
diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb
index b6c05f75b55..569e0199dde 100644
--- a/gcc/ada/sem_ch3.adb
+++ b/gcc/ada/sem_ch3.adb
@@ -79,6 +79,7 @@ with Sinfo.Nodes; use Sinfo.Nodes;
with Sinfo.Utils; use Sinfo.Utils;
with Sinput; use Sinput;
with Snames; use Snames;
+with Strub; use Strub;
with Targparm; use Targparm;
with Tbuild; use Tbuild;
with Ttypes; use Ttypes;
@@ -16065,6 +16066,8 @@ package body Sem_Ch3 is
Set_Alias (New_Subp, Actual_Subp);
end if;
+ Copy_Strub_Mode (New_Subp, Alias (New_Subp));
+
-- Derived subprograms of a tagged type must inherit the convention
-- of the parent subprogram (a requirement of AI-117). Derived
-- subprograms of untagged types simply get convention Ada by default.
diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb
index 3e5de076ee6..c3ea16df54d 100644
--- a/gcc/ada/sem_prag.adb
+++ b/gcc/ada/sem_prag.adb
@@ -84,6 +84,7 @@ with Sinfo.Utils; use Sinfo.Utils;
with Sinfo.CN; use Sinfo.CN;
with Sinput; use Sinput;
with Stringt; use Stringt;
+with Strub; use Strub;
with Stylesw; use Stylesw;
with Table;
with Targparm; use Targparm;
@@ -19467,7 +19468,29 @@ package body Sem_Prag is
Check_Arg_Is_OK_Static_Expression (Arg2, Standard_String);
Def_Id := Entity (Get_Pragma_Arg (Arg1));
- if Is_Access_Type (Def_Id) then
+ -- Apply the pragma to the designated type, rather than to the
+ -- access type, unless it's a strub annotation. We wish to enable
+ -- objects of access type, as well as access types themselves, to
+ -- be annotated, so that reading the access objects (as oposed to
+ -- the designated data) automatically enables stack
+ -- scrubbing. That said, as in the attribute handler that
+ -- processes the pragma turned into a compiler attribute, a strub
+ -- annotation that must be associated with a subprogram type (for
+ -- holding an explicit strub mode), when applied to an
+ -- access-to-subprogram, gets promoted to the subprogram type. We
+ -- might be tempted to leave it alone here, since the C attribute
+ -- handler will adjust it, but then GNAT would convert the
+ -- annotated subprogram types to naked ones before using them,
+ -- cancelling out their intended effects.
+
+ if Is_Access_Type (Def_Id)
+ and then (not Strub_Pragma_P (N)
+ or else
+ (Present (Arg3)
+ and then
+ Ekind (Designated_Type
+ (Def_Id)) = E_Subprogram_Type))
+ then
Def_Id := Designated_Type (Def_Id);
end if;
@@ -19485,7 +19508,7 @@ package body Sem_Prag is
if Rep_Item_Too_Late (Def_Id, N) then
return;
else
- Set_Has_Gigi_Rep_Item (Entity (Get_Pragma_Arg (Arg1)));
+ Set_Has_Gigi_Rep_Item (Def_Id);
end if;
end Machine_Attribute;
diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb
index 09a76f19930..ac262facfec 100644
--- a/gcc/ada/sem_res.adb
+++ b/gcc/ada/sem_res.adb
@@ -82,6 +82,7 @@ with Sinfo.CN; use Sinfo.CN;
with Snames; use Snames;
with Stand; use Stand;
with Stringt; use Stringt;
+with Strub; use Strub;
with Style; use Style;
with Targparm; use Targparm;
with Tbuild; use Tbuild;
@@ -3179,6 +3180,27 @@ package body Sem_Res is
-- Only one interpretation
else
+ -- Prevent implicit conversions between access-to-subprogram types
+ -- with different strub modes. Explicit conversions are acceptable in
+ -- some circumstances. We don't have to be concerned about data or
+ -- access-to-data types. Conversions between data types can safely
+ -- drop or add strub attributes from types, because strub effects are
+ -- associated with the locations rather than values. E.g., converting
+ -- a hypothetical Strub_Integer variable to Integer would load the
+ -- value from the variable, enabling stack scrabbing for the
+ -- enclosing subprogram, and then convert the value to Integer. As
+ -- for conversions between access-to-data types, that's no different
+ -- from any other case of type punning.
+
+ if Is_Access_Type (Typ)
+ and then Ekind (Designated_Type (Typ)) = E_Subprogram_Type
+ and then Is_Access_Type (Expr_Type)
+ and then Ekind (Designated_Type (Expr_Type)) = E_Subprogram_Type
+ then
+ Check_Same_Strub_Mode
+ (Designated_Type (Typ), Designated_Type (Expr_Type));
+ end if;
+
-- In Ada 2005, if we have something like "X : T := 2 + 2;", where
-- the "+" on T is abstract, and the operands are of universal type,
-- the above code will have (incorrectly) resolved the "+" to the
@@ -14154,7 +14176,15 @@ package body Sem_Res is
end;
end if;
- return True;
+ -- Check that the strub modes are compatible.
+ -- We wish to reject explicit conversions only for
+ -- incompatible modes.
+
+ return Conversion_Check
+ (Compatible_Strub_Modes
+ (Designated_Type (Target_Type),
+ Designated_Type (Opnd_Type)),
+ "incompatible `strub` modes");
-- Remote access to subprogram types
@@ -14180,7 +14210,16 @@ package body Sem_Res is
Designated_Type (Corresponding_Remote_Type (Opnd_Type)),
Err_Loc =>
N);
- return True;
+
+ -- Check that the strub modes are compatible.
+ -- We wish to reject explicit conversions only for
+ -- incompatible modes.
+
+ return Conversion_Check
+ (Compatible_Strub_Modes
+ (Designated_Type (Target_Type),
+ Designated_Type (Opnd_Type)),
+ "incompatible `strub` modes");
-- If it was legal in the generic, it's legal in the instance
diff --git a/gcc/ada/strub.adb b/gcc/ada/strub.adb
new file mode 100644
index 00000000000..84146580b02
--- /dev/null
+++ b/gcc/ada/strub.adb
@@ -0,0 +1,301 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- S T R U B --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 2021, Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 3, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNAT; see file COPYING3. If not, go to --
+-- http://www.gnu.org/licenses for a complete copy of the license. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- Package containing utility procedures related to Stack Scrubbing
+
+with Atree; use Atree;
+with Einfo; use Einfo;
+with Einfo.Entities; use Einfo.Entities;
+with Errout; use Errout;
+with Namet; use Namet;
+with Nlists; use Nlists;
+with Sem_Eval; use Sem_Eval;
+with Sinfo; use Sinfo;
+with Sinfo.Nodes; use Sinfo.Nodes;
+with Sinfo.Utils; use Sinfo.Utils;
+with Snames; use Snames;
+with Stringt; use Stringt;
+
+package body Strub is
+ -----------------------
+ -- Local Subprograms --
+ -----------------------
+
+ function Find_Explicit_Strub_Pragma (Id : Entity_Id) return Node_Id;
+ -- Return a pragma Machine_Attribute (Id, "strub"[, "mode"]) node
+ -- if Id has one.
+
+ function Strub_Pragma_Arg (Item : Node_Id) return Node_Id is
+ (Get_Pragma_Arg
+ (Next (Next (First (Pragma_Argument_Associations (Item))))));
+ -- Return the pragma argument holding the strub mode associated
+ -- with Item, a subprogram, variable, constant, or type. Bear in
+ -- mind that strub pragmas with an explicit strub mode argument,
+ -- naming access-to-subprogram types, are applied to the
+ -- designated subprogram type.
+
+ function Strub_Pragma_Arg_To_String (Item : Node_Id) return String is
+ (To_String (Strval (Expr_Value_S (Item))));
+ -- Extract and return as a String the strub mode held in a node
+ -- returned by Strub_Pragma_Arg.
+
+ function Strub_Pragma_Mode
+ (Id : Entity_Id;
+ Item : Node_Id) return Strub_Mode;
+ -- Return the strub mode associated with Item expressed in Id.
+ -- Strub_Pragma_P (Id) must hold.
+
+ ---------------------------
+ -- Check_Same_Strub_Mode --
+ ---------------------------
+
+ procedure Check_Same_Strub_Mode
+ (Dest, Src : Entity_Id;
+ Report : Boolean := True)
+ is
+ Src_Strub_Mode : constant Strub_Mode := Explicit_Strub_Mode (Src);
+ Dest_Strub_Mode : constant Strub_Mode := Explicit_Strub_Mode (Dest);
+
+ begin
+ if Dest_Strub_Mode = Src_Strub_Mode then
+ return;
+ end if;
+
+ -- Internal is not part of the interface, it's an *internal*
+ -- implementation detail, so consider it equivalent to unspecified here.
+ -- ??? -fstrub=relaxed|strict makes them interface-equivalent to
+ -- Callable or Disabled, respectively, but we don't look at that flag in
+ -- the front-end, and it seems undesirable for that flag to affect
+ -- whether specifications are conformant. Maybe there should be some
+ -- means to specify Callable or Disabled along with Internal?
+
+ if Dest_Strub_Mode in Unspecified | Internal
+ and then Src_Strub_Mode in Unspecified | Internal
+ then
+ return;
+ end if;
+
+ if not Report then
+ return;
+ end if;
+
+ if Src_Strub_Mode /= Unspecified then
+ Error_Msg_Sloc := Sloc (Find_Explicit_Strub_Pragma (Src));
+ else
+ Error_Msg_Sloc := Sloc (Src);
+ end if;
+ Error_Msg_Node_2 := Src;
+ Error_Msg_NE ("& requires the same `strub` mode as &#",
+ (if Dest_Strub_Mode /= Unspecified
+ then Find_Explicit_Strub_Pragma (Dest)
+ else Dest),
+ Dest);
+ end Check_Same_Strub_Mode;
+
+ ----------------------------
+ -- Compatible_Strub_Modes --
+ ----------------------------
+
+ function Compatible_Strub_Modes
+ (Dest, Src : Entity_Id) return Boolean
+ is
+ Src_Strub_Mode : constant Strub_Mode := Explicit_Strub_Mode (Src);
+ Dest_Strub_Mode : constant Strub_Mode := Explicit_Strub_Mode (Dest);
+
+ begin
+ return Src_Strub_Mode = Dest_Strub_Mode
+ or else At_Calls not in Src_Strub_Mode | Dest_Strub_Mode;
+ end Compatible_Strub_Modes;
+
+ ---------------------
+ -- Copy_Strub_Mode --
+ ---------------------
+
+ procedure Copy_Strub_Mode (Dest, Src : Entity_Id) is
+ Strub : Node_Id := Find_Explicit_Strub_Pragma (Src);
+ Src_Strub_Mode : constant Strub_Mode := Strub_Pragma_Mode (Src, Strub);
+
+ begin
+ pragma Assert (Explicit_Strub_Mode (Dest) = Unspecified);
+
+ -- Refrain from copying Internal to subprogram types.
+ -- It affects code generation for the subprogram,
+ -- but it has no effect on its type or interface.
+
+ if Src_Strub_Mode = Unspecified
+ or else (Ekind (Dest) = E_Subprogram_Type
+ and then Src_Strub_Mode = Internal)
+ then
+ return;
+ end if;
+
+ Strub := New_Copy (Strub);
+ Set_Next_Rep_Item (Strub, First_Rep_Item (Dest));
+ Set_First_Rep_Item (Dest, Strub);
+ Set_Has_Gigi_Rep_Item (Dest);
+ end Copy_Strub_Mode;
+
+ -------------------------
+ -- Explicit_Strub_Mode --
+ -------------------------
+
+ function Explicit_Strub_Mode (Id : Entity_Id) return Strub_Mode is
+ Item : constant Node_Id := Find_Explicit_Strub_Pragma (Id);
+
+ begin
+ return Strub_Pragma_Mode (Id, Item);
+ end Explicit_Strub_Mode;
+
+ --------------------------------
+ -- Find_Explicit_Strub_Pragma --
+ --------------------------------
+
+ function Find_Explicit_Strub_Pragma (Id : Entity_Id) return Node_Id is
+ Item : Node_Id;
+
+ begin
+ if not Has_Gigi_Rep_Item (Id) then
+ return Empty;
+ end if;
+
+ Item := First_Rep_Item (Id);
+ while Present (Item) loop
+ if Strub_Pragma_P (Item) then
+ return Item;
+ end if;
+ Item := Next_Rep_Item (Item);
+ end loop;
+
+ return Empty;
+ end Find_Explicit_Strub_Pragma;
+
+ -----------------------
+ -- Strub_Pragma_Mode --
+ -----------------------
+
+ function Strub_Pragma_Mode
+ (Id : Entity_Id;
+ Item : Node_Id) return Strub_Mode
+ is
+ Arg : Node_Id := Empty;
+
+ begin
+ -- ??? Enumeration literals, despite being conceptually functions, have
+ -- neither bodies nor stack frames, and it's not clear whether it would
+ -- make more sense to treat them as subprograms or as constants, but
+ -- they can be renamed as functions. Should we require all literals of
+ -- a type to have the same strub mode? Rule out their annotation?
+
+ if Ekind (Id) in E_Subprogram_Type
+ | Overloadable_Kind
+ | Generic_Subprogram_Kind
+ then
+ if Item = Empty then
+ return Unspecified;
+ end if;
+
+ Arg := Strub_Pragma_Arg (Item);
+ if Arg = Empty then
+ return At_Calls;
+ end if;
+
+ declare
+ Str : constant String := Strub_Pragma_Arg_To_String (Arg);
+ begin
+ if Str'Length /= 8 then
+ return Unspecified;
+ end if;
+
+ case Str (Str'First) is
+ when 'a' =>
+ if Str = "at-calls" then
+ return At_Calls;
+ end if;
+
+ when 'i' =>
+ if Str = "internal" then
+ return Internal;
+ end if;
+
+ when 'c' =>
+ if Str = "callable" then
+ return Callable;
+ end if;
+
+ when 'd' =>
+ if Str = "disabled" then
+ return Disabled;
+ end if;
+
+ when others =>
+ null;
+ end case;
+ return Unspecified;
+ end;
+
+ -- Access-to-subprogram types and variables can be treated just like
+ -- other access types, because the pragma logic has already promoted to
+ -- subprogram types any annotations applicable to them.
+
+ elsif Ekind (Id) in Type_Kind -- except E_Subprogram_Type, covered above
+ | Scalar_Kind
+ | Object_Kind
+ | Named_Kind
+ then
+ if Item = Empty then
+ return Unspecified;
+ end if;
+
+ Arg := Strub_Pragma_Arg (Item);
+ if Arg /= Empty then
+ -- A strub parameter is not applicable to variables,
+ -- and will be ignored.
+
+ return Unspecified;
+ end if;
+
+ return Enabled;
+
+ else
+ pragma Assert (Item = Empty);
+ return Not_Applicable;
+ end if;
+ end Strub_Pragma_Mode;
+
+ --------------------
+ -- Strub_Pragma_P --
+ --------------------
+
+ function Strub_Pragma_P
+ (Item : Node_Id) return Boolean is
+ (Nkind (Item) = N_Pragma
+ and then Pragma_Name (Item) = Name_Machine_Attribute
+ and then
+ Strub_Pragma_Arg_To_String
+ (Get_Pragma_Arg
+ (Next (First (Pragma_Argument_Associations (Item)))))
+ = "strub");
+
+end Strub;
diff --git a/gcc/ada/strub.ads b/gcc/ada/strub.ads
new file mode 100644
index 00000000000..2753dd0fa5b
--- /dev/null
+++ b/gcc/ada/strub.ads
@@ -0,0 +1,115 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- S T R U B --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 2021, Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 3, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNAT; see file COPYING3. If not, go to --
+-- http://www.gnu.org/licenses for a complete copy of the license. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- Package containing utility procedures related to Stack Scrubbing
+
+with Types; use Types;
+
+package Strub is
+ type Strub_Mode is
+ (Disabled, -- Subprogram cannot be called from strub contexts
+ At_Calls, -- Subprogram strubbed by caller
+ Internal, -- Subprogram strubbed by wrapper
+ Callable, -- Subprogram safe to call despite no strub
+ Unspecified, -- Subprogram or data without strub annotation
+ Enabled, -- Data (variable or constant) that enables strub
+ Not_Applicable); -- Entities that are not strub-capable
+ -- This is the type that expresses decoded strub annotations
+
+ -- We compare strub modes in the following circumstances:
+
+ -- * subprogram definition vs specification
+ -- * overriding vs overridden dispatch subprograms
+ -- * implementation vs interface dispatch subprogram
+ -- * renaming vs renamed subprogram
+ -- * type resolution
+ -- * explicit conversions
+
+ -- Explicit conversions can convert between strub modes other than
+ -- at-calls (see Compatible_Strub_Modes), but for the other cases
+ -- above, we insist on identity of the strub modes (see
+ -- Check_Same_Strub_Mode). Anything else would be
+ -- troublesome.
+
+ -- E.g., overriding a callable subprogram with a strub-disabled
+ -- implementation would enable a subprogram that's unsafe to call
+ -- in strub contexts to be called through a dispatching
+ -- interface. An explicitly strub-disabled subprogram shall not be
+ -- called from strub contexts, and a callable overriding
+ -- subprogram would still seem not-callable, so accepting
+ -- different modes would be surprising.
+
+ -- We could relax the requirement for overriders from equality to
+ -- compatibility, with the understanding that the dispatching ABI
+ -- is what prevails. For renaming, however, if we don't require
+ -- equality, it would have to encompass an implicit conversion.
+
+ procedure Check_Same_Strub_Mode
+ (Dest, Src : Entity_Id;
+ Report : Boolean := True);
+ -- Check whether Dest and Src are subprograms or subprogram types
+ -- annotated (or not) with the same strub mode. If Report is
+ -- requested, and the strub modes are not equivalent, an error
+ -- message is issued. Unspecified and Internal are considered
+ -- equivalent, because Internal is an internal implementation
+ -- detail. Unspecified decays to Disabled or Callable depending on
+ -- -fstrub=(strict|relaxed), but this procedure does not take this
+ -- decay into account, which avoids turning strub-equivalent
+ -- declarations into incompatible ones at command-line changes.
+
+ function Compatible_Strub_Modes
+ (Dest, Src : Entity_Id) return Boolean;
+ -- Return True if Dest and Src are subprograms or subprogram types
+ -- annotated (or not) with ABI-compatible strub modes. At-calls is
+ -- incompatible to other strub modes, because the back end
+ -- internally modifies the signature of such subprograms, adding
+ -- hidden parameters. Calling a subprogram through an
+ -- access-to-subprogram object converted between strub-at-calls
+ -- and other strub modes should be deemed equivalent to
+ -- dereferencing an uninitialized access-to-data object, though
+ -- one-way conversions might seem to work in some circumstances.
+ --
+ -- Unspecified, Disabled, Internal and Callable
+ -- (access-to-)subprograms, on the other hand, can be safely but
+ -- explicitly converted to each other, because these strub modes
+ -- do not require signature changes; so it is possible to alter
+ -- the caller-side stack scrubbing semantics of the call (e.g. to
+ -- call a subprogram that isn't strub-callable from within a strub
+ -- context, or to prevent it from being called through an access
+ -- object) without any incompatibilities.
+
+ procedure Copy_Strub_Mode (Dest, Src : Entity_Id);
+ -- Copy the strub mode from Src to Dest, subprograms or subprogram
+ -- types. Dest is required to not have a strub mode already set.
+
+ function Explicit_Strub_Mode (Id : Entity_Id) return Strub_Mode;
+ -- Return the strub mode associated with Id, that should refer to
+ -- a subprogram, a data object, or a type.
+
+ function Strub_Pragma_P (Item : Node_Id) return Boolean;
+ -- Return True iff Item is a strub annotation, specifically, one
+ -- introduced by pragma Machine_Attribute (Entity, "strub"[, "mode"]).
+
+end Strub;
^ permalink raw reply [flat|nested] 6+ messages in thread
* [gcc(refs/users/aoliva/heads/testme)] improve integration of strub with type systems
@ 2021-11-16 3:48 Alexandre Oliva
0 siblings, 0 replies; 6+ messages in thread
From: Alexandre Oliva @ 2021-11-16 3:48 UTC (permalink / raw)
To: gcc-cvs
https://gcc.gnu.org/g:716430b9fb42f4fbe208cf2ae4b775182fc43b45
commit 716430b9fb42f4fbe208cf2ae4b775182fc43b45
Author: Alexandre Oliva <oliva@adacore.com>
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-%<strub%> call in %<strub%> 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 %<always_inline%> %<strub%> %qD"
" in non-%<strub%> 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-%<strub%> %qD in %<strub%> context %qD",
e->callee->decl, node->decl);
+ else
+ error_at (gimple_location (e->call_stmt),
+ "calling %qD using non-%<strub%> type %qT"
+ " in %<strub%> 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;
^ permalink raw reply [flat|nested] 6+ messages in thread
end of thread, other threads:[~2022-04-06 15:02 UTC | newest]
Thread overview: 6+ messages (download: mbox.gz / follow: Atom feed)
-- links below jump to the message on this page --
2021-11-16 3:48 [gcc(refs/users/aoliva/heads/testme)] Improve integration of strub with type systems Alexandre Oliva
-- strict thread matches above, loose matches on Subject: below --
2022-04-06 15:02 Alexandre Oliva
2022-04-06 15:02 Alexandre Oliva
2022-04-06 15:02 [gcc(refs/users/aoliva/heads/testme)] improve " Alexandre Oliva
2021-11-16 3:48 [gcc(refs/users/aoliva/heads/testme)] Improve " Alexandre Oliva
2021-11-16 3:48 [gcc(refs/users/aoliva/heads/testme)] improve " Alexandre Oliva
This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).