Skip to content

R
riscv-gcc-1
Commit 3d6efb77 by Javier Miranda Committed by Arnaud Charlet
Options

a-tags.ads, a-tags.adb (Object_Specific_Data): Remove component Num_Prim_Ops. 

2007-04-06  Javier Miranda  <miranda@adacore.com>

	* 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
parent 98872613
Showing with 339 additions and 955 deletions
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_<Field_Name> and Set_<Field_Name>
-- in a-tags.ads.
-- Update the GNAT Dispatch Table structure in a-tags.adb
-- Provide bodies to the Get_<Field_Name> and Set_<Field_Name> routines.
-- The profile of a Get_<Field_Name> routine should resemble:
-- function Get_<Field_Name> (T : Tag; ...) return Field_Type is
-- Field : constant System.Address :=
-- To_Address (T) - <Sum_Of_Previous_Field_Sizes>;
-- begin
-- pragma Assert (Check_Signature (T, <Applicable_DT>));
-- <Additional_Assertions>
-- return To_Field_Type_Ptr (Field).all;
-- end Get_<Field_Name>;
-- The profile of a Set_<Field_Name> routine should resemble:
-- procedure Set_<Field_Name> (T : Tag; ..., Value : Field_Type) is
-- Field : constant System.Address :=
-- To_Address (T) - <Sum_Of_Previous_Field_Sizes>;
-- begin
-- pragma Assert (Check_Signature (T, <Applicable_DT>));
-- <Additional_Assertions>
-- To_Field_Type_Ptr (Field).all := Value;
-- end Set_<Field_Name>;
-- 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,54 +426,10 @@ 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,58 +709,19 @@ 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,32 +832,10 @@ 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;
......
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;
......@@ -487,14 +590,8 @@ private
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);
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment