OpenE2K/gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

a-tags.adb:

Browse Source 
2007-09-26  Javier Miranda  <miranda@adacore.com>
	    Eric Botcazou  <ebotcazou@adacore.com>

	* a-tags.adb: 
	(Get_HT_Link/Set_HT_Link): Updated to handle the additional level of
	 indirection added to the HT_Link component of the TSD. This is required
	 to statically allocate the TSD.

	* a-tags.ads: 
	Minor reordering of the declarations in the private part. Required to
	add a level of indirection to the contents of the TSD component HT_Link.
	This is required to statically allocate the TSD.

	* decl.c (gnat_to_gnu_entity) <object>: Do not exclude objects with
	Is_Statically_Allocated set from constant objects.
	Do not make exported constants created by the compiler volatile.
	(gnat_to_gnu_param): Do not treat an IN parameter whose address is taken
	as read-only.

	* trans.c (Identifier_to_gnu): For constants, unshare initializers
	before returning them.

	* exp_disp.ads, exp_disp.adb (Building_Static_DT): Spec moved to the
	public part of the package.
	(Make_DT): Move HT_Link component out of the TSD record. For this
	purpose Make_DT now declares a separate object that stores the
	HT_Link value, and initializes the TSD component with the address
	of this new object. The addition of this level of indirection is
	required to statically allocate the TSD because the TSD cannot
	have variable components.
	(Expand_Interface_Conversion): Improve the expanded code.
	(Expand_Interface_Thunk): Set Is_Thunk in the thunk entity.

	* sem_disp.adb (Check_Dispatching_Operation): In case of a body
	declaring a primitive operation ---allowed by RM 3.9.2 (13.e/2)---,
	if we are building static dispatch tables then we must not generate
	extra code to register the primitive because the dispatch table will
	be built at the end of the library package; otherwise we notify that
	we cannot build the static dispatch table.

From-SVN: r128784
This commit is contained in:
Javier Miranda 2007-09-26 12:42:20 +02:00 committed by Arnaud Charlet
parent e29bd38f96
commit 6e818918f2
7 changed files with 115 additions and 82 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
gcc/ada/a-tags.adb
View File

@ -279,7 +279,7 @@ package body Ada.Tags is
TSD : constant Type_Specific_Data_Ptr :=
To_Type_Specific_Data_Ptr (TSD_Ptr.all);
begin
return TSD.HT_Link;
return TSD.HT_Link.all;
end Get_HT_Link;
----------
@ -304,7 +304,7 @@ package body Ada.Tags is
TSD : constant Type_Specific_Data_Ptr :=
To_Type_Specific_Data_Ptr (TSD_Ptr.all);
begin
TSD.HT_Link := Next;
TSD.HT_Link.all := Next;
end Set_HT_Link;
end HTable_Subprograms;

42
gcc/ada/a-tags.ads
View File

@ -218,6 +218,26 @@ private
-- type. This construct is used in the handling of dispatching triggers
-- in select statements.
type Address_Array is array (Positive range <>) of System.Address;
subtype Dispatch_Table is Address_Array (1 .. 1);
-- Used by GDB to identify the _tags and traverse the run-time structure
-- associated with tagged types. For compatibility with older versions of
-- gdb, its name must not be changed.
type Tag is access all Dispatch_Table;
pragma No_Strict_Aliasing (Tag);
type Interface_Tag is access all Dispatch_Table;
No_Tag : constant Tag := null;
-- The expander ensures that Tag objects reference the Prims_Ptr component
-- of the wrapper.
type Tag_Ptr is access all Tag;
pragma No_Strict_Aliasing (Tag_Ptr);
type Tag_Table is array (Natural range <>) of Tag;
type Type_Specific_Data (Idepth : Natural) is record
@ -237,7 +257,7 @@ private
Expanded_Name : Cstring_Ptr;
External_Tag : Cstring_Ptr;
HT_Link : Tag;
HT_Link : Tag_Ptr;
-- Components used to support to the Ada.Tags subprograms in RM 3.9
-- Note: Expanded_Name is referenced by GDB to determine the actual name
@ -291,8 +311,6 @@ private
TK_Tagged,
TK_Task);
type Address_Array is array (Positive range <>) of System.Address;
type Dispatch_Table_Wrapper (Num_Prims : Natural) is record
Signature : Signature_Kind;
Tag_Kind : Tagged_Kind;
@ -315,24 +333,6 @@ private
-- actual array size, allocates the Dispatch_Table record accordingly.
end record;
subtype Dispatch_Table is Address_Array (1 .. 1);
-- Used by GDB to identify the _tags and traverse the run-time structure
-- associated with tagged types. For compatibility with older versions of
-- gdb, its name must not be changed.
type Tag is access all Dispatch_Table;
pragma No_Strict_Aliasing (Tag);
type Interface_Tag is access all Dispatch_Table;
No_Tag : constant Tag := null;
-- The expander ensures that Tag objects reference the Prims_Ptr component
-- of the wrapper.
type Tag_Ptr is access all Tag;
pragma No_Strict_Aliasing (Tag_Ptr);
type Dispatch_Table_Ptr is access all Dispatch_Table_Wrapper;
pragma No_Strict_Aliasing (Dispatch_Table_Ptr);

25
gcc/ada/decl.c
View File

@ -500,7 +500,6 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition)
bool used_by_ref = false;
bool const_flag
= ((kind == E_Constant || kind == E_Variable)
&& !Is_Statically_Allocated (gnat_entity)
&& Is_True_Constant (gnat_entity)
&& (((Nkind (Declaration_Node (gnat_entity))
== N_Object_Declaration)
@ -732,7 +731,11 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition)
the object volatile. We also interpret 13.3(19) conservatively
and disallow any optimizations for an object covered by it. */
if ((Treat_As_Volatile (gnat_entity)
|| Is_Exported (gnat_entity)
|| (Is_Exported (gnat_entity)
/* Exclude exported constants created by the compiler,
which should boil down to static dispatch tables and
make it possible to put them in read-only memory.  */
&& (Comes_From_Source (gnat_entity) || !const_flag))
|| Is_Imported (gnat_entity)
|| Present (Address_Clause (gnat_entity)))
&& !TYPE_VOLATILE (gnu_type))
@ -4447,6 +4450,8 @@ gnat_to_gnu_param (Entity_Id gnat_param, Mechanism_Type mech,
tree gnu_param_name = get_entity_name (gnat_param);
tree gnu_param_type = gnat_to_gnu_type (Etype (gnat_param));
bool in_param = (Ekind (gnat_param) == E_In_Parameter);
/* The parameter can be indirectly modified if its address is taken. */
bool ro_param = in_param && !Address_Taken (gnat_param);
bool by_return = false, by_component_ptr = false, by_ref = false;
tree gnu_param;
@ -4473,11 +4478,11 @@ gnat_to_gnu_param (Entity_Id gnat_param, Mechanism_Type mech,
gnu_param_type = unpadded_type;
}
/* If this is an IN parameter, it is read-only, so make a variant of the
type that is read-only. ??? However, if this is an unconstrained array,
that type can be very complex, so skip it for now. Likewise for any
other self-referential type. */
if (in_param
/* If this is a read-only parameter, make a variant of the type that is
read-only. ??? However, if this is an unconstrained array, that type
can be very complex, so skip it for now. Likewise for any other
self-referential type. */
if (ro_param
&& TREE_CODE (gnu_param_type) != UNCONSTRAINED_ARRAY_TYPE
&& !CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_param_type)))
gnu_param_type = build_qualified_type (gnu_param_type,
@ -4511,7 +4516,7 @@ gnat_to_gnu_param (Entity_Id gnat_param, Mechanism_Type mech,
by_component_ptr = true;
gnu_param_type = TREE_TYPE (gnu_param_type);
if (in_param)
if (ro_param)
gnu_param_type = build_qualified_type (gnu_param_type,
(TYPE_QUALS (gnu_param_type)
| TYPE_QUAL_CONST));
@ -4584,12 +4589,12 @@ gnat_to_gnu_param (Entity_Id gnat_param, Mechanism_Type mech,
return gnu_param_type;
gnu_param = create_param_decl (gnu_param_name, gnu_param_type,
by_ref || by_component_ptr || in_param);
ro_param || by_ref || by_component_ptr);
DECL_BY_REF_P (gnu_param) = by_ref;
DECL_BY_COMPONENT_PTR_P (gnu_param) = by_component_ptr;
DECL_BY_DESCRIPTOR_P (gnu_param) = (mech == By_Descriptor);
DECL_POINTS_TO_READONLY_P (gnu_param)
= (in_param && (by_ref || by_component_ptr));
= (ro_param && (by_ref || by_component_ptr));
/* If no Mechanism was specified, indicate what we're using, then
back-annotate it. */

95
gcc/ada/exp_disp.adb
View File

@ -66,10 +66,6 @@ package body Exp_Disp is
-- Local Subprograms --
-----------------------
function Building_Static_DT (Typ : Entity_Id) return Boolean;
pragma Inline (Building_Static_DT);
-- Returns true when building statically allocated dispatch tables
function Default_Prim_Op_Position (E : Entity_Id) return Uint;
-- Ada 2005 (AI-251): Returns the fixed position in the dispatch table
-- of the default primitive operations.
@ -104,7 +100,13 @@ package body Exp_Disp is
function Building_Static_DT (Typ : Entity_Id) return Boolean is
begin
return Static_Dispatch_Tables
and then Is_Library_Level_Tagged_Type (Typ);
and then Is_Library_Level_Tagged_Type (Typ)
-- If the type is derived from a CPP class we cannot statically
-- build the dispatch tables because we must inherit primitives
-- from the CPP side.
and then not Is_CPP_Class (Root_Type (Typ));
end Building_Static_DT;
----------------------------------
@ -742,7 +744,7 @@ package body Exp_Disp is
Operand_Typ := Base_Type (Corresponding_Record_Type (Operand_Typ));
end if;
-- Handle access types to interfaces
-- Handle access to class-wide interface types
if Is_Access_Type (Iface_Typ) then
Iface_Typ := Etype (Directly_Designated_Type (Iface_Typ));
@ -881,11 +883,9 @@ package body Exp_Disp is
-- end Func;
declare
Decls : List_Id;
Desig_Typ : Entity_Id;
Fent : Entity_Id;
New_Typ_Decl : Node_Id;
New_Obj_Decl : Node_Id;
Stats : List_Id;
begin
@ -895,6 +895,10 @@ package body Exp_Disp is
Desig_Typ := Directly_Designated_Type (Desig_Typ);
end if;
if Is_Concurrent_Type (Desig_Typ) then
Desig_Typ := Base_Type (Corresponding_Record_Type (Desig_Typ));
end if;
New_Typ_Decl :=
Make_Full_Type_Declaration (Loc,
Defining_Identifier =>
@ -907,22 +911,6 @@ package body Exp_Disp is
Subtype_Indication =>
New_Reference_To (Desig_Typ, Loc)));
New_Obj_Decl :=
Make_Object_Declaration (Loc,
Defining_Identifier =>
Make_Defining_Identifier (Loc,
New_Internal_Name ('S')),
Constant_Present => True,
Object_Definition =>
New_Reference_To (Defining_Identifier (New_Typ_Decl), Loc),
Expression =>
Unchecked_Convert_To (Defining_Identifier (New_Typ_Decl),
Make_Identifier (Loc, Name_uO)));
Decls := New_List (
New_Typ_Decl,
New_Obj_Decl);
Stats := New_List (
Make_Simple_Return_Statement (Loc,
Unchecked_Convert_To (Etype (N),
@ -930,9 +918,9 @@ package body Exp_Disp is
Prefix =>
Make_Selected_Component (Loc,
Prefix =>
New_Reference_To
(Defining_Identifier (New_Obj_Decl),
Loc),
Unchecked_Convert_To
(Defining_Identifier (New_Typ_Decl),
Make_Identifier (Loc, Name_uO)),
Selector_Name =>
New_Occurrence_Of (Iface_Tag, Loc)),
Attribute_Name => Name_Address))));
@ -975,7 +963,7 @@ package body Exp_Disp is
Result_Definition =>
New_Reference_To (Etype (N), Loc)),
Declarations => Decls,
Declarations => New_List (New_Typ_Decl),
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc, Stats));
@ -991,20 +979,17 @@ package body Exp_Disp is
if Is_Access_Type (Etype (Expression (N))) then
-- Generate: Operand_Typ!(Expression.all)'Address
-- Generate: Func (Address!(Expression))
Rewrite (N,
Make_Function_Call (Loc,
Name => New_Reference_To (Fent, Loc),
Parameter_Associations => New_List (
Make_Attribute_Reference (Loc,
Prefix => Unchecked_Convert_To (Operand_Typ,
Make_Explicit_Dereference (Loc,
Relocate_Node (Expression (N)))),
Attribute_Name => Name_Address))));
Unchecked_Convert_To (RTE (RE_Address),
Relocate_Node (Expression (N))))));
else
-- Generate: Operand_Typ!(Expression)'Address
-- Generate: Func (Operand_Typ!(Expression)'Address)
Rewrite (N,
Make_Function_Call (Loc,
@ -1409,6 +1394,8 @@ package body Exp_Disp is
Make_Defining_Identifier (Loc,
Chars => New_Internal_Name ('T'));
Set_Is_Thunk (Thunk_Id);
if Ekind (Target) = E_Procedure then
Thunk_Code :=
Make_Subprogram_Body (Loc,
@ -3064,6 +3051,8 @@ package body Exp_Disp is
New_External_Name (Tname, 'T', Suffix_Index => -1);
Name_Exname : constant Name_Id :=
New_External_Name (Tname, 'E', Suffix_Index => -1);
Name_HT_Link : constant Name_Id :=
New_External_Name (Tname, 'H', Suffix_Index => -1);
Name_Predef_Prims : constant Name_Id :=
New_External_Name (Tname, 'R', Suffix_Index => -1);
Name_SSD : constant Name_Id :=
@ -3077,6 +3066,8 @@ package body Exp_Disp is
Make_Defining_Identifier (Loc, Name_DT);
Exname : constant Entity_Id :=
Make_Defining_Identifier (Loc, Name_Exname);
HT_Link : constant Entity_Id :=
Make_Defining_Identifier (Loc, Name_HT_Link);
Predef_Prims : constant Entity_Id :=
Make_Defining_Identifier (Loc, Name_Predef_Prims);
SSD : constant Entity_Id :=
@ -3213,6 +3204,7 @@ package body Exp_Disp is
Set_Is_Statically_Allocated (DT);
Set_Is_Statically_Allocated (SSD);
Set_Is_Statically_Allocated (TSD);
Set_Is_Statically_Allocated (Predef_Prims);
-- Generate code to define the boolean that controls registration, in
-- order to avoid multiple registrations for tagged types defined in
@ -3353,6 +3345,15 @@ package body Exp_Disp is
Set_Is_Statically_Allocated (Exname);
Set_Is_True_Constant (Exname);
-- Declare the object used by Ada.Tags.Register_Tag
if RTE_Available (RE_Register_Tag) then
Append_To (Result,
Make_Object_Declaration (Loc,
Defining_Identifier => HT_Link,
Object_Definition => New_Reference_To (RTE (RE_Tag), Loc)));
end if;
-- Generate code to create the storage for the type specific data object
-- with enough space to store the tags of the ancestors plus the tags
-- of all the implemented interfaces (as described in a-tags.adb).
@ -3362,7 +3363,7 @@ package body Exp_Disp is
-- Access_Level => Type_Access_Level (Typ),
-- Expanded_Name => Cstring_Ptr!(Exname'Address))
-- External_Tag => Cstring_Ptr!(Exname'Address))
-- HT_Link => null,
-- HT_Link => HT_Link'Address,
-- Transportable => <<boolean-value>>,
-- RC_Offset => <<integer-value>>,
-- [ Interfaces_Table => <<access-value>> ]
@ -3590,9 +3591,17 @@ package body Exp_Disp is
-- HT_Link
Append_To (TSD_Aggr_List,
Unchecked_Convert_To (RTE (RE_Tag),
New_Reference_To (RTE (RE_Null_Address), Loc)));
if RTE_Available (RE_Register_Tag) then
Append_To (TSD_Aggr_List,
Unchecked_Convert_To (RTE (RE_Tag_Ptr),
Make_Attribute_Reference (Loc,
Prefix => New_Reference_To (HT_Link, Loc),
Attribute_Name => Name_Address)));
else
Append_To (TSD_Aggr_List,
Unchecked_Convert_To (RTE (RE_Tag_Ptr),
New_Reference_To (RTE (RE_Null_Address), Loc)));
end if;
-- Transportable: Set for types that can be used in remote calls
-- with respect to E.4(18) legality rules.
@ -4734,9 +4743,7 @@ package body Exp_Disp is
-- Import the forward declaration of the Dispatch Table wrapper record
-- (Make_DT will take care of its exportation)
if Building_Static_DT (Typ)
and then not Is_CPP_Class (Typ)
then
if Building_Static_DT (Typ) then
DT := Make_Defining_Identifier (Loc,
New_External_Name (Tname, 'T'));
@ -4746,9 +4753,6 @@ package body Exp_Disp is
Set_Is_Imported (DT);
-- Set_Is_True_Constant (DT);
-- Why is the above commented out???
-- The scope must be set now to call Get_External_Name
Set_Scope (DT, Current_Scope);
@ -4840,6 +4844,7 @@ package body Exp_Disp is
end if;
Set_Is_True_Constant (DT_Ptr);
Set_Is_Statically_Allocated (DT_Ptr);
end if;
pragma Assert (No (Access_Disp_Table (Typ)));

4
gcc/ada/exp_disp.ads
View File

@ -164,6 +164,10 @@ package Exp_Disp is
-- Exp_Disp.Default_Prim_Op_Position - indirect use
-- Exp_Disp.Set_All_DT_Position - direct use
function Building_Static_DT (Typ : Entity_Id) return Boolean;
pragma Inline (Building_Static_DT);
-- Returns true when building statically allocated dispatch tables
procedure Build_Static_Dispatch_Tables (N : Node_Id);
-- N is a library level package declaration or package body. Build the
-- static dispatch table of the tagged types defined at library level. In

25
gcc/ada/sem_disp.adb
View File

@ -740,9 +740,27 @@ package body Sem_Disp is
Set_DT_Position (Subp, DT_Position (Old_Subp));
if not Restriction_Active (No_Dispatching_Calls) then
Register_Primitive (Sloc (Subp_Body),
Prim => Subp,
Ins_Nod => Subp_Body);
if Building_Static_DT (Tagged_Type) then
-- If the static dispatch table has not been
-- built then there is nothing else to do now;
-- otherwise we notify that we cannot build the
-- static dispatch table.
if Has_Dispatch_Table (Tagged_Type) then
Error_Msg_N
("overriding of& is too late for building" &
" static dispatch tables!", Subp);
Error_Msg_N
("\spec should appear immediately after" &
" the type!", Subp);
end if;
else
Register_Primitive (Sloc (Subp_Body),
Prim => Subp,
Ins_Nod => Subp_Body);
end if;
end if;
end if;
end if;
@ -789,6 +807,7 @@ package body Sem_Disp is
if Present (Old_Subp) then
Check_Subtype_Conformant (Subp, Old_Subp);
if (Chars (Subp) = Name_Initialize
or else Chars (Subp) = Name_Adjust
or else Chars (Subp) = Name_Finalize)

2
gcc/ada/trans.c
View File

@ -626,7 +626,7 @@ Identifier_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p)
Is_Aliased (gnat_temp));
if (!object || !parent_requires_lvalue)
gnu_result = DECL_INITIAL (gnu_result);
gnu_result = unshare_expr (DECL_INITIAL (gnu_result));
}
*gnu_result_type_p = gnu_result_type;