From 3d6efb77de361ca80a8988350863ef02499148ee Mon Sep 17 00:00:00 2001 From: Javier Miranda Date: Fri, 6 Apr 2007 11:17:23 +0200 Subject: [PATCH] a-tags.ads, a-tags.adb (Object_Specific_Data): Remove component Num_Prim_Ops. 2007-04-06 Javier Miranda * a-tags.ads, a-tags.adb (Object_Specific_Data): Remove component Num_Prim_Ops. (Set_Num_Prim_Ops): Removed. Remove all the assertions because all the routines of this package are inline always. (Get_Offset_Index): Add support to primary dispatch tables. Move the documentation about the dispatch table to a-tags.ads (Set_External_Tag): Removed (Inherit_TSD): Removed. (Interface_Data_Element, Interfaces_Array, Interface_Data): Declarations moved to a-tags.ads (Displace, IW_Membership, Inherit_TSD, Interface_Ancestor_Tags, Register_Interface_Tag, Set_Offset_To_Top): Update all the occurrences of the TSD field "Table" because this field has been renamed to "Ifaces_Table". (Inherit_CPP_DT): Removed. (K_Typeinfo, K_Offset_To_Top, K_Tagged_Kind, K_Signature, Cstring, Tag_Table, Type_Specific_Data, Dispatch_Table): These declarations have been moved to a-tags.ads (Check_Size): Removed. (Expanded_Name): Updated to get access to the new field of TSD containing the address of the expanded name. (Get_Access_Level/Set_Access_Level): Removed. (Get_Predefined_Prim_Op_Address): Removed. (Set_Predefined_Prim_Op_Address): Removed. (Get_Prim_Op_Address/Set_Prim_Op_Address): Removed. (Get_Remotely_Callable/Set_Remotely_Callable): Removed. (Set_Expanded_Name): Removed. (Inherit_DT): Removed. (Inherit_CPP_DT): Removed. (Set_RC_Offset): Removed. (Set_TSD): Removed. (Base_Address): New function that displaces "this" to point to the base of the object (that is, to point to the primary tag of the object). From-SVN: r123550 --- gcc/ada/a-tags.adb | 761 ++------------------------------------------- gcc/ada/a-tags.ads | 533 +++++++++++++++++-------------- 2 files changed, 339 insertions(+), 955 deletions(-) diff --git a/gcc/ada/a-tags.adb b/gcc/ada/a-tags.adb index a0697e818b9..556265ac2fa 100644 --- a/gcc/ada/a-tags.adb +++ b/gcc/ada/a-tags.adb @@ -41,185 +41,11 @@ pragma Elaborate_All (System.HTable); package body Ada.Tags is --- Structure of the GNAT Primary Dispatch Table - --- +----------------------+ --- | table of | --- : predefined primitive : --- | ops pointers | --- +----------------------+ --- | Signature | --- +----------------------+ --- | Tagged_Kind | --- +----------------------+ --- | Offset_To_Top | --- +----------------------+ --- | Typeinfo_Ptr/TSD_Ptr ---> Type Specific Data --- Tag ---> +----------------------+ +-------------------+ --- | table of | | inheritance depth | --- : primitive ops : +-------------------+ --- | pointers | | access level | --- +----------------------+ +-------------------+ --- | expanded name | --- +-------------------+ --- | external tag | --- +-------------------+ --- | hash table link | --- +-------------------+ --- | remotely callable | --- +-------------------+ --- | rec ctrler offset | --- +-------------------+ --- | num prim ops | --- +-------------------+ --- | Ifaces_Table_Ptr --> Interface Data --- +-------------------+ +------------+ --- Select Specific Data <---- SSD_Ptr | | table | --- +--------------------+ +-------------------+ : of : --- | table of primitive | | table of | | interfaces | --- : operation : : ancestor : +------------+ --- | kinds | | tags | --- +--------------------+ +-------------------+ --- | table of | --- : entry : --- | indices | --- +--------------------+ - --- Structure of the GNAT Secondary Dispatch Table - --- +-----------------------+ --- | table of | --- : predefined primitive : --- | ops pointers | --- +-----------------------+ --- | Signature | --- +-----------------------+ --- | Tagged_Kind | --- +-----------------------+ --- | Offset_To_Top | --- +-----------------------+ --- | OSD_Ptr |---> Object Specific Data --- Tag ---> +-----------------------+ +---------------+ --- | table of | | num prim ops | --- : primitive op : +---------------+ --- | thunk pointers | | table of | --- +-----------------------+ + primitive | --- | op offsets | --- +---------------+ - - ---------------------------------- - -- GNAT Dispatch Table Prologue -- - ---------------------------------- - - -- GNAT's Dispatch Table prologue contains several fields which are hidden - -- in order to preserve compatibility with C++. These fields are accessed - -- by address calculations performed in the following manner: - - -- Field : Field_Type := - -- (To_Address (Tag) - Sum_Of_Preceding_Field_Sizes).all; - - -- The bracketed subtraction shifts the pointer (Tag) from the table of - -- primitive operations (or thunks) to the field in question. Since the - -- result of the subtraction is an address, dereferencing it will obtain - -- the actual value of the field. - - -- Guidelines for addition of new hidden fields - - -- Define a Field_Type and Field_Type_Ptr (access to Field_Type) in - -- A-Tags.ads for the newly introduced field. - - -- Defined the size of the new field as a constant Field_Name_Size - - -- Introduce an Unchecked_Conversion from System.Address to - -- Field_Type_Ptr in A-Tags.ads. - - -- Define the specifications of Get_ and Set_ - -- in a-tags.ads. - - -- Update the GNAT Dispatch Table structure in a-tags.adb - - -- Provide bodies to the Get_ and Set_ routines. - -- The profile of a Get_ routine should resemble: - - -- function Get_ (T : Tag; ...) return Field_Type is - -- Field : constant System.Address := - -- To_Address (T) - ; - -- begin - -- pragma Assert (Check_Signature (T, )); - -- - - -- return To_Field_Type_Ptr (Field).all; - -- end Get_; - - -- The profile of a Set_ routine should resemble: - - -- procedure Set_ (T : Tag; ..., Value : Field_Type) is - -- Field : constant System.Address := - -- To_Address (T) - ; - -- begin - -- pragma Assert (Check_Signature (T, )); - -- - - -- To_Field_Type_Ptr (Field).all := Value; - -- end Set_; - - -- NOTE: For each field in the prologue which precedes the newly added - -- one, find and update its respective Sum_Of_Previous_Field_Sizes by - -- subtractind Field_Name_Size from it. Falure to do so will clobber the - -- previous prologue field. - - K_Typeinfo : constant SSE.Storage_Count := DT_Typeinfo_Ptr_Size; - - K_Offset_To_Top : constant SSE.Storage_Count := - K_Typeinfo + DT_Offset_To_Top_Size; - - K_Tagged_Kind : constant SSE.Storage_Count := - K_Offset_To_Top + DT_Tagged_Kind_Size; - - K_Signature : constant SSE.Storage_Count := - K_Tagged_Kind + DT_Signature_Size; - - subtype Cstring is String (Positive); - type Cstring_Ptr is access all Cstring; - - -- We suppress index checks because the declared size in the record below - -- is a dummy size of one (see below). - - type Tag_Table is array (Natural range <>) of Tag; - pragma Suppress_Initialization (Tag_Table); - pragma Suppress (Index_Check, On => Tag_Table); - - -- Declarations for the table of interfaces - - type Interface_Data_Element is record - Iface_Tag : Tag; - Static_Offset_To_Top : Boolean; - Offset_To_Top_Value : System.Storage_Elements.Storage_Offset; - Offset_To_Top_Func : System.Address; - end record; - -- If some ancestor of the tagged type has discriminants the field - -- Static_Offset_To_Top is False and the field Offset_To_Top_Func - -- is used to store the address of the function generated by the - -- expander which provides this value; otherwise Static_Offset_To_Top - -- is True and such value is stored in the Offset_To_Top_Value field. - - type Interfaces_Array is - array (Natural range <>) of Interface_Data_Element; - - type Interface_Data (Nb_Ifaces : Positive) is record - Table : Interfaces_Array (1 .. Nb_Ifaces); - end record; - - -- Object specific data types + -- Object specific data types (see description in a-tags.ads) type Object_Specific_Data_Array is array (Positive range <>) of Positive; type Object_Specific_Data (Nb_Prim : Positive) is record - Num_Prim_Ops : Natural; - -- Number of primitive operations of the dispatch table. This field is - -- used by the run-time check routines that are activated when the - -- run-time is compiled with assertions enabled. - OSD_Table : Object_Specific_Data_Array (1 .. Nb_Prim); -- Table used in secondary DT to reference their counterpart in the -- select specific data (in the TSD of the primary DT). This construct @@ -242,112 +68,6 @@ package body Ada.Tags is -- NOTE: Nb_Prim is the number of non-predefined primitive operations end record; - -- Type specific data types - - type Type_Specific_Data is record - Idepth : Natural; - -- Inheritance Depth Level: Used to implement the membership test - -- associated with single inheritance of tagged types in constant-time. - -- In addition it also indicates the size of the first table stored in - -- the Tags_Table component (see comment below). - - Access_Level : Natural; - -- Accessibility level required to give support to Ada 2005 nested type - -- extensions. This feature allows safe nested type extensions by - -- shifting the accessibility checks to certain operations, rather than - -- being enforced at the type declaration. In particular, by performing - -- run-time accessibility checks on class-wide allocators, class-wide - -- function return, and class-wide stream I/O, the danger of objects - -- outliving their type declaration can be eliminated (Ada 2005: AI-344) - - Expanded_Name : Cstring_Ptr; - External_Tag : Cstring_Ptr; - HT_Link : Tag; - -- Components used to give support to the Ada.Tags subprograms described - -- in ARM 3.9 - - Remotely_Callable : Boolean; - -- Used to check ARM E.4 (18) - - RC_Offset : SSE.Storage_Offset; - -- Controller Offset: Used to give support to tagged controlled objects - -- (see Get_Deep_Controller at s-finimp) - - Ifaces_Table_Ptr : System.Address; - -- Pointer to the table of interface tags. It is used to implement the - -- membership test associated with interfaces and also for backward - -- abstract interface type conversions (Ada 2005:AI-251) - - Num_Prim_Ops : Natural; - -- Number of primitive operations of the dispatch table. This field is - -- used for additional run-time checks when the run-time is compiled - -- with assertions enabled. - - SSD_Ptr : System.Address; - -- Pointer to a table of records used in dispatching selects. This - -- field has a meaningful value for all tagged types that implement - -- a limited, protected, synchronized or task interfaces and have - -- non-predefined primitive operations. - - Tags_Table : Tag_Table (0 .. 1); - -- The size of the Tags_Table array actually depends on the tagged type - -- to which it applies. The compiler ensures that has enough space to - -- store all the entries of the two tables phisically stored there: the - -- "table of ancestor tags" and the "table of interface tags". For this - -- purpose we are using the same mechanism as for the Prims_Ptr array in - -- the Dispatch_Table record. See comments below on Prims_Ptr for - -- further details. - end record; - - type Dispatch_Table is record - - -- According to the C++ ABI the components Offset_To_Top and - -- Typeinfo_Ptr are stored just "before" the dispatch table (that is, - -- the Prims_Ptr table), and they are referenced with negative offsets - -- referring to the base of the dispatch table. The _Tag (or the - -- VTable_Ptr in C++ terminology) must point to the base of the virtual - -- table, just after these components, to point to the Prims_Ptr table. - -- For this purpose the expander generates a Prims_Ptr table that has - -- enough space for these additional components, and generates code that - -- displaces the _Tag to point after these components. - - -- Signature : Signature_Kind; - -- Tagged_Kind : Tagged_Kind; - -- Offset_To_Top : Natural; - -- Typeinfo_Ptr : System.Address; - - Prims_Ptr : Address_Array (1 .. 1); - -- The size of the Prims_Ptr array actually depends on the tagged type - -- to which it applies. For each tagged type, the expander computes the - -- actual array size, allocates the Dispatch_Table record accordingly, - -- and generates code that displaces the base of the record after the - -- Typeinfo_Ptr component. For this reason the first two components have - -- been commented in the previous declaration. The access to these - -- components is done by means of local functions. - -- - -- To avoid the use of discriminants to define the actual size of the - -- dispatch table, we used to declare the tag as a pointer to a record - -- that contains an arbitrary array of addresses, using Positive as its - -- index. This ensures that there are never range checks when accessing - -- the dispatch table, but it prevents GDB from displaying tagged types - -- properly. A better approach is to declare this record type as holding - -- small number of addresses, and to explicitly suppress checks on it. - -- - -- Note that in both cases, this type is never allocated, and serves - -- only to declare the corresponding access type. - end record; - - type Signature_Type is - (Must_Be_Primary_DT, - Must_Be_Secondary_DT, - Must_Be_Primary_Or_Secondary_DT, - Must_Be_Interface, - Must_Be_Primary_Or_Interface); - -- Type of signature accepted by primitives in this package that are called - -- during the elaboration of tagged types. This type is used by the routine - -- Check_Signature that is called only when the run-time is compiled with - -- assertions enabled. - --------------------------------------------- -- Unchecked Conversions for String Fields -- --------------------------------------------- @@ -388,19 +108,6 @@ package body Ada.Tags is -- Local Subprograms -- ----------------------- - function Check_Signature (T : Tag; Kind : Signature_Type) return Boolean; - -- Check that the signature of T is valid and corresponds with the subset - -- specified by the signature Kind. - - function Check_Size - (Old_T : Tag; - New_T : Tag; - Entry_Count : Natural) return Boolean; - -- Verify that Old_T and New_T have at least Entry_Count entries - - function Get_Num_Prim_Ops (T : Tag) return Natural; - -- Retrieve the number of primitive operations in the dispatch table of T - function Is_Primary_DT (T : Tag) return Boolean; pragma Inline_Always (Is_Primary_DT); -- Given a tag returns True if it has the signature of a primary dispatch @@ -512,78 +219,6 @@ package body Ada.Tags is end HTable_Subprograms; - --------------------- - -- Check_Signature -- - --------------------- - - function Check_Signature (T : Tag; Kind : Signature_Type) return Boolean is - Signature : constant Storage_Offset_Ptr := - To_Storage_Offset_Ptr (To_Address (T) - K_Signature); - - Sig_Values : constant Signature_Values := - To_Signature_Values (Signature.all); - - Signature_Id : Signature_Kind; - - begin - if Sig_Values (1) /= Valid_Signature then - Signature_Id := Unknown; - - elsif Sig_Values (2) in Primary_DT .. Abstract_Interface then - Signature_Id := Sig_Values (2); - - else - Signature_Id := Unknown; - end if; - - case Signature_Id is - when Primary_DT => - if Kind = Must_Be_Secondary_DT - or else Kind = Must_Be_Interface - then - return False; - end if; - - when Secondary_DT => - if Kind = Must_Be_Primary_DT - or else Kind = Must_Be_Interface - then - return False; - end if; - - when Abstract_Interface => - if Kind = Must_Be_Primary_DT - or else Kind = Must_Be_Secondary_DT - or else Kind = Must_Be_Primary_Or_Secondary_DT - then - return False; - end if; - - when others => - return False; - - end case; - - return True; - end Check_Signature; - - ---------------- - -- Check_Size -- - ---------------- - - function Check_Size - (Old_T : Tag; - New_T : Tag; - Entry_Count : Natural) return Boolean - is - Max_Entries_Old : constant Natural := Get_Num_Prim_Ops (Old_T); - Max_Entries_New : constant Natural := Get_Num_Prim_Ops (New_T); - - begin - return Entry_Count <= Max_Entries_Old - and then Entry_Count <= Max_Entries_New; - end Check_Size; - ------------------- -- CW_Membership -- ------------------- @@ -607,12 +242,19 @@ package body Ada.Tags is function CW_Membership (Obj_Tag : Tag; Typ_Tag : Tag) return Boolean is Pos : Integer; begin - pragma Assert (Check_Signature (Obj_Tag, Must_Be_Primary_DT)); - pragma Assert (Check_Signature (Typ_Tag, Must_Be_Primary_DT)); Pos := TSD (Obj_Tag).Idepth - TSD (Typ_Tag).Idepth; return Pos >= 0 and then TSD (Obj_Tag).Tags_Table (Pos) = Typ_Tag; end CW_Membership; + ------------------ + -- Base_Address -- + ------------------ + + function Base_Address (This : System.Address) return System.Address is + begin + return This - Offset_To_Top (This); + end Base_Address; + -------------- -- Displace -- -------------- @@ -621,36 +263,26 @@ package body Ada.Tags is (This : System.Address; T : Tag) return System.Address is - Curr_DT : constant Tag := To_Tag_Ptr (This).all; Iface_Table : Interface_Data_Ptr; Obj_Base : System.Address; Obj_DT : Tag; Obj_TSD : Type_Specific_Data_Ptr; begin - pragma Assert - (Check_Signature (Curr_DT, Must_Be_Primary_Or_Secondary_DT)); - pragma Assert - (Check_Signature (T, Must_Be_Interface)); - Obj_Base := This - Offset_To_Top (This); Obj_DT := To_Tag_Ptr (Obj_Base).all; - - pragma Assert - (Check_Signature (Obj_DT, Must_Be_Primary_DT)); - Obj_TSD := TSD (Obj_DT); Iface_Table := To_Interface_Data_Ptr (Obj_TSD.Ifaces_Table_Ptr); if Iface_Table /= null then for Id in 1 .. Iface_Table.Nb_Ifaces loop - if Iface_Table.Table (Id).Iface_Tag = T then + if Iface_Table.Ifaces_Table (Id).Iface_Tag = T then -- Case of Static value of Offset_To_Top - if Iface_Table.Table (Id).Static_Offset_To_Top then - Obj_Base := - Obj_Base + Iface_Table.Table (Id).Offset_To_Top_Value; + if Iface_Table.Ifaces_Table (Id).Static_Offset_To_Top then + Obj_Base := Obj_Base + + Iface_Table.Ifaces_Table (Id).Offset_To_Top_Value; -- Otherwise we call the function generated by the expander -- to provide us with this value @@ -659,15 +291,11 @@ package body Ada.Tags is Obj_Base := Obj_Base + To_Offset_To_Top_Function_Ptr - (Iface_Table.Table (Id).Offset_To_Top_Func).all + (Iface_Table.Ifaces_Table (Id).Offset_To_Top_Func).all (Obj_Base); end if; Obj_DT := To_Tag_Ptr (Obj_Base).all; - - pragma Assert - (Check_Signature (Obj_DT, Must_Be_Secondary_DT)); - return Obj_Base; end if; end loop; @@ -700,7 +328,6 @@ package body Ada.Tags is -- that are contained in the dispatch table referenced by Obj'Tag. function IW_Membership (This : System.Address; T : Tag) return Boolean is - Curr_DT : constant Tag := To_Tag_Ptr (This).all; Iface_Table : Interface_Data_Ptr; Last_Id : Natural; Obj_Base : System.Address; @@ -708,19 +335,10 @@ package body Ada.Tags is Obj_TSD : Type_Specific_Data_Ptr; begin - pragma Assert - (Check_Signature (Curr_DT, Must_Be_Primary_Or_Secondary_DT)); - pragma Assert - (Check_Signature (T, Must_Be_Primary_Or_Interface)); - Obj_Base := This - Offset_To_Top (This); Obj_DT := To_Tag_Ptr (Obj_Base).all; - - pragma Assert - (Check_Signature (Obj_DT, Must_Be_Primary_DT)); - - Obj_TSD := TSD (Obj_DT); - Last_Id := Obj_TSD.Idepth; + Obj_TSD := TSD (Obj_DT); + Last_Id := Obj_TSD.Idepth; -- Look for the tag in the table of interfaces @@ -728,7 +346,7 @@ package body Ada.Tags is if Iface_Table /= null then for Id in 1 .. Iface_Table.Nb_Ifaces loop - if Iface_Table.Table (Id).Iface_Tag = T then + if Iface_Table.Ifaces_Table (Id).Iface_Tag = T then return True; end if; end loop; @@ -751,13 +369,9 @@ package body Ada.Tags is -------------------- function Descendant_Tag (External : String; Ancestor : Tag) return Tag is - Int_Tag : Tag; + Int_Tag : constant Tag := Internal_Tag (External); begin - pragma Assert (Check_Signature (Ancestor, Must_Be_Primary_DT)); - Int_Tag := Internal_Tag (External); - pragma Assert (Check_Signature (Int_Tag, Must_Be_Primary_DT)); - if not Is_Descendant_At_Same_Level (Int_Tag, Ancestor) then raise Tag_Error; end if; @@ -777,7 +391,6 @@ package body Ada.Tags is raise Tag_Error; end if; - pragma Assert (Check_Signature (T, Must_Be_Primary_Or_Interface)); Result := TSD (T).Expanded_Name; return Result (1 .. Length (Result)); end Expanded_Name; @@ -794,30 +407,16 @@ package body Ada.Tags is raise Tag_Error; end if; - pragma Assert (Check_Signature (T, Must_Be_Primary_Or_Interface)); Result := TSD (T).External_Tag; - return Result (1 .. Length (Result)); end External_Tag; - ---------------------- - -- Get_Access_Level -- - ---------------------- - - function Get_Access_Level (T : Tag) return Natural is - begin - pragma Assert (Check_Signature (T, Must_Be_Primary_DT)); - return TSD (T).Access_Level; - end Get_Access_Level; - --------------------- -- Get_Entry_Index -- --------------------- function Get_Entry_Index (T : Tag; Position : Positive) return Positive is begin - pragma Assert (Check_Signature (T, Must_Be_Primary_DT)); - pragma Assert (Position <= Get_Num_Prim_Ops (T)); return SSD (T).SSD_Table (Position).Index; end Get_Entry_Index; @@ -827,53 +426,9 @@ package body Ada.Tags is function Get_External_Tag (T : Tag) return System.Address is begin - pragma Assert (Check_Signature (T, Must_Be_Primary_DT)); return To_Address (TSD (T).External_Tag); end Get_External_Tag; - ---------------------- - -- Get_Num_Prim_Ops -- - ---------------------- - - function Get_Num_Prim_Ops (T : Tag) return Natural is - begin - pragma Assert (Check_Signature (T, Must_Be_Primary_Or_Secondary_DT)); - - if Is_Primary_DT (T) then - return TSD (T).Num_Prim_Ops; - else - return OSD (T).Num_Prim_Ops; - end if; - end Get_Num_Prim_Ops; - - -------------------------------- - -- Get_Predef_Prim_Op_Address -- - -------------------------------- - - function Get_Predefined_Prim_Op_Address - (T : Tag; - Position : Positive) return System.Address - is - begin - pragma Assert (Check_Signature (T, Must_Be_Primary_Or_Secondary_DT)); - pragma Assert (Position <= Default_Prim_Op_Count); - return Predefined_DT (T).Prims_Ptr (Position); - end Get_Predefined_Prim_Op_Address; - - ------------------------- - -- Get_Prim_Op_Address -- - ------------------------- - - function Get_Prim_Op_Address - (T : Tag; - Position : Positive) return System.Address - is - begin - pragma Assert (Check_Signature (T, Must_Be_Primary_Or_Secondary_DT)); - pragma Assert (Position <= Get_Num_Prim_Ops (T)); - return T.Prims_Ptr (Position); - end Get_Prim_Op_Address; - ---------------------- -- Get_Prim_Op_Kind -- ---------------------- @@ -883,8 +438,6 @@ package body Ada.Tags is Position : Positive) return Prim_Op_Kind is begin - pragma Assert (Check_Signature (T, Must_Be_Primary_DT)); - pragma Assert (Position <= Get_Num_Prim_Ops (T)); return SSD (T).SSD_Table (Position).Kind; end Get_Prim_Op_Kind; @@ -897,9 +450,11 @@ package body Ada.Tags is Position : Positive) return Positive is begin - pragma Assert (Check_Signature (T, Must_Be_Secondary_DT)); - pragma Assert (Position <= Get_Num_Prim_Ops (T)); - return OSD (T).OSD_Table (Position); + if Is_Primary_DT (T) then + return Position; + else + return OSD (T).OSD_Table (Position); + end if; end Get_Offset_Index; ------------------- @@ -908,20 +463,9 @@ package body Ada.Tags is function Get_RC_Offset (T : Tag) return SSE.Storage_Offset is begin - pragma Assert (Check_Signature (T, Must_Be_Primary_DT)); return TSD (T).RC_Offset; end Get_RC_Offset; - --------------------------- - -- Get_Remotely_Callable -- - --------------------------- - - function Get_Remotely_Callable (T : Tag) return Boolean is - begin - pragma Assert (Check_Signature (T, Must_Be_Primary_DT)); - return TSD (T).Remotely_Callable; - end Get_Remotely_Callable; - --------------------- -- Get_Tagged_Kind -- --------------------- @@ -930,113 +474,9 @@ package body Ada.Tags is Tagged_Kind_Ptr : constant System.Address := To_Address (T) - K_Tagged_Kind; begin - pragma Assert (Check_Signature (T, Must_Be_Primary_Or_Secondary_DT)); return To_Tagged_Kind_Ptr (Tagged_Kind_Ptr).all; end Get_Tagged_Kind; - -------------------- - -- Inherit_CPP_DT -- - -------------------- - - procedure Inherit_CPP_DT - (Old_T : Tag; - New_T : Tag; - Entry_Count : Natural) - is - begin - New_T.Prims_Ptr (1 .. Entry_Count) := Old_T.Prims_Ptr (1 .. Entry_Count); - end Inherit_CPP_DT; - - ---------------- - -- Inherit_DT -- - ---------------- - - procedure Inherit_DT (Old_T : Tag; New_T : Tag; Entry_Count : Natural) is - subtype All_Predefined_Prims is - Positive range 1 .. Default_Prim_Op_Count; - - begin - pragma Assert (Check_Signature (Old_T, Must_Be_Primary_Or_Secondary_DT)); - pragma Assert (Check_Signature (New_T, Must_Be_Primary_Or_Secondary_DT)); - pragma Assert (Check_Size (Old_T, New_T, Entry_Count)); - - if Old_T /= null then - - -- Inherit the primitives of the parent - - New_T.Prims_Ptr (1 .. Entry_Count) := - Old_T.Prims_Ptr (1 .. Entry_Count); - - -- Inherit the predefined primitives of the parent - - -- NOTE: In the following assignment we have to unactivate a warning - -- generated by the compiler because of the following declaration of - -- the Dispatch_Table: - - -- Prims_Ptr : Address_Array (1 .. 1); - - -- This is a dummy declaration that is expanded by the frontend to - -- the correct size of the dispatch table corresponding with each - -- tagged type. As a consequence, if we try to use a constant to - -- copy the predefined elements (ie. Prims_Ptr (1 .. 15) := ...) - -- the compiler generates a warning indicating that Constraint_Error - -- will be raised at run-time (which is not true in this specific - -- case). - - pragma Warnings (Off); - Predefined_DT (New_T).Prims_Ptr (All_Predefined_Prims) := - Predefined_DT (Old_T).Prims_Ptr (All_Predefined_Prims); - pragma Warnings (On); - end if; - end Inherit_DT; - - ----------------- - -- Inherit_TSD -- - ----------------- - - procedure Inherit_TSD (Old_Tag : Tag; New_Tag : Tag) is - New_TSD_Ptr : Type_Specific_Data_Ptr; - New_Iface_Table_Ptr : Interface_Data_Ptr; - Old_TSD_Ptr : Type_Specific_Data_Ptr; - Old_Iface_Table_Ptr : Interface_Data_Ptr; - - begin - pragma Assert (Check_Signature (New_Tag, Must_Be_Primary_Or_Interface)); - New_TSD_Ptr := TSD (New_Tag); - - if Old_Tag /= null then - pragma Assert - (Check_Signature (Old_Tag, Must_Be_Primary_Or_Interface)); - Old_TSD_Ptr := TSD (Old_Tag); - New_TSD_Ptr.Idepth := Old_TSD_Ptr.Idepth + 1; - - -- Copy the "table of ancestor tags" plus the "table of interfaces" - -- of the parent. - - New_TSD_Ptr.Tags_Table (1 .. New_TSD_Ptr.Idepth) := - Old_TSD_Ptr.Tags_Table (0 .. Old_TSD_Ptr.Idepth); - - -- Copy the table of interfaces of the parent - - if not System."=" (Old_TSD_Ptr.Ifaces_Table_Ptr, - System.Null_Address) - then - Old_Iface_Table_Ptr := - To_Interface_Data_Ptr (Old_TSD_Ptr.Ifaces_Table_Ptr); - New_Iface_Table_Ptr := - To_Interface_Data_Ptr (New_TSD_Ptr.Ifaces_Table_Ptr); - - New_Iface_Table_Ptr.Table (1 .. Old_Iface_Table_Ptr.Nb_Ifaces) := - Old_Iface_Table_Ptr.Table (1 .. Old_Iface_Table_Ptr.Nb_Ifaces); - end if; - - else - New_TSD_Ptr.Idepth := 0; - end if; - - New_TSD_Ptr.Tags_Table (0) := New_Tag; - end Inherit_TSD; - ----------------------------- -- Interface_Ancestor_Tags -- ----------------------------- @@ -1058,7 +498,7 @@ package body Ada.Tags is Table : Tag_Array (1 .. Iface_Table.Nb_Ifaces); begin for J in 1 .. Iface_Table.Nb_Ifaces loop - Table (J) := Iface_Table.Table (J).Iface_Tag; + Table (J) := Iface_Table.Ifaces_Table (J).Iface_Tag; end loop; return Table; @@ -1167,7 +607,6 @@ package body Ada.Tags is OSD_Ptr : constant Addr_Ptr := To_Addr_Ptr (To_Address (T) - K_Typeinfo); begin - pragma Assert (Check_Signature (T, Must_Be_Secondary_DT)); return To_Object_Specific_Data_Ptr (OSD_Ptr.all); end OSD; @@ -1194,7 +633,6 @@ package body Ada.Tags is -- Access to the _size primitive of the parent begin - pragma Assert (Check_Signature (T, Must_Be_Primary_DT)); Parent_Tag := TSD (T).Tags_Table (Parent_Slot); F := To_Acc_Size (Predefined_DT (Parent_Tag).Prims_Ptr (Size_Slot)); @@ -1213,8 +651,6 @@ package body Ada.Tags is raise Tag_Error; end if; - pragma Assert (Check_Signature (T, Must_Be_Primary_DT)); - -- The Parent_Tag of a root-level tagged type is defined to be No_Tag. -- The first entry in the Ancestors_Tags array will be null for such -- a type, but it's better to be explicit about returning No_Tag in @@ -1249,14 +685,9 @@ package body Ada.Tags is Iface_Table : Interface_Data_Ptr; begin - pragma Assert (Check_Signature (T, Must_Be_Primary_Or_Interface)); - pragma Assert (Check_Signature (Interface_T, Must_Be_Interface)); - New_T_TSD := TSD (T); Iface_Table := To_Interface_Data_Ptr (New_T_TSD.Ifaces_Table_Ptr); - - pragma Assert (Position <= Iface_Table.Nb_Ifaces); - Iface_Table.Table (Position).Iface_Tag := Interface_T; + Iface_Table.Ifaces_Table (Position).Iface_Tag := Interface_T; end Register_Interface_Tag; ------------------ @@ -1268,16 +699,6 @@ package body Ada.Tags is External_Tag_HTable.Set (T); end Register_Tag; - ---------------------- - -- Set_Access_Level -- - ---------------------- - - procedure Set_Access_Level (T : Tag; Value : Natural) is - begin - pragma Assert (Check_Signature (T, Must_Be_Primary_DT)); - TSD (T).Access_Level := Value; - end Set_Access_Level; - --------------------- -- Set_Entry_Index -- --------------------- @@ -1288,57 +709,18 @@ package body Ada.Tags is Value : Positive) is begin - pragma Assert (Check_Signature (T, Must_Be_Primary_DT)); - pragma Assert (Position <= Get_Num_Prim_Ops (T)); SSD (T).SSD_Table (Position).Index := Value; end Set_Entry_Index; - ----------------------- - -- Set_Expanded_Name -- - ----------------------- - - procedure Set_Expanded_Name (T : Tag; Value : System.Address) is - begin - pragma Assert - (Check_Signature (T, Must_Be_Primary_Or_Interface)); - TSD (T).Expanded_Name := To_Cstring_Ptr (Value); - end Set_Expanded_Name; - - ---------------------- - -- Set_External_Tag -- - ---------------------- - - procedure Set_External_Tag (T : Tag; Value : System.Address) is - begin - pragma Assert (Check_Signature (T, Must_Be_Primary_Or_Interface)); - TSD (T).External_Tag := To_Cstring_Ptr (Value); - end Set_External_Tag; - ------------------------- -- Set_Interface_Table -- ------------------------- procedure Set_Interface_Table (T : Tag; Value : System.Address) is begin - pragma Assert (Check_Signature (T, Must_Be_Primary_Or_Interface)); TSD (T).Ifaces_Table_Ptr := Value; end Set_Interface_Table; - ---------------------- - -- Set_Num_Prim_Ops -- - ---------------------- - - procedure Set_Num_Prim_Ops (T : Tag; Value : Natural) is - begin - pragma Assert (Check_Signature (T, Must_Be_Primary_Or_Secondary_DT)); - - if Is_Primary_DT (T) then - TSD (T).Num_Prim_Ops := Value; - else - OSD (T).Num_Prim_Ops := Value; - end if; - end Set_Num_Prim_Ops; - ---------------------- -- Set_Offset_Index -- ---------------------- @@ -1349,8 +731,6 @@ package body Ada.Tags is Value : Positive) is begin - pragma Assert (Check_Signature (T, Must_Be_Secondary_DT)); - pragma Assert (Position <= Get_Num_Prim_Ops (T)); OSD (T).OSD_Table (Position) := Value; end Set_Offset_Index; @@ -1373,10 +753,6 @@ package body Ada.Tags is Obj_TSD : Type_Specific_Data_Ptr; begin if System."=" (This, System.Null_Address) then - pragma Assert - (Check_Signature (Interface_T, Must_Be_Primary_DT)); - pragma Assert (Offset_Value = 0); - Offset_To_Top := To_Storage_Offset_Ptr (To_Address (Interface_T) - K_Offset_To_Top); Offset_To_Top.all := Offset_Value; @@ -1388,9 +764,6 @@ package body Ada.Tags is Prim_DT := To_Tag_Ptr (This).all; - pragma Assert - (Check_Signature (Prim_DT, Must_Be_Primary_DT)); - -- Save the offset to top field in the secondary dispatch table. if Offset_Value /= 0 then @@ -1399,9 +772,6 @@ package body Ada.Tags is Offset_To_Top := To_Storage_Offset_Ptr (To_Address (Sec_DT) - K_Offset_To_Top); - pragma Assert - (Check_Signature (Sec_DT, Must_Be_Secondary_DT)); - if Is_Static then Offset_To_Top.all := Offset_Value; else @@ -1420,13 +790,15 @@ package body Ada.Tags is if Iface_Table /= null then for Id in 1 .. Iface_Table.Nb_Ifaces loop - if Iface_Table.Table (Id).Iface_Tag = Interface_T then - Iface_Table.Table (Id).Static_Offset_To_Top := Is_Static; + if Iface_Table.Ifaces_Table (Id).Iface_Tag = Interface_T then + Iface_Table.Ifaces_Table (Id).Static_Offset_To_Top := Is_Static; if Is_Static then - Iface_Table.Table (Id).Offset_To_Top_Value := Offset_Value; + Iface_Table.Ifaces_Table (Id).Offset_To_Top_Value + := Offset_Value; else - Iface_Table.Table (Id).Offset_To_Top_Func := Offset_Func; + Iface_Table.Ifaces_Table (Id).Offset_To_Top_Func + := Offset_Func; end if; return; @@ -1447,40 +819,9 @@ package body Ada.Tags is OSD_Ptr : constant Addr_Ptr := To_Addr_Ptr (To_Address (T) - K_Typeinfo); begin - pragma Assert (Check_Signature (T, Must_Be_Secondary_DT)); OSD_Ptr.all := Value; end Set_OSD; - ------------------------------------ - -- Set_Predefined_Prim_Op_Address -- - ------------------------------------ - - procedure Set_Predefined_Prim_Op_Address - (T : Tag; - Position : Positive; - Value : System.Address) - is - begin - pragma Assert (Check_Signature (T, Must_Be_Primary_Or_Secondary_DT)); - pragma Assert (Position >= 1 and then Position <= Default_Prim_Op_Count); - Predefined_DT (T).Prims_Ptr (Position) := Value; - end Set_Predefined_Prim_Op_Address; - - ------------------------- - -- Set_Prim_Op_Address -- - ------------------------- - - procedure Set_Prim_Op_Address - (T : Tag; - Position : Positive; - Value : System.Address) - is - begin - pragma Assert (Check_Signature (T, Must_Be_Primary_Or_Secondary_DT)); - pragma Assert (Position <= Get_Num_Prim_Ops (T)); - T.Prims_Ptr (Position) := Value; - end Set_Prim_Op_Address; - ---------------------- -- Set_Prim_Op_Kind -- ---------------------- @@ -1491,31 +832,9 @@ package body Ada.Tags is Value : Prim_Op_Kind) is begin - pragma Assert (Check_Signature (T, Must_Be_Primary_DT)); - pragma Assert (Position <= Get_Num_Prim_Ops (T)); SSD (T).SSD_Table (Position).Kind := Value; end Set_Prim_Op_Kind; - ------------------- - -- Set_RC_Offset -- - ------------------- - - procedure Set_RC_Offset (T : Tag; Value : SSE.Storage_Offset) is - begin - pragma Assert (Check_Signature (T, Must_Be_Primary_DT)); - TSD (T).RC_Offset := Value; - end Set_RC_Offset; - - --------------------------- - -- Set_Remotely_Callable -- - --------------------------- - - procedure Set_Remotely_Callable (T : Tag; Value : Boolean) is - begin - pragma Assert (Check_Signature (T, Must_Be_Primary_DT)); - TSD (T).Remotely_Callable := Value; - end Set_Remotely_Callable; - ------------------- -- Set_Signature -- ------------------- @@ -1535,7 +854,6 @@ package body Ada.Tags is procedure Set_SSD (T : Tag; Value : System.Address) is begin - pragma Assert (Check_Signature (T, Must_Be_Primary_DT)); TSD (T).SSD_Ptr := Value; end Set_SSD; @@ -1547,29 +865,15 @@ package body Ada.Tags is Tagged_Kind_Ptr : constant System.Address := To_Address (T) - K_Tagged_Kind; begin - pragma Assert (Check_Signature (T, Must_Be_Primary_Or_Secondary_DT)); To_Tagged_Kind_Ptr (Tagged_Kind_Ptr).all := Value; end Set_Tagged_Kind; - ------------- - -- Set_TSD -- - ------------- - - procedure Set_TSD (T : Tag; Value : System.Address) is - TSD_Ptr : Addr_Ptr; - begin - pragma Assert (Check_Signature (T, Must_Be_Primary_Or_Interface)); - TSD_Ptr := To_Addr_Ptr (To_Address (T) - K_Typeinfo); - TSD_Ptr.all := Value; - end Set_TSD; - --------- -- SSD -- --------- function SSD (T : Tag) return Select_Specific_Data_Ptr is begin - pragma Assert (Check_Signature (T, Must_Be_Primary_DT)); return To_Select_Specific_Data_Ptr (TSD (T).SSD_Ptr); end SSD; @@ -1592,7 +896,6 @@ package body Ada.Tags is TSD_Ptr : constant Addr_Ptr := To_Addr_Ptr (To_Address (T) - K_Typeinfo); begin - pragma Assert (Check_Signature (T, Must_Be_Primary_Or_Interface)); return To_Type_Specific_Data_Ptr (TSD_Ptr.all); end TSD; diff --git a/gcc/ada/a-tags.ads b/gcc/ada/a-tags.ads index 24fedab7ff8..bc39cd509e2 100644 --- a/gcc/ada/a-tags.ads +++ b/gcc/ada/a-tags.ads @@ -81,40 +81,213 @@ package Ada.Tags is Tag_Error : exception; private - -- The following subprogram specifications are placed here instead of - -- the package body to see them from the frontend through rtsfind. - - --------------------------------------------------------------- - -- Abstract Procedural Interface For The GNAT Dispatch Table -- - --------------------------------------------------------------- - - -- GNAT's Dispatch Table format is customizable in order to match the - -- format used in another language. GNAT supports programs that use two - -- different dispatch table formats at the same time: the native format - -- that supports Ada 95 tagged types and which is described in Ada.Tags, - -- and a foreign format for types that are imported from some other - -- language (typically C++) which is described in Interfaces.CPP. The - -- runtime information kept for each tagged type is separated into two + -- Structure of the GNAT Primary Dispatch Table + + -- +--------------------+ + -- | table of | + -- :predefined primitive: + -- | ops pointers | + -- +--------------------+ + -- | Signature | + -- +--------------------+ + -- | Tagged_Kind | + -- +--------------------+ + -- | Offset_To_Top | + -- +--------------------+ + -- |Typeinfo_Ptr/TSD_Ptr---> Type Specific Data + -- Tag ---> +--------------------+ +-------------------+ + -- | table of | | inheritance depth | + -- : primitive ops : +-------------------+ + -- | pointers | | access level | + -- +--------------------+ +-------------------+ + -- | expanded name | + -- +-------------------+ + -- | external tag | + -- +-------------------+ + -- | hash table link | + -- +-------------------+ + -- | remotely callable | + -- +-------------------+ + -- | rec ctrler offset | + -- +-------------------+ + -- | num prim ops | + -- +-------------------+ + -- | Ifaces_Table_Ptr --> Interface Data + -- +-------------------+ +------------+ + -- Select Specific Data <---- SSD_Ptr | | table | + -- +------------------+ +-------------------+ : of : + -- |table of primitive| | table of | | interfaces | + -- : operation : : ancestor : +------------+ + -- | kinds | | tags | + -- +------------------+ +-------------------+ + -- |table of | + -- : entry : + -- | indices | + -- +------------------+ + + -- Structure of the GNAT Secondary Dispatch Table + + -- +-----------------------+ + -- | table of | + -- : predefined primitive : + -- | ops pointers | + -- +-----------------------+ + -- | Signature | + -- +-----------------------+ + -- | Tagged_Kind | + -- +-----------------------+ + -- | Offset_To_Top | + -- +-----------------------+ + -- | OSD_Ptr |---> Object Specific Data + -- Tag ---> +-----------------------+ +---------------+ + -- | table of | | num prim ops | + -- : primitive op : +---------------+ + -- | thunk pointers | | table of | + -- +-----------------------+ + primitive | + -- | op offsets | + -- +---------------+ + + -- The runtime information kept for each tagged type is separated into two -- objects: the Dispatch Table and the Type Specific Data record. These -- two objects are allocated statically using the constants: -- DT Size = DT_Prologue_Size + Nb_Prim * DT_Entry_Size - -- TSD Size = TSD_Prologue_Size + (1 + Idepth) * TSD_Entry_Size -- where Nb_prim is the number of primitive operations of the given -- type and Idepth its inheritance depth. - -- In order to set or retrieve information from the Dispatch Table or - -- the Type Specific Data record, GNAT generates calls to Set_XXX or - -- Get_XXX routines, where XXX is the name of the field of interest. + type Address_Array is array (Natural range <>) of System.Address; + pragma Suppress (Index_Check, On => Address_Array); + -- The reason we suppress index checks is that in the dispatch table, + -- the component of this type is declared with a dummy size of 1, the + -- actual size depending on the number of primitive operations. + + type Dispatch_Table is record + + -- According to the C++ ABI the components Offset_To_Top and + -- Typeinfo_Ptr are stored just "before" the dispatch table (that is, + -- the Prims_Ptr table), and they are referenced with negative offsets + -- referring to the base of the dispatch table. The _Tag (or the + -- VTable_Ptr in C++ terminology) must point to the base of the virtual + -- table, just after these components, to point to the Prims_Ptr table. + -- For this purpose the expander generates a Prims_Ptr table that has + -- enough space for these additional components, and generates code that + -- displaces the _Tag to point after these components. + + -- Signature : Signature_Kind; + -- Tagged_Kind : Tagged_Kind; + -- Offset_To_Top : Natural; + -- Typeinfo_Ptr : System.Address; + + Prims_Ptr : Address_Array (1 .. 1); + -- The size of the Prims_Ptr array actually depends on the tagged type + -- to which it applies. For each tagged type, the expander computes the + -- actual array size, allocates the Dispatch_Table record accordingly, + -- and generates code that displaces the base of the record after the + -- Typeinfo_Ptr component. For this reason the first two components have + -- been commented in the previous declaration. The access to these + -- components is done by means of local functions. + -- + -- To avoid the use of discriminants to define the actual size of the + -- dispatch table, we used to declare the tag as a pointer to a record + -- that contains an arbitrary array of addresses, using Positive as its + -- index. This ensures that there are never range checks when accessing + -- the dispatch table, but it prevents GDB from displaying tagged types + -- properly. A better approach is to declare this record type as holding + -- small number of addresses, and to explicitly suppress checks on it. + -- + -- Note that in both cases, this type is never allocated, and serves + -- only to declare the corresponding access type. + end record; + + subtype Cstring is String (Positive); + type Cstring_Ptr is access all Cstring; + pragma No_Strict_Aliasing (Cstring_Ptr); + + -- We suppress index checks because the declared size in the record below + -- is a dummy size of one (see below). + + type Tag_Table is array (Natural range <>) of Tag; + pragma Suppress_Initialization (Tag_Table); + pragma Suppress (Index_Check, On => Tag_Table); + + package SSE renames System.Storage_Elements; + + -- Type specific data types + + type Type_Specific_Data (Idepth : Natural) is record + -- Inheritance Depth Level: Used to implement the membership test + -- associated with single inheritance of tagged types in constant-time. + -- It also indicates the size of the Tags_Table component. + + Access_Level : Natural; + -- Accessibility level required to give support to Ada 2005 nested type + -- extensions. This feature allows safe nested type extensions by + -- shifting the accessibility checks to certain operations, rather than + -- being enforced at the type declaration. In particular, by performing + -- run-time accessibility checks on class-wide allocators, class-wide + -- function return, and class-wide stream I/O, the danger of objects + -- outliving their type declaration can be eliminated (Ada 2005: AI-344) + + Expanded_Name : Cstring_Ptr; + External_Tag : Cstring_Ptr; + HT_Link : Tag; + -- Components used to support to the Ada.Tags subprograms in RM 3.9. + -- Note: Expanded_Name is referenced by GDB ??? + + Remotely_Callable : Boolean; + -- Used to check ARM E.4 (18) + + RC_Offset : SSE.Storage_Offset; + -- Controller Offset: Used to give support to tagged controlled objects + -- (see Get_Deep_Controller at s-finimp) + + Ifaces_Table_Ptr : System.Address; + -- Pointer to the table of interface tags. It is used to implement the + -- membership test associated with interfaces and also for backward + -- abstract interface type conversions (Ada 2005:AI-251) + + SSD_Ptr : System.Address; + -- Pointer to a table of records used in dispatching selects. This + -- field has a meaningful value for all tagged types that implement + -- a limited, protected, synchronized or task interfaces and have + -- non-predefined primitive operations. + + Tags_Table : Tag_Table (0 .. Idepth); + -- Table of ancestor tags. Its size actually depends on the inheritance + -- depth level of the tagged type. + end record; + + -- Declarations for the table of interfaces + + type Interface_Data_Element is record + Iface_Tag : Tag; + Static_Offset_To_Top : Boolean; + Offset_To_Top_Value : System.Storage_Elements.Storage_Offset; + Offset_To_Top_Func : System.Address; + end record; + -- If some ancestor of the tagged type has discriminants the field + -- Static_Offset_To_Top is False and the field Offset_To_Top_Func + -- is used to store the address of the function generated by the + -- expander which provides this value; otherwise Static_Offset_To_Top + -- is True and such value is stored in the Offset_To_Top_Value field. + + type Interfaces_Array is + array (Natural range <>) of Interface_Data_Element; + + type Interface_Data (Nb_Ifaces : Positive) is record + Ifaces_Table : Interfaces_Array (1 .. Nb_Ifaces); + end record; + + -- Declaration of tag types - type Dispatch_Table; type Tag is access all Dispatch_Table; + type Tag_Ptr is access Tag; type Interface_Tag is access all Dispatch_Table; + type Type_Specific_Data_Ptr is access all Type_Specific_Data; No_Tag : constant Tag := null; - type Interface_Data (Nb_Ifaces : Positive); type Interface_Data_Ptr is access all Interface_Data; -- Table of abstract interfaces used to give support to backward interface -- conversions and also to IW_Membership. @@ -132,9 +305,6 @@ private -- type. This construct is used in the handling of dispatching triggers -- in select statements. - type Type_Specific_Data; - type Type_Specific_Data_Ptr is access all Type_Specific_Data; - -- Primitive operation kinds. These values differentiate the kinds of -- callable entities stored in the dispatch table. Certain kinds may -- not be used, but are added for completeness. @@ -162,8 +332,7 @@ private type Tagged_Kind_Ptr is access all Tagged_Kind; Default_Prim_Op_Count : constant Positive := 15; - -- Number of predefined primitive operations added by the Expander for a - -- tagged type (must match Exp_Disp.Default_Prim_Op_Count). + -- Maximum number of predefined primitive operations of a tagged type. type Signature_Kind is (Unknown, @@ -183,68 +352,101 @@ private -- range Primary_DT .. Abstract_Interface. The Unknown value is used by -- the Check_XXX routines to indicate that the signature is wrong. - package SSE renames System.Storage_Elements; + DT_Min_Prologue_Size : constant SSE.Storage_Count := + SSE.Storage_Count + (2 * (Standard'Address_Size / + System.Storage_Unit)); + -- Size of the hidden part of the dispatch table used when the program + -- is compiled under restriction No_Dispatching_Calls. It contains the + -- pointer to the TSD record plus a dummy entry whose address is used + -- at run-time as the Tag. + + DT_Prologue_Size : constant SSE.Storage_Count := + SSE.Storage_Count + ((Default_Prim_Op_Count + 4) * + (Standard'Address_Size / System.Storage_Unit)); + -- Size of the hidden part of the dispatch table. It contains the table of + -- predefined primitive operations plus the C++ ABI header. + + DT_Signature_Size : constant SSE.Storage_Count := + SSE.Storage_Count + (1 * (Standard'Address_Size / System.Storage_Unit)); + -- Size of the Signature field of the dispatch table + + DT_Tagged_Kind_Size : constant SSE.Storage_Count := + SSE.Storage_Count (1 * (Standard'Address_Size / System.Storage_Unit)); + -- Size of the Tagged_Type_Kind field of the dispatch table + + DT_Offset_To_Top_Size : constant SSE.Storage_Count := + SSE.Storage_Count + (1 * (Standard'Address_Size / + System.Storage_Unit)); + -- Size of the Offset_To_Top field of the Dispatch Table + + DT_Typeinfo_Ptr_Size : constant SSE.Storage_Count := + SSE.Storage_Count + (1 * (Standard'Address_Size / + System.Storage_Unit)); + -- Size of the Typeinfo_Ptr field of the Dispatch Table + + DT_Entry_Size : constant SSE.Storage_Count := + SSE.Storage_Count + (1 * (Standard'Address_Size / System.Storage_Unit)); + -- Size of each primitive operation entry in the Dispatch Table + + Tag_Size : constant SSE.Storage_Count := + SSE.Storage_Count (1 * (Standard'Address_Size / System.Storage_Unit)); + -- Size of each tag + + -- Constants used by the code generated by the frontend to get access + -- to the header of the dispatch table. + + K_Typeinfo : constant SSE.Storage_Count := DT_Typeinfo_Ptr_Size; + K_Offset_To_Top : constant SSE.Storage_Count := + System.Storage_Elements."+" + (K_Typeinfo, DT_Offset_To_Top_Size); + K_Tagged_Kind : constant SSE.Storage_Count := + System.Storage_Elements."+" + (K_Offset_To_Top, DT_Tagged_Kind_Size); + K_Signature : constant SSE.Storage_Count := + System.Storage_Elements."+" + (K_Tagged_Kind, DT_Signature_Size); + + -- The following subprogram specifications are placed here instead of + -- the package body to see them from the frontend through rtsfind. + + function Base_Address (This : System.Address) return System.Address; + -- Ada 2005 (AI-251): Displace "This" to point to the base address of + -- the object (that is, the address of the primary tag of the object). function CW_Membership (Obj_Tag : Tag; Typ_Tag : Tag) return Boolean; -- Given the tag of an object and the tag associated to a type, return -- true if Obj is in Typ'Class. - function IW_Membership (This : System.Address; T : Tag) return Boolean; - -- Ada 2005 (AI-251): General routine that checks if a given object - -- implements a tagged type. Its common usage is to check if Obj is in - -- Iface'Class, but it is also used to check if a class-wide interface - -- implements a given type (Iface_CW_Typ in T'Class). For example: - -- - -- type I is interface; - -- type T is tagged ... - -- - -- function Test (O : I'Class) is - -- begin - -- return O in T'Class. - -- end Test; - function Displace (This : System.Address; T : Tag) return System.Address; - -- (Ada 2005 (AI-251): Displace "This" to point to the secondary dispatch + -- Ada 2005 (AI-251): Displace "This" to point to the secondary dispatch -- table of T. - function Get_Access_Level (T : Tag) return Natural; - -- Given the tag associated with a type, returns the accessibility level - -- of the type. - function Get_Entry_Index (T : Tag; Position : Positive) return Positive; - -- Return a primitive operation's entry index (if entry) given a dispatch - -- table T and a position of a primitive operation in T. + -- Ada 2005 (AI-251): Return a primitive operation's entry index (if entry) + -- given a dispatch table T and a position of a primitive operation in T. function Get_External_Tag (T : Tag) return System.Address; - -- Retrieve the address of a null terminated string containing - -- the external name. + -- Returns address of a null terminated string containing the external name function Get_Offset_Index (T : Tag; Position : Positive) return Positive; - -- Given a pointer to a secondary dispatch table (T) and a position of an - -- operation in the DT, retrieve the corresponding operation's position in - -- the primary dispatch table from the Offset Specific Data table of T. - - function Get_Predefined_Prim_Op_Address - (T : Tag; - Position : Positive) return System.Address; - -- Given a pointer to a dispatch table (T) and a position in the DT - -- this function returns the address of the virtual function stored - -- in it (used for dispatching calls). - - function Get_Prim_Op_Address - (T : Tag; - Position : Positive) return System.Address; - -- Given a pointer to a dispatch table (T) and a position in the DT - -- this function returns the address of the virtual function stored - -- in it (used for dispatching calls). + -- Ada 2005 (AI-251): Given a pointer to a secondary dispatch table (T) and + -- a position of an operation in the DT, retrieve the corresponding + -- operation's position in the primary dispatch table from the Offset + -- Specific Data table of T. function Get_Prim_Op_Kind (T : Tag; Position : Positive) return Prim_Op_Kind; - -- Return a primitive operation's kind given a dispatch table T and a - -- position of a primitive operation in T. + -- Ada 2005 (AI-251): Return a primitive operation's kind given a dispatch + -- table T and a position of a primitive operation in T. function Get_RC_Offset (T : Tag) return SSE.Storage_Offset; -- Return the Offset of the implicit record controller when the object @@ -255,37 +457,35 @@ private -- it is exported manually in order to avoid changing completely the -- organization of the run time. - function Get_Remotely_Callable (T : Tag) return Boolean; - -- Return the value previously set by Set_Remotely_Callable - function Get_Tagged_Kind (T : Tag) return Tagged_Kind; - -- Given a pointer to either a primary or a secondary dispatch table, - -- return the tagged kind of a type in the context of concurrency and - -- limitedness. - - procedure Inherit_CPP_DT (Old_T : Tag; New_T : Tag; Entry_Count : Natural); - -- Entry point used to initialize the DT of a type knowing the tag - -- of the direct CPP ancestor and the number of primitive ops that - -- are inherited (Entry_Count). - - procedure Inherit_DT (Old_T : Tag; New_T : Tag; Entry_Count : Natural); - -- Entry point used to initialize the DT of a type knowing the tag - -- of the direct ancestor and the number of primitive ops that are - -- inherited (Entry_Count). + -- Ada 2005 (AI-345): Given a pointer to either a primary or a secondary + -- dispatch table, return the tagged kind of a type in the context of + -- concurrency and limitedness. - procedure Inherit_TSD (Old_Tag : Tag; New_Tag : Tag); - -- Initialize the TSD of a type knowing the tag of the direct ancestor + function IW_Membership (This : System.Address; T : Tag) return Boolean; + -- Ada 2005 (AI-251): General routine that checks if a given object + -- implements a tagged type. Its common usage is to check if Obj is in + -- Iface'Class, but it is also used to check if a class-wide interface + -- implements a given type (Iface_CW_Typ in T'Class). For example: + -- + -- type I is interface; + -- type T is tagged ... + -- + -- function Test (O : I'Class) is + -- begin + -- return O in T'Class. + -- end Test; function Offset_To_Top (This : System.Address) return System.Storage_Elements.Storage_Offset; - -- Returns the current value of the offset_to_top component available in - -- the prologue of the dispatch table. If the parent of the tagged type - -- has discriminants this value is stored in a record component just - -- immediately after the tag component. + -- Ada 2005 (AI-251): Returns the current value of the offset_to_top + -- component available in the prologue of the dispatch table. If the parent + -- of the tagged type has discriminants this value is stored in a record + -- component just immediately after the tag component. function OSD (T : Tag) return Object_Specific_Data_Ptr; -- Ada 2005 (AI-251): Given a pointer T to a secondary dispatch table, - -- retrieve the address of the record containing the Objet Specific + -- retrieve the address of the record containing the Object Specific -- Data table. function Parent_Size @@ -311,36 +511,20 @@ private -- Insert the Tag and its associated external_tag in a table for the -- sake of Internal_Tag - procedure Set_Access_Level (T : Tag; Value : Natural); - -- Sets the accessibility level of the tagged type associated with T - -- in its TSD. - procedure Set_Entry_Index (T : Tag; Position : Positive; Value : Positive); - -- Set the entry index of a primitive operation in T's TSD table indexed - -- by Position. - - procedure Set_Expanded_Name (T : Tag; Value : System.Address); - -- Set the address of the string containing the expanded name - -- in the Dispatch table. - - procedure Set_External_Tag (T : Tag; Value : System.Address); - -- Set the address of the string containing the external tag - -- in the Dispatch table. + -- Ada 2005 (AI-345): Set the entry index of a primitive operation in T's + -- TSD table indexed by Position. procedure Set_Interface_Table (T : Tag; Value : System.Address); -- Ada 2005 (AI-251): Given a pointer T to a dispatch Table, stores the -- pointer to the table of interfaces. - procedure Set_Num_Prim_Ops (T : Tag; Value : Natural); - -- Set the number of primitive operations in the dispatch table of T. This - -- is used for debugging purposes. - procedure Set_Offset_Index (T : Tag; Position : Positive; Value : Positive); - -- Set the offset value of a primitive operation in a secondary dispatch - -- table denoted by T, indexed by Position. + -- Ada 2005 (AI-345): Set the offset value of a primitive operation in a + -- secondary dispatch table denoted by T, indexed by Position. procedure Set_Offset_To_Top (This : System.Address; @@ -358,121 +542,40 @@ private -- secondary dispatch table. procedure Set_OSD (T : Tag; Value : System.Address); - -- Given a pointer T to a secondary dispatch table, store the pointer to - -- the record containing the Object Specific Data generated by GNAT. - - procedure Set_Predefined_Prim_Op_Address - (T : Tag; - Position : Positive; - Value : System.Address); - -- Given a pointer to a dispatch Table (T) and a position in the dispatch - -- table associated with a predefined primitive operation, put the address - -- of the virtual function in it (used for overriding). - - procedure Set_Prim_Op_Address - (T : Tag; - Position : Positive; - Value : System.Address); - -- Given a pointer to a dispatch Table (T) and a position in the dispatch - -- Table put the address of the virtual function in it (used for - -- overriding). + -- Ada 2005 (AI-251): Given a pointer T to a secondary dispatch table, + -- store the pointer to the record containing the Object Specific Data + -- generated by GNAT. procedure Set_Prim_Op_Kind (T : Tag; Position : Positive; Value : Prim_Op_Kind); - -- Set the kind of a primitive operation in T's TSD table indexed by - -- Position. - - procedure Set_RC_Offset (T : Tag; Value : SSE.Storage_Offset); - -- Sets the Offset of the implicit record controller when the object - -- has controlled components. Set to O otherwise. - - procedure Set_Remotely_Callable (T : Tag; Value : Boolean); - -- Set to true if the type has been declared in a context described - -- in E.4 (18). + -- Ada 2005 (AI-251): Set the kind of a primitive operation in T's TSD + -- table indexed by Position. procedure Set_Signature (T : Tag; Value : Signature_Kind); -- Given a pointer T to a dispatch table, store the signature id procedure Set_SSD (T : Tag; Value : System.Address); - -- Given a pointer T to a dispatch Table, stores the pointer to the record - -- containing the Select Specific Data generated by GNAT. + -- Ada 2005 (AI-345): Given a pointer T to a dispatch Table, stores the + -- pointer to the record containing the Select Specific Data generated by + -- GNAT. procedure Set_Tagged_Kind (T : Tag; Value : Tagged_Kind); - -- Set the tagged kind of a type in either a primary or a secondary - -- dispatch table denoted by T. - - procedure Set_TSD (T : Tag; Value : System.Address); - -- Given a pointer T to a dispatch Table, stores the address of the record - -- containing the Type Specific Data generated by GNAT. + -- Ada 2005 (AI-345): Set the tagged kind of a type in either a primary or + -- a secondary dispatch table denoted by T. function SSD (T : Tag) return Select_Specific_Data_Ptr; - -- Given a pointer T to a dispatch Table, retrieves the address of the - -- record containing the Select Specific Data in T's TSD. + -- Ada 2005 (AI-251): Given a pointer T to a dispatch Table, retrieves the + -- address of the record containing the Select Specific Data in T's TSD. function TSD (T : Tag) return Type_Specific_Data_Ptr; -- Given a pointer T to a dispatch Table, retrieves the address of the -- record containing the Type Specific Data generated by GNAT. - DT_Prologue_Size : constant SSE.Storage_Count := - SSE.Storage_Count - ((Default_Prim_Op_Count + 4) * - (Standard'Address_Size / System.Storage_Unit)); - -- Size of the hidden part of the dispatch table. It contains the table of - -- predefined primitive operations plus the C++ ABI header. - - DT_Signature_Size : constant SSE.Storage_Count := - SSE.Storage_Count - (1 * (Standard'Address_Size / System.Storage_Unit)); - -- Size of the Signature field of the dispatch table - - DT_Tagged_Kind_Size : constant SSE.Storage_Count := - SSE.Storage_Count (1 * (Standard'Address_Size / System.Storage_Unit)); - -- Size of the Tagged_Type_Kind field of the dispatch table - - DT_Offset_To_Top_Size : constant SSE.Storage_Count := - SSE.Storage_Count - (1 * (Standard'Address_Size / - System.Storage_Unit)); - -- Size of the Offset_To_Top field of the Dispatch Table - - DT_Typeinfo_Ptr_Size : constant SSE.Storage_Count := - SSE.Storage_Count - (1 * (Standard'Address_Size / - System.Storage_Unit)); - -- Size of the Typeinfo_Ptr field of the Dispatch Table - - DT_Entry_Size : constant SSE.Storage_Count := - SSE.Storage_Count - (1 * (Standard'Address_Size / System.Storage_Unit)); - -- Size of each primitive operation entry in the Dispatch Table - - Tag_Size : constant SSE.Storage_Count := - SSE.Storage_Count (1 * (Standard'Address_Size / System.Storage_Unit)); - -- Size of each tag - - TSD_Prologue_Size : constant SSE.Storage_Count := - SSE.Storage_Count - (10 * (Standard'Address_Size / - System.Storage_Unit)); - -- Size of the first part of the type specific data - - TSD_Entry_Size : constant SSE.Storage_Count := - SSE.Storage_Count - (1 * (Standard'Address_Size / System.Storage_Unit)); - -- Size of each ancestor tag entry in the TSD - - type Address_Array is array (Natural range <>) of System.Address; - pragma Suppress (Index_Check, On => Address_Array); - -- The reason we suppress index checks is that in the body, objects - -- of this type are declared with a dummy size of 1, the actual size - -- depending on the number of primitive operations. - -- Unchecked Conversions type Addr_Ptr is access System.Address; - type Tag_Ptr is access Tag; type Signature_Values is array (1 .. DT_Signature_Size) of Signature_Kind; @@ -486,15 +589,9 @@ private function To_Type_Specific_Data_Ptr is new Unchecked_Conversion (System.Address, Type_Specific_Data_Ptr); - function To_Address is - new Unchecked_Conversion (Interface_Tag, System.Address); - function To_Address is new Unchecked_Conversion (Tag, System.Address); - function To_Address is - new Unchecked_Conversion (Type_Specific_Data_Ptr, System.Address); - function To_Interface_Data_Ptr is new Unchecked_Conversion (System.Address, Interface_Data_Ptr); @@ -527,37 +624,21 @@ private pragma Inline_Always (CW_Membership); pragma Inline_Always (Displace); pragma Inline_Always (IW_Membership); - pragma Inline_Always (Get_Access_Level); pragma Inline_Always (Get_Entry_Index); pragma Inline_Always (Get_Offset_Index); - pragma Inline_Always (Get_Predefined_Prim_Op_Address); - pragma Inline_Always (Get_Prim_Op_Address); pragma Inline_Always (Get_Prim_Op_Kind); - pragma Inline_Always (Get_RC_Offset); - pragma Inline_Always (Get_Remotely_Callable); pragma Inline_Always (Get_Tagged_Kind); - pragma Inline_Always (Inherit_DT); - pragma Inline_Always (Inherit_TSD); pragma Inline_Always (OSD); pragma Inline_Always (Register_Interface_Tag); pragma Inline_Always (Register_Tag); - pragma Inline_Always (Set_Access_Level); pragma Inline_Always (Set_Entry_Index); - pragma Inline_Always (Set_Expanded_Name); - pragma Inline_Always (Set_External_Tag); pragma Inline_Always (Set_Interface_Table); - pragma Inline_Always (Set_Num_Prim_Ops); pragma Inline_Always (Set_Offset_Index); pragma Inline_Always (Set_Offset_To_Top); - pragma Inline_Always (Set_Predefined_Prim_Op_Address); - pragma Inline_Always (Set_Prim_Op_Address); pragma Inline_Always (Set_Prim_Op_Kind); - pragma Inline_Always (Set_RC_Offset); - pragma Inline_Always (Set_Remotely_Callable); pragma Inline_Always (Set_Signature); pragma Inline_Always (Set_OSD); pragma Inline_Always (Set_SSD); - pragma Inline_Always (Set_TSD); pragma Inline_Always (Set_Tagged_Kind); pragma Inline_Always (SSD); pragma Inline_Always (TSD); -- 2.30.2