-- 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
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
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;
-- 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);
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)
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))
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;
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,
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));
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. */
-- 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.
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;
----------------------------------
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));
-- 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
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 =>
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),
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))));
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));
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,
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,
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 :=
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 :=
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
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).
-- 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>> ]
-- 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.
-- 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'));
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);
end if;
Set_Is_True_Constant (DT_Ptr);
+ Set_Is_Statically_Allocated (DT_Ptr);
end if;
pragma Assert (No (Access_Disp_Table (Typ)));
projects / platform / upstream / gcc.git / commitdiff