From mboxrd@z Thu Jan 1 00:00:00 1970 Return-Path: Received: by sourceware.org (Postfix, from userid 2140) id EC6423858C2C; Sat, 30 Oct 2021 10:16:37 +0000 (GMT) DKIM-Filter: OpenDKIM Filter v2.11.0 sourceware.org EC6423858C2C Content-Type: text/plain; charset="us-ascii" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit From: Alexandre Oliva To: gcc-cvs@gcc.gnu.org Subject: [gcc(refs/users/aoliva/heads/strub)] Improve integration of strub with type systems X-Act-Checkin: gcc X-Git-Author: Alexandre Oliva X-Git-Refname: refs/users/aoliva/heads/strub X-Git-Oldrev: ecc3d3025beb9114345ad34205ac8d29ef812bca X-Git-Newrev: d988c8393963322c4d426778abae9a596b4cf2bb Message-Id: <20211030101637.EC6423858C2C@sourceware.org> Date: Sat, 30 Oct 2021 10:16:37 +0000 (GMT) X-BeenThere: gcc-cvs@gcc.gnu.org X-Mailman-Version: 2.1.29 Precedence: list List-Id: Gcc-cvs mailing list List-Unsubscribe: , List-Archive: List-Help: List-Subscribe: , X-List-Received-Date: Sat, 30 Oct 2021 10:16:38 -0000 https://gcc.gnu.org/g:d988c8393963322c4d426778abae9a596b4cf2bb commit d988c8393963322c4d426778abae9a596b4cf2bb Author: Alexandre Oliva 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 68d21494809..c9141f5fe3e 100644 --- a/gcc/ada/libgnat/s-arit64.ads +++ b/gcc/ada/libgnat/s-arit64.ads @@ -93,11 +93,4 @@ package System.Arith_64 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 152ef83387d..48d91532854 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; @@ -16047,6 +16048,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 10ad82fd8a4..6ef22fbb749 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; @@ -19438,7 +19439,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; @@ -19456,7 +19479,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;