diff options
Diffstat (limited to 'gcc')
| -rw-r--r-- | gcc/ada/a-tags.adb | 4 | ||||
| -rw-r--r-- | gcc/ada/a-tags.ads | 42 | ||||
| -rw-r--r-- | gcc/ada/decl.c | 25 | ||||
| -rw-r--r-- | gcc/ada/exp_disp.adb | 95 | ||||
| -rw-r--r-- | gcc/ada/exp_disp.ads | 4 | ||||
| -rw-r--r-- | gcc/ada/sem_disp.adb | 25 | ||||
| -rw-r--r-- | gcc/ada/trans.c | 2 |
7 files changed, 115 insertions, 82 deletions
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 => <<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))); 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; |