From: Javier Miranda Date: Wed, 23 May 2018 10:22:47 +0000 (+0000) Subject: [Ada] Restrict initialization of External_Tag and Expanded_Name X-Git-Url: https://git.libre-soc.org/?a=commitdiff_plain;h=51ab2a39e9baae7fe1552daca02337050b11cfb6;p=gcc.git [Ada] Restrict initialization of External_Tag and Expanded_Name 2018-05-23 Javier Miranda gcc/ada/ * exp_disp.adb (Make_DT): Restrict the initialization of External_Tag and Expanded_Name to an empty string to the case where both pragmas apply (i.e. No_Tagged_Streams and Discard_Names), since restricted runtimes are compiled with pragma Discard_Names. * doc/gnat_rm/implementation_defined_pragmas.rst, doc/gnat_rm/implementation_defined_characteristics.rst: Add documentation. * gnat_rm.texi: Regenerate. From-SVN: r260584 --- diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index cd5cd128cf5..abc289c419b 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,14 @@ +2018-05-23 Javier Miranda + + * exp_disp.adb (Make_DT): Restrict the initialization of + External_Tag and Expanded_Name to an empty string to the case where + both pragmas apply (i.e. No_Tagged_Streams and Discard_Names), since + restricted runtimes are compiled with pragma Discard_Names. + * doc/gnat_rm/implementation_defined_pragmas.rst, + doc/gnat_rm/implementation_defined_characteristics.rst: Add + documentation. + * gnat_rm.texi: Regenerate. + 2018-05-23 Maroua Maalej * sem_spark.adb: Fix of some permission rules of pointers in SPARK. diff --git a/gcc/ada/doc/gnat_rm/implementation_defined_characteristics.rst b/gcc/ada/doc/gnat_rm/implementation_defined_characteristics.rst index 44d29935de1..67ad7e7aa0d 100644 --- a/gcc/ada/doc/gnat_rm/implementation_defined_characteristics.rst +++ b/gcc/ada/doc/gnat_rm/implementation_defined_characteristics.rst @@ -875,6 +875,11 @@ be suppressed. In the presence of this pragma, the Image attribute provides the image of the Pos of the literal, and Value accepts Pos values. +For tagged types, when pragmas ``Discard_Names`` and ``No_Tagged_Streams`` +simultaneously apply, their Expanded_Name and External_Tag are initialized +with empty strings. This is useful to avoid exposing entity names at binary +level. + * "The result of the ``Task_Identification.Image`` attribute. See C.7.1(7)." diff --git a/gcc/ada/doc/gnat_rm/implementation_defined_pragmas.rst b/gcc/ada/doc/gnat_rm/implementation_defined_pragmas.rst index b39625c39c5..c3a1ec4ba5f 100644 --- a/gcc/ada/doc/gnat_rm/implementation_defined_pragmas.rst +++ b/gcc/ada/doc/gnat_rm/implementation_defined_pragmas.rst @@ -3892,6 +3892,11 @@ and derived types of this type inherit the pragma automatically, so the effect applies to a complete hierarchy (this is necessary to deal with the class-wide dispatching versions of the stream routines). +When pragmas ``Discard_Names`` and ``No_Tagged_Streams`` are simultaneously +applied to a tagged type its Expanded_Name and External_Tag are initialized +with empty strings. This is useful to avoid exposing entity names at binary +level but has a negative impact on the debuggability of tagged types. + Pragma Normalize_Scalars ======================== diff --git a/gcc/ada/exp_disp.adb b/gcc/ada/exp_disp.adb index 84add602c44..bded4c1dc52 100644 --- a/gcc/ada/exp_disp.adb +++ b/gcc/ada/exp_disp.adb @@ -4480,6 +4480,21 @@ package body Exp_Disp is Result : constant List_Id := New_List; Tname : constant Name_Id := Chars (Typ); + -- When pragmas Discard_Names and No_Tagged_Streams simultaneously apply + -- we initialize the Expanded_Name and the External_Tag of this tagged + -- type with an empty string. This is useful to avoid exposing entity + -- names at binary level. It can be done when both pragmas apply because + -- (1) Discard_Names allows initializing Expanded_Name with an + -- implementation defined value (Ada RM Section C.5 (7/2)). + -- (2) External_Tag (combined with Internal_Tag) is used for object + -- streaming and No_Tagged_Streams inhibits the generation of + -- streams. + + Discard_Names : constant Boolean := + Present (No_Tagged_Streams_Pragma (Typ)) + and then (Global_Discard_Names + or else Einfo.Discard_Names (Typ)); + -- The following name entries are used by Make_DT to generate a number -- of entities related to a tagged type. These entities may be generated -- in a scope other than that of the tagged type declaration, and if @@ -4511,8 +4526,7 @@ package body Exp_Disp is DT_Aggr_List : List_Id; DT_Constr_List : List_Id; DT_Ptr : Entity_Id; - Expanded_Name : Entity_Id; - External_Tag_Name : Entity_Id; + Exname : Entity_Id; HT_Link : Entity_Id; ITable : Node_Id; I_Depth : Nat := 0; @@ -4591,44 +4605,12 @@ package body Exp_Disp is end if; end if; - DT := Make_Defining_Identifier (Loc, Name_DT); - Expanded_Name := Make_Defining_Identifier (Loc, Name_Exname); - HT_Link := Make_Defining_Identifier (Loc, Name_HT_Link); - Predef_Prims := Make_Defining_Identifier (Loc, Name_Predef_Prims); - SSD := Make_Defining_Identifier (Loc, Name_SSD); - TSD := Make_Defining_Identifier (Loc, Name_TSD); - - -- Expanded_Name - -- ------------- - - -- We generally initialize the Expanded_Name and the External_Tag of - -- tagged types with the same name, unless pragmas Discard_Names or - -- No_Tagged_Streams apply: Discard_Names allows us to initialize its - -- Expanded_Name with an empty string because in such a case it's - -- value is implementation defined (Ada RM Section C.5(7/2)); pragma - -- No_Tagged_Streams inhibits the generation of stream routines and - -- we initialize its External_Tag with an empty string since Ada.Tags - -- services Internal_Tag and External_Tag are mainly used with streams. - - -- Small optimization: when both pragmas apply then there is no need to - -- declare two objects initialized with empty strings (since the two - -- aggregate components can be initialized with the same object). - - if (Global_Discard_Names or else Discard_Names (Typ)) - and then Present (No_Tagged_Streams_Pragma (Typ)) - then - External_Tag_Name := Expanded_Name; - - elsif Global_Discard_Names - or else Discard_Names (Typ) - or else Present (No_Tagged_Streams_Pragma (Typ)) - then - External_Tag_Name := - Make_Defining_Identifier (Loc, - New_External_Name (Tname, 'N', Suffix_Index => -1)); - else - External_Tag_Name := Expanded_Name; - end if; + DT := Make_Defining_Identifier (Loc, Name_DT); + Exname := Make_Defining_Identifier (Loc, Name_Exname); + HT_Link := Make_Defining_Identifier (Loc, Name_HT_Link); + Predef_Prims := Make_Defining_Identifier (Loc, Name_Predef_Prims); + SSD := Make_Defining_Identifier (Loc, Name_SSD); + TSD := Make_Defining_Identifier (Loc, Name_TSD); -- Initialize Parent_Typ handling private types @@ -5033,27 +5015,25 @@ package body Exp_Disp is end if; end if; - -- Generate: - -- Expanded_Name : constant String := ""; + -- Generate: Expanded_Name : constant String := ""; - if Global_Discard_Names or else Discard_Names (Typ) then + if Discard_Names then Append_To (Result, Make_Object_Declaration (Loc, - Defining_Identifier => Expanded_Name, + Defining_Identifier => Exname, Constant_Present => True, Object_Definition => New_Occurrence_Of (Standard_String, Loc), Expression => Make_String_Literal (Loc, ""))); - -- Generate: - -- Expanded_Name : constant String := full_qualified_name (typ); + -- Generate: Exname : constant String := full_qualified_name (typ); -- The type itself may be an anonymous parent type, so use the first -- subtype to have a user-recognizable name. else Append_To (Result, Make_Object_Declaration (Loc, - Defining_Identifier => Expanded_Name, + Defining_Identifier => Exname, Constant_Present => True, Object_Definition => New_Occurrence_Of (Standard_String, Loc), Expression => @@ -5061,46 +5041,8 @@ package body Exp_Disp is Fully_Qualified_Name_String (First_Subtype (Typ))))); end if; - Set_Is_Statically_Allocated (Expanded_Name); - Set_Is_True_Constant (Expanded_Name); - - -- Generate the External_Tag name only when it is required (since in - -- most cases we can initialize Expanded_Name and External_Tag using - -- the same object). - - if Expanded_Name /= External_Tag_Name then - - -- Generate: - -- External_Tag_Name : constant String := ""; - - if Present (No_Tagged_Streams_Pragma (Typ)) then - Append_To (Result, - Make_Object_Declaration (Loc, - Defining_Identifier => External_Tag_Name, - Constant_Present => True, - Object_Definition => - New_Occurrence_Of (Standard_String, Loc), - Expression => Make_String_Literal (Loc, ""))); - - -- Generate: - -- External_Tag_Name : constant String := - -- full_qualified_name (typ); - - else - Append_To (Result, - Make_Object_Declaration (Loc, - Defining_Identifier => External_Tag_Name, - Constant_Present => True, - Object_Definition => - New_Occurrence_Of (Standard_String, Loc), - Expression => - Make_String_Literal (Loc, - Fully_Qualified_Name_String (First_Subtype (Typ))))); - end if; - - Set_Is_Statically_Allocated (External_Tag_Name); - Set_Is_True_Constant (External_Tag_Name); - end if; + Set_Is_Statically_Allocated (Exname); + Set_Is_True_Constant (Exname); -- Declare the object used by Ada.Tags.Register_Tag @@ -5120,8 +5062,8 @@ package body Exp_Disp is -- (Idepth => I_Depth, -- Access_Level => Type_Access_Level (Typ), -- Alignment => Typ'Alignment, - -- Expanded_Name => Cstring_Ptr!(ExpandedName'Address)) - -- External_Tag => Cstring_Ptr!(ExternalName'Address)) + -- Expanded_Name => Cstring_Ptr!(Exname'Address)) + -- External_Tag => Cstring_Ptr!(Exname'Address)) -- HT_Link => HT_Link'Address, -- Transportable => <>, -- Is_Abstract => <>, @@ -5191,18 +5133,9 @@ package body Exp_Disp is Append_To (TSD_Aggr_List, Unchecked_Convert_To (RTE (RE_Cstring_Ptr), Make_Attribute_Reference (Loc, - Prefix => New_Occurrence_Of (Expanded_Name, Loc), + Prefix => New_Occurrence_Of (Exname, Loc), Attribute_Name => Name_Address))); - -- External_Tag when pragma No_Tagged_Streams applies - - if Present (No_Tagged_Streams_Pragma (Typ)) then - New_Node := - Unchecked_Convert_To (RTE (RE_Cstring_Ptr), - Make_Attribute_Reference (Loc, - Prefix => New_Occurrence_Of (External_Tag_Name, Loc), - Attribute_Name => Name_Address)); - -- External_Tag of a local tagged type -- A : constant String := @@ -5230,7 +5163,8 @@ package body Exp_Disp is -- specified. That's an odd case for which we have already issued a -- warning, where we will not be able to compute the internal tag. - elsif not Is_Library_Level_Entity (Typ) + if not Discard_Names + and then not Is_Library_Level_Entity (Typ) and then not Has_External_Tag_Rep_Clause (Typ) then declare @@ -5333,8 +5267,7 @@ package body Exp_Disp is New_Node := Unchecked_Convert_To (RTE (RE_Cstring_Ptr), Make_Attribute_Reference (Loc, - Prefix => - New_Occurrence_Of (External_Tag_Name, Loc), + Prefix => New_Occurrence_Of (Exname, Loc), Attribute_Name => Name_Address)); else Old_Val := Strval (Expr_Value_S (Expression (Def))); @@ -6501,7 +6434,7 @@ package body Exp_Disp is -- applies to Ada 2005 (and Ada 2012). It might be argued that it is -- a desirable check to add in Ada 95 mode, but we hesitate to make -- this change, as it would be incompatible, and could conceivably - -- cause a problem in existing Aa 95 code. + -- cause a problem in existing Ada 95 code. -- We check for No_Run_Time_Mode here, because we do not want to pick -- up the RE_Check_TSD entity and call it in No_Run_Time mode. @@ -6510,10 +6443,10 @@ package body Exp_Disp is -- was discarded. if not No_Run_Time_Mode + and then not Discard_Names and then Ada_Version >= Ada_2005 and then RTE_Available (RE_Check_TSD) and then not Duplicated_Tag_Checks_Suppressed (Typ) - and then not (Global_Discard_Names or else Discard_Names (Typ)) then Append_To (Elab_Code, Make_Procedure_Call_Statement (Loc, diff --git a/gcc/ada/gnat_rm.texi b/gcc/ada/gnat_rm.texi index 387e2a04d3c..f4b7f94c0c8 100644 --- a/gcc/ada/gnat_rm.texi +++ b/gcc/ada/gnat_rm.texi @@ -21,7 +21,7 @@ @copying @quotation -GNAT Reference Manual , Apr 20, 2018 +GNAT Reference Manual , Apr 23, 2018 AdaCore @@ -5328,6 +5328,11 @@ and derived types of this type inherit the pragma automatically, so the effect applies to a complete hierarchy (this is necessary to deal with the class-wide dispatching versions of the stream routines). +When pragmas @code{Discard_Names} and @code{No_Tagged_Streams} are simultaneously +applied to a tagged type its Expanded_Name and External_Tag are initialized +with empty strings. This is useful to avoid exposing entity names at binary +level but has a negative impact on the debuggability of tagged types. + @node Pragma Normalize_Scalars,Pragma Obsolescent,Pragma No_Tagged_Streams,Implementation Defined Pragmas @anchor{gnat_rm/implementation_defined_pragmas pragma-normalize-scalars}@anchor{a8} @section Pragma Normalize_Scalars @@ -17143,6 +17148,11 @@ be suppressed. In the presence of this pragma, the Image attribute provides the image of the Pos of the literal, and Value accepts Pos values. +For tagged types, when pragmas @code{Discard_Names} and @code{No_Tagged_Streams} +simultaneously apply, their Expanded_Name and External_Tag are initialized +with empty strings. This is useful to avoid exposing entity names at binary +level. + @itemize *