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_External_Tag --
 308    ----------------------
 309
 310    function Get_External_Tag (T : Tag) return System.Address is
 311    begin
 312       return To_Address (TSD (T).External_Tag);
 313    end Get_External_Tag;
 314
 315    -------------------------
 316    -- Get_Prim_Op_Address --
 317    -------------------------
 318
 319    function Get_Prim_Op_Address
 320      (T        : Tag;
 321       Position : Positive) return System.Address
 322    is
 323    begin
 324       return T.Prims_Ptr (Position);
 325    end Get_Prim_Op_Address;
 326
 327    -------------------
 328    -- Get_RC_Offset --
 329    -------------------
 330
 331    function Get_RC_Offset (T : Tag) return SSE.Storage_Offset is
 332    begin
 333       return TSD (T).RC_Offset;
 334    end Get_RC_Offset;
 335
 336    ---------------------------
 337    -- Get_Remotely_Callable --
 338    ---------------------------
 339
 340    function Get_Remotely_Callable (T : Tag) return Boolean is
 341    begin
 342       return TSD (T).Remotely_Callable = True;
 343    end Get_Remotely_Callable;
 344
 345    ----------------
 346    -- Inherit_DT --
 347    ----------------
 348
 349    procedure Inherit_DT
 350     (Old_T       : Tag;
 351      New_T       : Tag;
 352      Entry_Count : Natural)
 353    is
 354    begin
 355       if Old_T /= null then
 356          New_T.Prims_Ptr (1 .. Entry_Count) :=
 357            Old_T.Prims_Ptr (1 .. Entry_Count);
 358       end if;
 359    end Inherit_DT;
 360
 361    -----------------
 362    -- Inherit_TSD --
 363    -----------------
 364
 365    procedure Inherit_TSD (Old_Tag : Tag; New_Tag : Tag) is
 366       New_TSD_Ptr : constant Type_Specific_Data_Ptr := TSD (New_Tag);
 367       Old_TSD_Ptr : Type_Specific_Data_Ptr;
 368
 369    begin
 370       if Old_Tag /= null then
 371          Old_TSD_Ptr        := TSD (Old_Tag);
 372          New_TSD_Ptr.Idepth := Old_TSD_Ptr.Idepth + 1;
 373          New_TSD_Ptr.Ancestor_Tags (1 .. New_TSD_Ptr.Idepth) :=
 374            Old_TSD_Ptr.Ancestor_Tags (0 .. Old_TSD_Ptr.Idepth);
 375       else
 376          New_TSD_Ptr.Idepth := 0;
 377       end if;
 378
 379       New_TSD_Ptr.Ancestor_Tags (0) := New_Tag;
 380    end Inherit_TSD;
 381
 382    ------------------
 383    -- Internal_Tag --
 384    ------------------
 385
 386    function Internal_Tag (External : String) return Tag is
 387       Ext_Copy : aliased String (External'First .. External'Last + 1);
 388       Res      : Tag;
 389
 390    begin
 391       --  Make a copy of the string representing the external tag with
 392       --  a null at the end
 393
 394       Ext_Copy (External'Range) := External;
 395       Ext_Copy (Ext_Copy'Last) := ASCII.NUL;
 396       Res := External_Tag_HTable.Get (Ext_Copy'Address);
 397
 398       if Res = null then
 399          declare
 400             Msg1 : constant String := "unknown tagged type: ";
 401             Msg2 : String (1 .. Msg1'Length + External'Length);
 402          begin
 403             Msg2 (1 .. Msg1'Length) := Msg1;
 404             Msg2 (Msg1'Length + 1 .. Msg1'Length + External'Length) :=
 405               External;
 406             Ada.Exceptions.Raise_Exception (Tag_Error'Identity, Msg2);
 407          end;
 408       end if;
 409
 410       return Res;
 411    end Internal_Tag;
 412
 413    ------------
 414    -- Length --
 415    ------------
 416
 417    function Length (Str : Cstring_Ptr) return Natural is
 418       Len : Integer := 1;
 419
 420    begin
 421       while Str (Len) /= ASCII.Nul loop
 422          Len := Len + 1;
 423       end loop;
 424
 425       return Len - 1;
 426    end Length;
 427
 428    -----------------
 429    -- Parent_Size --
 430    -----------------
 431
 432    type Acc_Size
 433      is access function (A : System.Address) return Long_Long_Integer;
 434
 435    function To_Acc_Size is new Unchecked_Conversion (System.Address, Acc_Size);
 436    --  The profile of the implicitly defined _size primitive
 437
 438    function Parent_Size
 439      (Obj : System.Address;
 440       T   : Tag) return SSE.Storage_Count
 441    is
 442       Parent_Tag : constant Tag := TSD (T).Ancestor_Tags (1);
 443       --  The tag of the parent type through the dispatch table
 444
 445       F : constant Acc_Size := To_Acc_Size (Parent_Tag.Prims_Ptr (1));
 446       --  Access to the _size primitive of the parent. We assume that
 447       --  it is always in the first slot of the distatch table
 448
 449    begin
 450       --  Here we compute the size of the _parent field of the object
 451
 452       return SSE.Storage_Count (F.all (Obj));
 453    end Parent_Size;
 454
 455    ----------------
 456    -- Parent_Tag --
 457    ----------------
 458
 459    function Parent_Tag (T : Tag) return Tag is
 460    begin
 461       return TSD (T).Ancestor_Tags (1);
 462    end Parent_Tag;
 463
 464    ------------------
 465    -- Register_Tag --
 466    ------------------
 467
 468    procedure Register_Tag (T : Tag) is
 469    begin
 470       External_Tag_HTable.Set (T);
 471    end Register_Tag;
 472
 473    -----------------------
 474    -- Set_Expanded_Name --
 475    -----------------------
 476
 477    procedure Set_Expanded_Name (T : Tag; Value : System.Address) is
 478    begin
 479       TSD (T).Expanded_Name := To_Cstring_Ptr (Value);
 480    end Set_Expanded_Name;
 481
 482    ----------------------
 483    -- Set_External_Tag --
 484    ----------------------
 485
 486    procedure Set_External_Tag (T : Tag; Value : System.Address) is
 487    begin
 488       TSD (T).External_Tag := To_Cstring_Ptr (Value);
 489    end Set_External_Tag;
 490
 491    -------------------------
 492    -- Set_Prim_Op_Address --
 493    -------------------------
 494
 495    procedure Set_Prim_Op_Address
 496      (T        : Tag;
 497       Position : Positive;
 498       Value    : System.Address)
 499    is
 500    begin
 501       T.Prims_Ptr (Position) := Value;
 502    end Set_Prim_Op_Address;
 503
 504    -------------------
 505    -- Set_RC_Offset --
 506    -------------------
 507
 508    procedure Set_RC_Offset (T : Tag; Value : SSE.Storage_Offset) is
 509    begin
 510       TSD (T).RC_Offset := Value;
 511    end Set_RC_Offset;
 512
 513    ---------------------------
 514    -- Set_Remotely_Callable --
 515    ---------------------------
 516
 517    procedure Set_Remotely_Callable (T : Tag; Value : Boolean) is
 518    begin
 519       if Value then
 520          TSD (T).Remotely_Callable := True;
 521       else
 522          TSD (T).Remotely_Callable := False;
 523       end if;
 524    end Set_Remotely_Callable;
 525
 526    -------------
 527    -- Set_TSD --
 528    -------------
 529
 530    procedure Set_TSD (T : Tag; Value : System.Address) is
 531       use type System.Storage_Elements.Storage_Offset;
 532       TSD_Ptr : constant Addr_Ptr :=
 533                   To_Addr_Ptr (To_Address (T) - DT_Typeinfo_Ptr_Size);
 534    begin
 535       TSD_Ptr.all := Value;
 536    end Set_TSD;
 537
 538    -------------------
 539    -- Offset_To_Top --
 540    -------------------
 541
 542    function Offset_To_Top (T : Tag) return Integer is
 543       use type System.Storage_Elements.Storage_Offset;
 544       TSD_Ptr : constant Int_Ptr :=
 545                   To_Int_Ptr (To_Address (T) - DT_Prologue_Size);
 546    begin
 547       return TSD_Ptr.all;
 548    end Offset_To_Top;
 549
 550    ------------------
 551    -- Typeinfo_Ptr --
 552    ------------------
 553
 554    function Typeinfo_Ptr (T : Tag) return System.Address is
 555       use type System.Storage_Elements.Storage_Offset;
 556       TSD_Ptr : constant Addr_Ptr :=
 557                   To_Addr_Ptr (To_Address (T) - DT_Typeinfo_Ptr_Size);
 558    begin
 559       return TSD_Ptr.all;
 560    end Typeinfo_Ptr;
 561
 562    ---------
 563    -- TSD --
 564    ---------
 565
 566    function TSD (T : Tag) return Type_Specific_Data_Ptr is
 567       use type System.Storage_Elements.Storage_Offset;
 568       TSD_Ptr : constant Addr_Ptr :=
 569                   To_Addr_Ptr (To_Address (T) - DT_Typeinfo_Ptr_Size);
 570    begin
 571       return To_Type_Specific_Data_Ptr (TSD_Ptr.all);
 572    end TSD;
 573
 574 end Ada.Tags;