From: Javier Miranda Date: Wed, 26 Sep 2007 10:42:20 +0000 (+0200) Subject: a-tags.adb: X-Git-Url: http://review.tizen.org/git/?a=commitdiff_plain;h=6e818918f2c6dab5258d709562aad8a836feaa1f;p=platform%2Fupstream%2Fgcc.git a-tags.adb: 2007-09-26 Javier Miranda Eric Botcazou * 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) : 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 --- diff --git a/gcc/ada/a-tags.adb b/gcc/ada/a-tags.adb index 33f0be3..47e76ff 100644 --- a/gcc/ada/a-tags.adb +++ b/gcc/ada/a-tags.adb @@ -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; diff --git a/gcc/ada/a-tags.ads b/gcc/ada/a-tags.ads index a41ae9d..6630743 100644 --- a/gcc/ada/a-tags.ads +++ b/gcc/ada/a-tags.ads @@ -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); diff --git a/gcc/ada/decl.c b/gcc/ada/decl.c index c625afb..4a55947 100644 --- a/gcc/ada/decl.c +++ b/gcc/ada/decl.c @@ -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. */ diff --git a/gcc/ada/exp_disp.adb b/gcc/ada/exp_disp.adb index 2d663ba..54e08c6 100644 --- a/gcc/ada/exp_disp.adb +++ b/gcc/ada/exp_disp.adb @@ -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 => <>, -- RC_Offset => <>, -- [ Interfaces_Table => <> ] @@ -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))); diff --git a/gcc/ada/exp_disp.ads b/gcc/ada/exp_disp.ads index 99a275b..ee78c81 100644 --- a/gcc/ada/exp_disp.ads +++ b/gcc/ada/exp_disp.ads @@ -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 diff --git a/gcc/ada/sem_disp.adb b/gcc/ada/sem_disp.adb index 9862f7a..5924039 100644 --- a/gcc/ada/sem_disp.adb +++ b/gcc/ada/sem_disp.adb @@ -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) diff --git a/gcc/ada/trans.c b/gcc/ada/trans.c index e6f9ef8..36177e2 100644 --- a/gcc/ada/trans.c +++ b/gcc/ada/trans.c @@ -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;