Skip to content

R
riscv-gcc-1
Commit b00baef5 by Javier Miranda Committed by Pierre-Marie de Rodat
Options

[Ada] Disable name generation for External_Tag and Expanded_Name 

In order to avoid exposing internal names of tagged types in the
binary code generated by the compiler this enhancement facilitates
initializes the External_Tag of a tagged type with an empty string
when pragma No_Tagged_Streams is applicable to the tagged type, and
facilitates initializes its Expanded_Name with an empty string when
pragma Discard_Names is applicable to the tagged type.

This enhancement can be verified by means of the following small
test:

package Library_Level_Test is
   type Typ_01 is tagged null record;    --  Case 1: No pragmas

   type Typ_02 is tagged null record;    --  Case 2: Discard_Names
   pragma Discard_Names (Typ_02);

   pragma No_Tagged_Streams;
   type Typ_03 is tagged null record;    --  Case 3: No_Tagged_Streams

   type Typ_04 is tagged null record;    --  Case 4: Both pragmas
   pragma Discard_Names (Typ_04);
end;

Commands:
  gcc -c -gnatD library_level_test.ads
  grep "\.TYP_" library_level_test.ads.dg

Output:
     "LIBRARY_LEVEL_TEST.TYP_01["00"]";
     "LIBRARY_LEVEL_TEST.TYP_02["00"]";
     "LIBRARY_LEVEL_TEST.TYP_03["00"]";

2018-05-22  Javier Miranda  <miranda@adacore.com>

gcc/ada/

	* exp_disp.adb (Make_DT): Initialize the External_Tag with an empty
	string when pragma No_Tagged_Streams is applicable to the tagged type,
	and initialize the Expanded_Name with an empty string when pragma
	Discard_Names is applicable to the tagged type.

From-SVN: r260528
parent 90fa8613
Showing with 133 additions and 23 deletions
gcc/ada/ChangeLog
2018-05-22 Javier Miranda <miranda@adacore.com>
* exp_disp.adb (Make_DT): Initialize the External_Tag with an empty
string when pragma No_Tagged_Streams is applicable to the tagged type,
and initialize the Expanded_Name with an empty string when pragma
Discard_Names is applicable to the tagged type.
2018-05-22 Ed Schonberg <schonberg@adacore.com> 2018-05-22 Ed Schonberg <schonberg@adacore.com>
* sem_ch6.adb (Check_Conformance): Add RM reference for rule that a * sem_ch6.adb (Check_Conformance): Add RM reference for rule that a
......
gcc/ada/exp_disp.adb
...@@ -4511,7 +4511,8 @@ package body Exp_Disp is ...@@ -4511,7 +4511,8 @@ package body Exp_Disp is
DT_Aggr_List : List_Id; DT_Aggr_List : List_Id;
DT_Constr_List : List_Id; DT_Constr_List : List_Id;
DT_Ptr : Entity_Id; DT_Ptr : Entity_Id;
Exname : Entity_Id; Expanded_Name : Entity_Id;
External_Tag_Name : Entity_Id;
HT_Link : Entity_Id; HT_Link : Entity_Id;
ITable : Node_Id; ITable : Node_Id;
I_Depth : Nat := 0; I_Depth : Nat := 0;
...@@ -4590,12 +4591,44 @@ package body Exp_Disp is ...@@ -4590,12 +4591,44 @@ package body Exp_Disp is
end if; end if;
end if; end if;
DT := Make_Defining_Identifier (Loc, Name_DT); DT := Make_Defining_Identifier (Loc, Name_DT);
Exname := Make_Defining_Identifier (Loc, Name_Exname); Expanded_Name := Make_Defining_Identifier (Loc, Name_Exname);
HT_Link := Make_Defining_Identifier (Loc, Name_HT_Link); HT_Link := Make_Defining_Identifier (Loc, Name_HT_Link);
Predef_Prims := Make_Defining_Identifier (Loc, Name_Predef_Prims); Predef_Prims := Make_Defining_Identifier (Loc, Name_Predef_Prims);
SSD := Make_Defining_Identifier (Loc, Name_SSD); SSD := Make_Defining_Identifier (Loc, Name_SSD);
TSD := Make_Defining_Identifier (Loc, Name_TSD); 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;
-- Initialize Parent_Typ handling private types -- Initialize Parent_Typ handling private types
...@@ -5000,20 +5033,72 @@ package body Exp_Disp is ...@@ -5000,20 +5033,72 @@ package body Exp_Disp is
end if; end if;
end if; end if;
-- Generate: Exname : constant String := full_qualified_name (typ); -- Generate: Expanded_Name : constant String := "";
if Global_Discard_Names or else Discard_Names (Typ) then
Append_To (Result,
Make_Object_Declaration (Loc,
Defining_Identifier => Expanded_Name,
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);
-- The type itself may be an anonymous parent type, so use the first -- The type itself may be an anonymous parent type, so use the first
-- subtype to have a user-recognizable name. -- subtype to have a user-recognizable name.
Append_To (Result, else
Make_Object_Declaration (Loc, Append_To (Result,
Defining_Identifier => Exname, Make_Object_Declaration (Loc,
Constant_Present => True, Defining_Identifier => Expanded_Name,
Object_Definition => New_Occurrence_Of (Standard_String, Loc), Constant_Present => True,
Expression => Object_Definition => New_Occurrence_Of (Standard_String, Loc),
Make_String_Literal (Loc, Expression =>
Strval => Fully_Qualified_Name_String (First_Subtype (Typ))))); Make_String_Literal (Loc,
Set_Is_Statically_Allocated (Exname); Fully_Qualified_Name_String (First_Subtype (Typ)))));
Set_Is_True_Constant (Exname); 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;
-- Declare the object used by Ada.Tags.Register_Tag -- Declare the object used by Ada.Tags.Register_Tag
...@@ -5033,8 +5118,8 @@ package body Exp_Disp is ...@@ -5033,8 +5118,8 @@ package body Exp_Disp is
-- (Idepth => I_Depth, -- (Idepth => I_Depth,
-- Access_Level => Type_Access_Level (Typ), -- Access_Level => Type_Access_Level (Typ),
-- Alignment => Typ'Alignment, -- Alignment => Typ'Alignment,
-- Expanded_Name => Cstring_Ptr!(Exname'Address)) -- Expanded_Name => Cstring_Ptr!(ExpandedName'Address))
-- External_Tag => Cstring_Ptr!(Exname'Address)) -- External_Tag => Cstring_Ptr!(ExternalName'Address))
-- HT_Link => HT_Link'Address, -- HT_Link => HT_Link'Address,
-- Transportable => <<boolean-value>>, -- Transportable => <<boolean-value>>,
-- Is_Abstract => <<boolean-value>>, -- Is_Abstract => <<boolean-value>>,
...@@ -5104,9 +5189,19 @@ package body Exp_Disp is ...@@ -5104,9 +5189,19 @@ package body Exp_Disp is
Append_To (TSD_Aggr_List, Append_To (TSD_Aggr_List,
Unchecked_Convert_To (RTE (RE_Cstring_Ptr), Unchecked_Convert_To (RTE (RE_Cstring_Ptr),
Make_Attribute_Reference (Loc, Make_Attribute_Reference (Loc,
Prefix => New_Occurrence_Of (Exname, Loc), Prefix => New_Occurrence_Of (Expanded_Name, Loc),
Attribute_Name => Name_Address))); 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 -- External_Tag of a local tagged type
-- <typ>A : constant String := -- <typ>A : constant String :=
...@@ -5134,7 +5229,7 @@ package body Exp_Disp is ...@@ -5134,7 +5229,7 @@ package body Exp_Disp is
-- specified. That's an odd case for which we have already issued a -- 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. -- warning, where we will not be able to compute the internal tag.
if not Is_Library_Level_Entity (Typ) elsif not Is_Library_Level_Entity (Typ)
and then not Has_External_Tag_Rep_Clause (Typ) and then not Has_External_Tag_Rep_Clause (Typ)
then then
declare declare
...@@ -5189,6 +5284,9 @@ package body Exp_Disp is ...@@ -5189,6 +5284,9 @@ package body Exp_Disp is
Right_Opnd => Right_Opnd =>
Make_String_Literal (Loc, Str2_Id))))); Make_String_Literal (Loc, Str2_Id)))));
-- Generate:
-- Exname : constant String := Str1 & Str2;
else else
Append_To (Result, Append_To (Result,
Make_Object_Declaration (Loc, Make_Object_Declaration (Loc,
...@@ -5234,7 +5332,8 @@ package body Exp_Disp is ...@@ -5234,7 +5332,8 @@ package body Exp_Disp is
New_Node := New_Node :=
Unchecked_Convert_To (RTE (RE_Cstring_Ptr), Unchecked_Convert_To (RTE (RE_Cstring_Ptr),
Make_Attribute_Reference (Loc, Make_Attribute_Reference (Loc,
Prefix => New_Occurrence_Of (Exname, Loc), Prefix => New_Occurrence_Of
(External_Tag_Name, Loc),
Attribute_Name => Name_Address)); Attribute_Name => Name_Address));
else else
Old_Val := Strval (Expr_Value_S (Expression (Def))); Old_Val := Strval (Expr_Value_S (Expression (Def)));
...@@ -6406,10 +6505,14 @@ package body Exp_Disp is ...@@ -6406,10 +6505,14 @@ package body Exp_Disp is
-- We check for No_Run_Time_Mode here, because we do not want to pick -- 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. -- up the RE_Check_TSD entity and call it in No_Run_Time mode.
-- We cannot perform this check if the generation of its expanded name
-- was discarded.
if not No_Run_Time_Mode if not No_Run_Time_Mode
and then Ada_Version >= Ada_2005 and then Ada_Version >= Ada_2005
and then RTE_Available (RE_Check_TSD) and then RTE_Available (RE_Check_TSD)
and then not Duplicated_Tag_Checks_Suppressed (Typ) and then not Duplicated_Tag_Checks_Suppressed (Typ)
and then not (Global_Discard_Names or else Discard_Names (Typ))
then then
Append_To (Elab_Code, Append_To (Elab_Code,
Make_Procedure_Call_Statement (Loc, Make_Procedure_Call_Statement (Loc,
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment