gcc/ada/a-tags.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT RUNTIME COMPONENTS                          --
   4 --                                                                          --
   5 --                             A D A . T A G S                              --
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                                                                          --
   9 --          Copyright (C) 1992-2005 Free Software Foundation, Inc.          --
  10 --                                                                          --
  11 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
  12 -- terms of the  GNU General Public License as published  by the Free Soft- --
  13 -- ware  Foundation;  either version 2,  or (at your option) any later ver- --
  14 -- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
  15 -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
  16 -- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
  17 -- for  more details.  You should have  received  a copy of the GNU General --
  18 -- Public License  distributed with GNAT;  see file COPYING.  If not, write --
  19 -- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
  20 -- MA 02111-1307, USA.                                                      --
  21 --                                                                          --
  22 -- As a special exception,  if other files  instantiate  generics from this --
  23 -- unit, or you link  this unit with other files  to produce an executable, --
  24 -- this  unit  does not  by itself cause  the resulting  executable  to  be --
  25 -- covered  by the  GNU  General  Public  License.  This exception does not --
  26 -- however invalidate  any other reasons why  the executable file  might be --
  27 -- covered by the  GNU Public License.                                      --
  28 --                                                                          --
  29 -- GNAT was originally developed  by the GNAT team at  New York University. --
  30 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
  31 --                                                                          --
  32 ------------------------------------------------------------------------------
  33
  34 with Ada.Exceptions;
  35 with System.HTable;
  36
  37 pragma Elaborate_All (System.HTable);
  38
  39 package body Ada.Tags is
  40
  41 --  Structure of the GNAT Dispatch Table
  42
  43 --           +-----------------------+
  44 --           |     Offset_To_Top     |
  45 --           +-----------------------+
  46 --           | Typeinfo_Ptr/TSD_Ptr  |----> Type Specific Data
  47 --  Tag ---> +-----------------------+      +-------------------+
  48 --           |        table of       |      | inheritance depth |
  49 --           :     primitive ops     :      +-------------------+
  50 --           |        pointers       |      |   expanded name   |
  51 --           +-----------------------+      +-------------------+
  52 --                                          |   external tag    |
  53 --                                          +-------------------+
  54 --                                          |   Hash table link |
  55 --                                          +-------------------+
  56 --                                          | Remotely Callable |
  57 --                                          +-------------------+
  58 --                                          | Rec Ctrler offset |
  59 --                                          +-------------------+
  60 --                                          | table of          |
  61 --                                          :   ancestor        :
  62 --                                          |      tags         |
  63 --                                          +-------------------+
  64
  65    subtype Cstring is String (Positive);
  66    type Cstring_Ptr is access all Cstring;
  67
  68    type Tag_Table is array (Natural range <>) of Tag;
  69    pragma Suppress_Initialization (Tag_Table);
  70    pragma Suppress (Index_Check, On => Tag_Table);
  71    --  We suppress index checks because the declared size in the record below
  72    --  is a dummy size of one (see below).
  73
  74    type Wide_Boolean is new Boolean;
  75    --  This name should probably be changed sometime ??? and indeed probably
  76    --  this field could simply be of type Standard.Boolean.
  77
  78    type Type_Specific_Data is record
  79       Idepth             : Natural;
  80       Expanded_Name      : Cstring_Ptr;
  81       External_Tag       : Cstring_Ptr;
  82       HT_Link            : Tag;
  83       Remotely_Callable  : Wide_Boolean;
  84       RC_Offset          : SSE.Storage_Offset;
  85       Ancestor_Tags      : Tag_Table (0 .. 1);
  86    end record;
  87    --  The size of the Ancestor_Tags array actually depends on the tagged type
  88    --  to which it applies. We are using the same mechanism as for the
  89    --  Prims_Ptr array in the Dispatch_Table record. See comments below for
  90    --  more details.
  91
  92    type Dispatch_Table is record
  93       --  Offset_To_Top : Integer := 0;
  94       --  Typeinfo_Ptr  : System.Address; -- Currently TSD is also here???
  95       Prims_Ptr    : Address_Array (Positive);
  96    end record;
  97
  98    --  Note on the commented out fields of the Dispatch_Table
  99    --  ------------------------------------------------------
 100    --  According to the C++ ABI the components Offset_To_Top and Typeinfo_Ptr
 101    --  are stored just "before" the dispatch table (that is, the Prims_Ptr
 102    --  table), and they are referenced with negative offsets referring to the
 103    --  base of the dispatch table. The _Tag (or the VTable_Ptr in C++ termi-
 104    --  nology) must point to the base of the virtual table, just after these
 105    --  components, to point to the Prims_Ptr table. For this purpose the
 106    --  expander generates a Prims_Ptr table that has enough space for these
 107    --  additional components, and generates code that displaces the _Tag to
 108    --  point after these components.
 109    --  -----------------------------------------------------------------------
 110
 111    --  The size of the Prims_Ptr array actually depends on the tagged type to
 112    --  which it applies. For each tagged type, the expander computes the
 113    --  actual array size, allocates the Dispatch_Table record accordingly, and
 114    --  generates code that displaces the base of the record after the
 115    --  Typeinfo_Ptr component. For this reason the first two components have
 116    --  been commented in the previous declaration. The access to these
 117    --  components is done by means of local functions.
 118    --
 119    --  To avoid the use of discriminants to define the actual size of the
 120    --  dispatch table, we used to declare the tag as a pointer to a record
 121    --  that contains an arbitrary array of addresses, using Positive as its
 122    --  index. This ensures that there are never range checks when accessing
 123    --  the dispatch table, but it prevents GDB from displaying tagged types
 124    --  properly. A better approach is to declare this record type as holding a
 125    --  small number of addresses, and to explicitly suppress checks on it.
 126    --
 127    --  Note that in both cases, this type is never allocated, and serves only
 128    --  to declare the corresponding access type.
 129
 130    ---------------------------------------------
 131    -- Unchecked Conversions for String Fields --
 132    ---------------------------------------------
 133
 134    function To_Cstring_Ptr is
 135      new Unchecked_Conversion (System.Address, Cstring_Ptr);
 136
 137    function To_Address is
 138      new Unchecked_Conversion (Cstring_Ptr, System.Address);
 139
 140    -----------------------------------------------------------
 141    -- Unchecked Conversions for the component offset_to_top --
 142    -----------------------------------------------------------
 143
 144    type Int_Ptr is access Integer;
 145
 146    function To_Int_Ptr is
 147       new Unchecked_Conversion (System.Address, Int_Ptr);
 148
 149    -----------------------
 150    -- Local Subprograms --
 151    -----------------------
 152
 153    function Length (Str : Cstring_Ptr) return Natural;
 154    --  Length of string represented by the given pointer (treating the string
 155    --  as a C-style string, which is Nul terminated).
 156
 157    function Offset_To_Top (T : Tag) return Integer;
 158    --  Returns the current value of the offset_to_top component available in
 159    --  the prologue of the dispatch table.
 160
 161    function Typeinfo_Ptr (T : Tag) return System.Address;
 162    --  Returns the current value of the typeinfo_ptr component available in
 163    --  the prologue of the dispatch table.
 164
 165    pragma Unreferenced (Offset_To_Top);
 166    pragma Unreferenced (Typeinfo_Ptr);
 167    --  These functions will be used for full compatibility with the C++ ABI
 168
 169    -------------------------
 170    -- External_Tag_HTable --
 171    -------------------------
 172
 173    type HTable_Headers is range 1 .. 64;
 174
 175    --  The following internal package defines the routines used for the
 176    --  instantiation of a new System.HTable.Static_HTable (see below). See
 177    --  spec in g-htable.ads for details of usage.
 178
 179    package HTable_Subprograms is
 180       procedure Set_HT_Link (T : Tag; Next : Tag);
 181       function  Get_HT_Link (T : Tag) return Tag;
 182       function Hash (F : System.Address) return HTable_Headers;
 183       function Equal (A, B : System.Address) return Boolean;
 184    end HTable_Subprograms;
 185
 186    package External_Tag_HTable is new System.HTable.Static_HTable (
 187      Header_Num => HTable_Headers,
 188      Element    => Dispatch_Table,
 189      Elmt_Ptr   => Tag,
 190      Null_Ptr   => null,
 191      Set_Next   => HTable_Subprograms.Set_HT_Link,
 192      Next       => HTable_Subprograms.Get_HT_Link,
 193      Key        => System.Address,
 194      Get_Key    => Get_External_Tag,
 195      Hash       => HTable_Subprograms.Hash,
 196      Equal      => HTable_Subprograms.Equal);
 197
 198    ------------------------
 199    -- HTable_Subprograms --
 200    ------------------------
 201
 202    --  Bodies of routines for hash table instantiation
 203
 204    package body HTable_Subprograms is
 205
 206    -----------
 207    -- Equal --
 208    -----------
 209
 210       function Equal (A, B : System.Address) return Boolean is
 211          Str1 : constant Cstring_Ptr := To_Cstring_Ptr (A);
 212          Str2 : constant Cstring_Ptr := To_Cstring_Ptr (B);
 213          J    : Integer := 1;
 214
 215       begin
 216          loop
 217             if Str1 (J) /= Str2 (J) then
 218                return False;
 219
 220             elsif Str1 (J) = ASCII.NUL then
 221                return True;
 222
 223             else
 224                J := J + 1;
 225             end if;
 226          end loop;
 227       end Equal;
 228
 229       -----------------
 230       -- Get_HT_Link --
 231       -----------------
 232
 233       function Get_HT_Link (T : Tag) return Tag is
 234       begin
 235          return TSD (T).HT_Link;
 236       end Get_HT_Link;
 237
 238       ----------
 239       -- Hash --
 240       ----------
 241
 242       function Hash (F : System.Address) return HTable_Headers is
 243          function H is new System.HTable.Hash (HTable_Headers);
 244          Str : constant Cstring_Ptr    := To_Cstring_Ptr (F);
 245          Res : constant HTable_Headers := H (Str (1 .. Length (Str)));
 246       begin
 247          return Res;
 248       end Hash;
 249
 250       -----------------
 251       -- Set_HT_Link --
 252       -----------------
 253
 254       procedure Set_HT_Link (T : Tag; Next : Tag) is
 255       begin
 256          TSD (T).HT_Link := Next;
 257       end Set_HT_Link;
 258
 259    end HTable_Subprograms;
 260
 261    -------------------
 262    -- CW_Membership --
 263    -------------------
 264
 265    --  Canonical implementation of Classwide Membership corresponding to:
 266
 267    --     Obj in Typ'Class
 268
 269    --  Each dispatch table contains a reference to a table of ancestors
 270    --  (Ancestor_Tags) and a count of the level of inheritance "Idepth" .
 271
 272    --  Obj is in Typ'Class if Typ'Tag is in the table of ancestors that are
 273    --  contained in the dispatch table referenced by Obj'Tag . Knowing the
 274    --  level of inheritance of both types, this can be computed in constant
 275    --  time by the formula:
 276
 277    --   Obj'tag.TSD.Ancestor_Tags (Obj'tag.TSD.Idepth - Typ'tag.TSD.Idepth)
 278    --     = Typ'tag
 279
 280    function CW_Membership (Obj_Tag : Tag; Typ_Tag : Tag) return Boolean is
 281       Pos : constant Integer := TSD (Obj_Tag).Idepth - TSD (Typ_Tag).Idepth;
 282    begin
 283       return Pos >= 0 and then TSD (Obj_Tag).Ancestor_Tags (Pos) = Typ_Tag;
 284    end CW_Membership;
 285
 286    -------------------
 287    -- Expanded_Name --
 288    -------------------
 289
 290    function Expanded_Name (T : Tag) return String is
 291       Result : constant Cstring_Ptr := TSD (T).Expanded_Name;
 292    begin
 293       return Result (1 .. Length (Result));
 294    end Expanded_Name;
 295
 296    ------------------
 297    -- External_Tag --
 298    ------------------
 299
 300    function External_Tag (T : Tag) return String is
 301       Result : constant Cstring_Ptr := TSD (T).External_Tag;
 302    begin
 303       return Result (1 .. Length (Result));
 304    end External_Tag;
 305
 306    -----------------------
 307    -- Get_Expanded_Name --
 308    -----------------------
 309
 310    function Get_Expanded_Name (T : Tag) return System.Address is
 311    begin
 312       return To_Address (TSD (T).Expanded_Name);
 313    end Get_Expanded_Name;
 314
 315    ----------------------
 316    -- Get_External_Tag --
 317    ----------------------
 318
 319    function Get_External_Tag (T : Tag) return System.Address is
 320    begin
 321       return To_Address (TSD (T).External_Tag);
 322    end Get_External_Tag;
 323
 324    ---------------------------
 325    -- Get_Inheritance_Depth --
 326    ---------------------------
 327
 328    function Get_Inheritance_Depth (T : Tag) return Natural is
 329    begin
 330       return TSD (T).Idepth;
 331    end Get_Inheritance_Depth;
 332
 333    -------------------------
 334    -- Get_Prim_Op_Address --
 335    -------------------------
 336
 337    function Get_Prim_Op_Address
 338      (T        : Tag;
 339       Position : Positive) return System.Address
 340    is
 341    begin
 342       return T.Prims_Ptr (Position);
 343    end Get_Prim_Op_Address;
 344
 345    -------------------
 346    -- Get_RC_Offset --
 347    -------------------
 348
 349    function Get_RC_Offset (T : Tag) return SSE.Storage_Offset is
 350    begin
 351       return TSD (T).RC_Offset;
 352    end Get_RC_Offset;
 353
 354    ---------------------------
 355    -- Get_Remotely_Callable --
 356    ---------------------------
 357
 358    function Get_Remotely_Callable (T : Tag) return Boolean is
 359    begin
 360       return TSD (T).Remotely_Callable = True;
 361    end Get_Remotely_Callable;
 362
 363    -------------
 364    -- Get_TSD --
 365    -------------
 366
 367    function Get_TSD  (T : Tag) return System.Address is
 368       use type System.Storage_Elements.Storage_Offset;
 369       TSD_Ptr : constant Addr_Ptr :=
 370                   To_Addr_Ptr (To_Address (T) - DT_Typeinfo_Ptr_Size);
 371    begin
 372       return TSD_Ptr.all;
 373    end Get_TSD;
 374
 375    ----------------
 376    -- Inherit_DT --
 377    ----------------
 378
 379    procedure Inherit_DT
 380     (Old_T       : Tag;
 381      New_T       : Tag;
 382      Entry_Count : Natural)
 383    is
 384    begin
 385       if Old_T /= null then
 386          New_T.Prims_Ptr (1 .. Entry_Count) :=
 387            Old_T.Prims_Ptr (1 .. Entry_Count);
 388       end if;
 389    end Inherit_DT;
 390
 391    -----------------
 392    -- Inherit_TSD --
 393    -----------------
 394
 395    procedure Inherit_TSD (Old_TSD : System.Address; New_Tag : Tag) is
 396       Old_TSD_Ptr  : constant Type_Specific_Data_Ptr :=
 397                        To_Type_Specific_Data_Ptr (Old_TSD);
 398       New_TSD_Ptr  : constant Type_Specific_Data_Ptr :=
 399                        TSD (New_Tag);
 400
 401    begin
 402       if Old_TSD_Ptr /= null then
 403          New_TSD_Ptr.Idepth := Old_TSD_Ptr.Idepth + 1;
 404          New_TSD_Ptr.Ancestor_Tags (1 .. New_TSD_Ptr.Idepth) :=
 405            Old_TSD_Ptr.Ancestor_Tags (0 .. Old_TSD_Ptr.Idepth);
 406       else
 407          New_TSD_Ptr.Idepth := 0;
 408       end if;
 409
 410       New_TSD_Ptr.Ancestor_Tags (0) := New_Tag;
 411    end Inherit_TSD;
 412
 413    ------------------
 414    -- Internal_Tag --
 415    ------------------
 416
 417    function Internal_Tag (External : String) return Tag is
 418       Ext_Copy : aliased String (External'First .. External'Last + 1);
 419       Res      : Tag;
 420
 421    begin
 422       --  Make a copy of the string representing the external tag with
 423       --  a null at the end
 424
 425       Ext_Copy (External'Range) := External;
 426       Ext_Copy (Ext_Copy'Last) := ASCII.NUL;
 427       Res := External_Tag_HTable.Get (Ext_Copy'Address);
 428
 429       if Res = null then
 430          declare
 431             Msg1 : constant String := "unknown tagged type: ";
 432             Msg2 : String (1 .. Msg1'Length + External'Length);
 433          begin
 434             Msg2 (1 .. Msg1'Length) := Msg1;
 435             Msg2 (Msg1'Length + 1 .. Msg1'Length + External'Length) :=
 436               External;
 437             Ada.Exceptions.Raise_Exception (Tag_Error'Identity, Msg2);
 438          end;
 439       end if;
 440
 441       return Res;
 442    end Internal_Tag;
 443
 444    ------------
 445    -- Length --
 446    ------------
 447
 448    function Length (Str : Cstring_Ptr) return Natural is
 449       Len : Integer := 1;
 450
 451    begin
 452       while Str (Len) /= ASCII.Nul loop
 453          Len := Len + 1;
 454       end loop;
 455
 456       return Len - 1;
 457    end Length;
 458
 459    -----------------
 460    -- Parent_Size --
 461    -----------------
 462
 463    type Acc_Size
 464      is access function (A : System.Address) return Long_Long_Integer;
 465
 466    function To_Acc_Size is new Unchecked_Conversion (System.Address, Acc_Size);
 467    --  The profile of the implicitly defined _size primitive
 468
 469    function Parent_Size
 470      (Obj : System.Address;
 471       T   : Tag) return SSE.Storage_Count
 472    is
 473       Parent_Tag : constant Tag := TSD (T).Ancestor_Tags (1);
 474       --  The tag of the parent type through the dispatch table
 475
 476       F : constant Acc_Size := To_Acc_Size (Parent_Tag.Prims_Ptr (1));
 477       --  Access to the _size primitive of the parent. We assume that
 478       --  it is always in the first slot of the distatch table
 479
 480    begin
 481       --  Here we compute the size of the _parent field of the object
 482
 483       return SSE.Storage_Count (F.all (Obj));
 484    end Parent_Size;
 485
 486    ----------------
 487    -- Parent_Tag --
 488    ----------------
 489
 490    function Parent_Tag (T : Tag) return Tag is
 491    begin
 492       return TSD (T).Ancestor_Tags (1);
 493    end Parent_Tag;
 494
 495    ------------------
 496    -- Register_Tag --
 497    ------------------
 498
 499    procedure Register_Tag (T : Tag) is
 500    begin
 501       External_Tag_HTable.Set (T);
 502    end Register_Tag;
 503
 504    -----------------------
 505    -- Set_Expanded_Name --
 506    -----------------------
 507
 508    procedure Set_Expanded_Name (T : Tag; Value : System.Address) is
 509    begin
 510       TSD (T).Expanded_Name := To_Cstring_Ptr (Value);
 511    end Set_Expanded_Name;
 512
 513    ----------------------
 514    -- Set_External_Tag --
 515    ----------------------
 516
 517    procedure Set_External_Tag (T : Tag; Value : System.Address) is
 518    begin
 519       TSD (T).External_Tag := To_Cstring_Ptr (Value);
 520    end Set_External_Tag;
 521
 522    ---------------------------
 523    -- Set_Inheritance_Depth --
 524    ---------------------------
 525
 526    procedure Set_Inheritance_Depth
 527      (T     : Tag;
 528       Value : Natural)
 529    is
 530    begin
 531       TSD (T).Idepth := Value;
 532    end Set_Inheritance_Depth;
 533
 534    -------------------------
 535    -- Set_Prim_Op_Address --
 536    -------------------------
 537
 538    procedure Set_Prim_Op_Address
 539      (T        : Tag;
 540       Position : Positive;
 541       Value    : System.Address)
 542    is
 543    begin
 544       T.Prims_Ptr (Position) := Value;
 545    end Set_Prim_Op_Address;
 546
 547    -------------------
 548    -- Set_RC_Offset --
 549    -------------------
 550
 551    procedure Set_RC_Offset (T : Tag; Value : SSE.Storage_Offset) is
 552    begin
 553       TSD (T).RC_Offset := Value;
 554    end Set_RC_Offset;
 555
 556    ---------------------------
 557    -- Set_Remotely_Callable --
 558    ---------------------------
 559
 560    procedure Set_Remotely_Callable (T : Tag; Value : Boolean) is
 561    begin
 562       if Value then
 563          TSD (T).Remotely_Callable := True;
 564       else
 565          TSD (T).Remotely_Callable := False;
 566       end if;
 567    end Set_Remotely_Callable;
 568
 569    -------------
 570    -- Set_TSD --
 571    -------------
 572
 573    procedure Set_TSD (T : Tag; Value : System.Address) is
 574       use type System.Storage_Elements.Storage_Offset;
 575       TSD_Ptr : constant Addr_Ptr :=
 576                   To_Addr_Ptr (To_Address (T) - DT_Typeinfo_Ptr_Size);
 577    begin
 578       TSD_Ptr.all := Value;
 579    end Set_TSD;
 580
 581    -------------------
 582    -- Offset_To_Top --
 583    -------------------
 584
 585    function Offset_To_Top (T : Tag) return Integer is
 586       use type System.Storage_Elements.Storage_Offset;
 587       TSD_Ptr : constant Int_Ptr :=
 588                   To_Int_Ptr (To_Address (T) - DT_Prologue_Size);
 589    begin
 590       return TSD_Ptr.all;
 591    end Offset_To_Top;
 592
 593    ------------------
 594    -- Typeinfo_Ptr --
 595    ------------------
 596
 597    function Typeinfo_Ptr (T : Tag) return System.Address is
 598       use type System.Storage_Elements.Storage_Offset;
 599       TSD_Ptr : constant Addr_Ptr :=
 600                   To_Addr_Ptr (To_Address (T) - DT_Typeinfo_Ptr_Size);
 601    begin
 602       return TSD_Ptr.all;
 603    end Typeinfo_Ptr;
 604
 605    ---------
 606    -- TSD --
 607    ---------
 608
 609    function TSD (T : Tag) return Type_Specific_Data_Ptr is
 610    begin
 611       return To_Type_Specific_Data_Ptr (Get_TSD (T));
 612    end TSD;
 613
 614 end Ada.Tags;