From mboxrd@z Thu Jan 1 00:00:00 1970 Return-Path: Received: by sourceware.org (Postfix, from userid 2140) id 20842385E451; Wed, 6 Apr 2022 15:02:02 +0000 (GMT) DKIM-Filter: OpenDKIM Filter v2.11.0 sourceware.org 20842385E451 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/testme)] Revert "[Ada] Improve integration of strub with type systems" X-Act-Checkin: gcc X-Git-Author: Alexandre Oliva X-Git-Refname: refs/users/aoliva/heads/testme X-Git-Oldrev: 418967ca275853a570b0ae566d7022ff38e7cd0d X-Git-Newrev: 81e257609c225fc542c1d104736a461aa6766dab Message-Id: <20220406150202.20842385E451@sourceware.org> Date: Wed, 6 Apr 2022 15:02:02 +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: Wed, 06 Apr 2022 15:02:02 -0000 https://gcc.gnu.org/g:81e257609c225fc542c1d104736a461aa6766dab commit 81e257609c225fc542c1d104736a461aa6766dab Author: Alexandre Oliva Date: Tue Nov 16 00:45:35 2021 -0300 Revert "[Ada] Improve integration of strub with type systems" This reverts commit d235950e83965ed6389eb94b1cffb7393dcb1984. 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/gcc-interface/Make-lang.in | 1 - 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 -------- 15 files changed, 46 insertions(+), 631 deletions(-) diff --git a/gcc/ada/doc/gnat_rm/security_hardening_features.rst b/gcc/ada/doc/gnat_rm/security_hardening_features.rst index bdcfd99ad86..cf76938d91d 100644 --- a/gcc/ada/doc/gnat_rm/security_hardening_features.rst +++ b/gcc/ada/doc/gnat_rm/security_hardening_features.rst @@ -73,52 +73,20 @@ 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. -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. +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. .. Hardened Conditionals: diff --git a/gcc/ada/exp_attr.adb b/gcc/ada/exp_attr.adb index 5374dd4d7e9..bc7e045f51b 100644 --- a/gcc/ada/exp_attr.adb +++ b/gcc/ada/exp_attr.adb @@ -67,7 +67,6 @@ 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; @@ -2161,7 +2160,6 @@ 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 f2d20af52d0..f06a4c4ea76 100644 --- a/gcc/ada/exp_disp.adb +++ b/gcc/ada/exp_disp.adb @@ -66,7 +66,6 @@ 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; @@ -847,7 +846,6 @@ 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 7ed44f591fc..de04a08ae8a 100644 --- a/gcc/ada/freeze.adb +++ b/gcc/ada/freeze.adb @@ -69,7 +69,6 @@ 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; @@ -1791,10 +1790,6 @@ 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 @@ -1828,10 +1823,11 @@ package body Freeze is while Present (Op_Node) loop Prim := Node (Op_Node); - Par_Prim := Overridden_Operation (Prim); - if Present (Par_Prim) + if Present (Overridden_Operation (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. @@ -1841,11 +1837,6 @@ 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. @@ -1861,54 +1852,6 @@ 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; @@ -2560,18 +2503,6 @@ 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/gcc-interface/Make-lang.in b/gcc/ada/gcc-interface/Make-lang.in index a8d8899d3c9..2af2ae76390 100644 --- a/gcc/ada/gcc-interface/Make-lang.in +++ b/gcc/ada/gcc-interface/Make-lang.in @@ -433,7 +433,6 @@ 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/libgnat/a-except.ads b/gcc/ada/libgnat/a-except.ads index af87d6624a9..4411e5b1c47 100644 --- a/gcc/ada/libgnat/a-except.ads +++ b/gcc/ada/libgnat/a-except.ads @@ -184,9 +184,14 @@ 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"); - -- Make it callable from strub contexts + 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. 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 fe043a97afb..b71fcd35d9a 100644 --- a/gcc/ada/libgnat/s-arit128.ads +++ b/gcc/ada/libgnat/s-arit128.ads @@ -167,4 +167,11 @@ 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 c4bebeb0e4e..7ea58a48517 100644 --- a/gcc/ada/libgnat/s-arit64.ads +++ b/gcc/ada/libgnat/s-arit64.ads @@ -179,4 +179,11 @@ 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 b75f1a3a264..eaaba35e752 100644 --- a/gcc/ada/libgnat/s-secsta.ads +++ b/gcc/ada/libgnat/s-secsta.ads @@ -438,4 +438,9 @@ 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 33179aa2f87..169a9d1a358 100644 --- a/gcc/ada/sem_attr.adb +++ b/gcc/ada/sem_attr.adb @@ -74,7 +74,6 @@ 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; @@ -11316,27 +11315,6 @@ 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 2e207c16e23..d3c75229402 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -79,7 +79,6 @@ 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; @@ -16076,8 +16075,6 @@ 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 f9169eeedd7..728b1c3a963 100644 --- a/gcc/ada/sem_prag.adb +++ b/gcc/ada/sem_prag.adb @@ -84,7 +84,6 @@ 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; @@ -19495,29 +19494,7 @@ package body Sem_Prag is Check_Arg_Is_OK_Static_Expression (Arg2, Standard_String); Def_Id := Entity (Get_Pragma_Arg (Arg1)); - -- 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 + if Is_Access_Type (Def_Id) then Def_Id := Designated_Type (Def_Id); end if; @@ -19535,7 +19512,7 @@ package body Sem_Prag is if Rep_Item_Too_Late (Def_Id, N) then return; else - Set_Has_Gigi_Rep_Item (Def_Id); + Set_Has_Gigi_Rep_Item (Entity (Get_Pragma_Arg (Arg1))); end if; end Machine_Attribute; diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb index 4f66b715778..ed94036c9b6 100644 --- a/gcc/ada/sem_res.adb +++ b/gcc/ada/sem_res.adb @@ -82,7 +82,6 @@ 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; @@ -3180,27 +3179,6 @@ 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 @@ -14226,15 +14204,7 @@ package body Sem_Res is end; end if; - -- 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"); + return True; -- Remote access to subprogram types @@ -14260,16 +14230,7 @@ package body Sem_Res is Designated_Type (Corresponding_Remote_Type (Opnd_Type)), Err_Loc => N); - - -- 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"); + return True; -- 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 deleted file mode 100644 index 485c2632ed3..00000000000 --- a/gcc/ada/strub.adb +++ /dev/null @@ -1,301 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- 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 deleted file mode 100644 index 3a67632a54a..00000000000 --- a/gcc/ada/strub.ads +++ /dev/null @@ -1,115 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- 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;