gcc/ada/s-finmas.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT COMPILER COMPONENTS                         --
   4 --                                                                          --
   5 --           S Y S T E M . F I N A L I Z A T I O N _ M A S T E R S          --
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                                                                          --
   9 --             Copyright (C) 2011, 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 3,  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.                                     --
  17 --                                                                          --
  18 -- As a special exception under Section 7 of GPL version 3, you are granted --
  19 -- additional permissions described in the GCC Runtime Library Exception,   --
  20 -- version 3.1, as published by the Free Software Foundation.               --
  21 --                                                                          --
  22 -- You should have received a copy of the GNU General Public License and    --
  23 -- a copy of the GCC Runtime Library Exception along with this program;     --
  24 -- see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see    --
  25 -- <http://www.gnu.org/licenses/>.                                          --
  26 --                                                                          --
  27 -- GNAT was originally developed  by the GNAT team at  New York University. --
  28 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
  29 --                                                                          --
  30 ------------------------------------------------------------------------------
  31
  32 with Ada.Exceptions; use Ada.Exceptions;
  33
  34 with System.Address_Image;
  35 with System.HTable;           use System.HTable;
  36 with System.IO;               use System.IO;
  37 with System.Soft_Links;       use System.Soft_Links;
  38 with System.Storage_Elements; use System.Storage_Elements;
  39
  40 package body System.Finalization_Masters is
  41
  42    --  Finalize_Address hash table types. In general, masters are homogeneous
  43    --  collections of controlled objects. Rare cases such as allocations on a
  44    --  subpool require heterogeneous masters. The following table provides a
  45    --  relation between object address and its Finalize_Address routine.
  46
  47    type Header_Num is range 0 .. 127;
  48
  49    function Hash (Key : System.Address) return Header_Num;
  50
  51    --  Address --> Finalize_Address_Ptr
  52
  53    package Finalize_Address_Table is new Simple_HTable
  54      (Header_Num => Header_Num,
  55       Element    => Finalize_Address_Ptr,
  56       No_Element => null,
  57       Key        => System.Address,
  58       Hash       => Hash,
  59       Equal      => "=");
  60
  61    ---------------------------
  62    -- Add_Offset_To_Address --
  63    ---------------------------
  64
  65    function Add_Offset_To_Address
  66      (Addr   : System.Address;
  67       Offset : System.Storage_Elements.Storage_Offset) return System.Address
  68    is
  69    begin
  70       return System.Storage_Elements."+" (Addr, Offset);
  71    end Add_Offset_To_Address;
  72
  73    ------------
  74    -- Attach --
  75    ------------
  76
  77    procedure Attach (N : not null FM_Node_Ptr; L : not null FM_Node_Ptr) is
  78    begin
  79       Lock_Task.all;
  80       Attach_Unprotected (N, L);
  81       Unlock_Task.all;
  82
  83       --  Note: No need to unlock in case of an exception because the above
  84       --  code can never raise one.
  85    end Attach;
  86
  87    ------------------------
  88    -- Attach_Unprotected --
  89    ------------------------
  90
  91    procedure Attach_Unprotected
  92      (N : not null FM_Node_Ptr;
  93       L : not null FM_Node_Ptr)
  94    is
  95    begin
  96       L.Next.Prev := N;
  97       N.Next := L.Next;
  98       L.Next := N;
  99       N.Prev := L;
 100    end Attach_Unprotected;
 101
 102    ---------------
 103    -- Base_Pool --
 104    ---------------
 105
 106    function Base_Pool
 107      (Master : Finalization_Master) return Any_Storage_Pool_Ptr
 108    is
 109    begin
 110       return Master.Base_Pool;
 111    end Base_Pool;
 112
 113    -----------------------------------------
 114    -- Delete_Finalize_Address_Unprotected --
 115    -----------------------------------------
 116
 117    procedure Delete_Finalize_Address_Unprotected (Obj : System.Address) is
 118    begin
 119       Finalize_Address_Table.Remove (Obj);
 120    end Delete_Finalize_Address_Unprotected;
 121
 122    ------------
 123    -- Detach --
 124    ------------
 125
 126    procedure Detach (N : not null FM_Node_Ptr) is
 127    begin
 128       Lock_Task.all;
 129       Detach_Unprotected (N);
 130       Unlock_Task.all;
 131
 132       --  Note: No need to unlock in case of an exception because the above
 133       --  code can never raise one.
 134    end Detach;
 135
 136    ------------------------
 137    -- Detach_Unprotected --
 138    ------------------------
 139
 140    procedure Detach_Unprotected (N : not null FM_Node_Ptr) is
 141    begin
 142       if N.Prev /= null and then N.Next /= null then
 143          N.Prev.Next := N.Next;
 144          N.Next.Prev := N.Prev;
 145          N.Prev := null;
 146          N.Next := null;
 147       end if;
 148    end Detach_Unprotected;
 149
 150    --------------
 151    -- Finalize --
 152    --------------
 153
 154    overriding procedure Finalize (Master : in out Finalization_Master) is
 155       Cleanup  : Finalize_Address_Ptr;
 156       Curr_Ptr : FM_Node_Ptr;
 157       Ex_Occur : Exception_Occurrence;
 158       Obj_Addr : Address;
 159       Raised   : Boolean := False;
 160
 161       function Is_Empty_List (L : not null FM_Node_Ptr) return Boolean;
 162       --  Determine whether a list contains only one element, the dummy head
 163
 164       -------------------
 165       -- Is_Empty_List --
 166       -------------------
 167
 168       function Is_Empty_List (L : not null FM_Node_Ptr) return Boolean is
 169       begin
 170          return L.Next = L and then L.Prev = L;
 171       end Is_Empty_List;
 172
 173    --  Start of processing for Finalize
 174
 175    begin
 176       Lock_Task.all;
 177
 178       --  Synchronization:
 179       --    Read  - allocation, finalization
 180       --    Write - finalization
 181
 182       if Master.Finalization_Started then
 183          Unlock_Task.all;
 184
 185          --  Double finalization may occur during the handling of stand alone
 186          --  libraries or the finalization of a pool with subpools. Due to the
 187          --  potential aliasing of masters in these two cases, do not process
 188          --  the same master twice.
 189
 190          return;
 191       end if;
 192
 193       --  Lock the master to prevent any allocations while the objects are
 194       --  being finalized. The master remains locked because either the master
 195       --  is explicitly deallocated or the associated access type is about to
 196       --  go out of scope.
 197
 198       --  Synchronization:
 199       --    Read  - allocation, finalization
 200       --    Write - finalization
 201
 202       Master.Finalization_Started := True;
 203
 204       while not Is_Empty_List (Master.Objects'Unchecked_Access) loop
 205          Curr_Ptr := Master.Objects.Next;
 206
 207          --  Synchronization:
 208          --    Write - allocation, deallocation, finalization
 209
 210          Detach_Unprotected (Curr_Ptr);
 211
 212          --  Skip the list header in order to offer proper object layout for
 213          --  finalization.
 214
 215          Obj_Addr := Curr_Ptr.all'Address + Header_Offset;
 216
 217          --  Retrieve TSS primitive Finalize_Address depending on the master's
 218          --  mode of operation.
 219
 220          --  Synchronization:
 221          --    Read  - allocation, finalization
 222          --    Write - outside
 223
 224          if Master.Is_Homogeneous then
 225
 226             --  Synchronization:
 227             --    Read  - finalization
 228             --    Write - allocation, outside
 229
 230             Cleanup := Master.Finalize_Address;
 231
 232          else
 233             --  Synchronization:
 234             --    Read  - finalization
 235             --    Write - allocation, deallocation
 236
 237             Cleanup := Finalize_Address_Unprotected (Obj_Addr);
 238          end if;
 239
 240          begin
 241             Cleanup (Obj_Addr);
 242          exception
 243             when Fin_Occur : others =>
 244                if not Raised then
 245                   Raised := True;
 246                   Save_Occurrence (Ex_Occur, Fin_Occur);
 247                end if;
 248          end;
 249
 250          --  When the master is a heterogeneous collection, destroy the object
 251          --  - Finalize_Address pair since it is no longer needed.
 252
 253          --  Synchronization:
 254          --    Read  - finalization
 255          --    Write - outside
 256
 257          if not Master.Is_Homogeneous then
 258
 259             --  Synchronization:
 260             --    Read  - finalization
 261             --    Write - allocation, deallocation, finalization
 262
 263             Delete_Finalize_Address_Unprotected (Obj_Addr);
 264          end if;
 265       end loop;
 266
 267       Unlock_Task.all;
 268
 269       --  If the finalization of a particular object failed or Finalize_Address
 270       --  was not set, reraise the exception now.
 271
 272       if Raised then
 273          Reraise_Occurrence (Ex_Occur);
 274       end if;
 275    end Finalize;
 276
 277    ----------------------
 278    -- Finalize_Address --
 279    ----------------------
 280
 281    function Finalize_Address
 282      (Master : Finalization_Master) return Finalize_Address_Ptr
 283    is
 284    begin
 285       return Master.Finalize_Address;
 286    end Finalize_Address;
 287
 288    ----------------------------------
 289    -- Finalize_Address_Unprotected --
 290    ----------------------------------
 291
 292    function Finalize_Address_Unprotected
 293      (Obj : System.Address) return Finalize_Address_Ptr
 294    is
 295    begin
 296       return Finalize_Address_Table.Get (Obj);
 297    end Finalize_Address_Unprotected;
 298
 299    --------------------------
 300    -- Finalization_Started --
 301    --------------------------
 302
 303    function Finalization_Started
 304      (Master : Finalization_Master) return Boolean
 305    is
 306    begin
 307       return Master.Finalization_Started;
 308    end Finalization_Started;
 309
 310    ----------
 311    -- Hash --
 312    ----------
 313
 314    function Hash (Key : System.Address) return Header_Num is
 315    begin
 316       return
 317         Header_Num
 318           (To_Integer (Key) mod Integer_Address (Header_Num'Range_Length));
 319    end Hash;
 320
 321    -----------------
 322    -- Header_Size --
 323    -----------------
 324
 325    function Header_Size return System.Storage_Elements.Storage_Count is
 326    begin
 327       return FM_Node'Size / Storage_Unit;
 328    end Header_Size;
 329
 330    -------------------
 331    -- Header_Offset --
 332    -------------------
 333
 334    function Header_Offset return System.Storage_Elements.Storage_Offset is
 335    begin
 336       return FM_Node'Size / Storage_Unit;
 337    end Header_Offset;
 338
 339    ----------------
 340    -- Initialize --
 341    ----------------
 342
 343    overriding procedure Initialize (Master : in out Finalization_Master) is
 344    begin
 345       --  The dummy head must point to itself in both directions
 346
 347       Master.Objects.Next := Master.Objects'Unchecked_Access;
 348       Master.Objects.Prev := Master.Objects'Unchecked_Access;
 349    end Initialize;
 350
 351    --------------------
 352    -- Is_Homogeneous --
 353    --------------------
 354
 355    function Is_Homogeneous (Master : Finalization_Master) return Boolean is
 356    begin
 357       return Master.Is_Homogeneous;
 358    end Is_Homogeneous;
 359
 360    -------------
 361    -- Objects --
 362    -------------
 363
 364    function Objects (Master : Finalization_Master) return FM_Node_Ptr is
 365    begin
 366       return Master.Objects'Unrestricted_Access;
 367    end Objects;
 368
 369    ------------------
 370    -- Print_Master --
 371    ------------------
 372
 373    procedure Print_Master (Master : Finalization_Master) is
 374       Head      : constant FM_Node_Ptr := Master.Objects'Unrestricted_Access;
 375       Head_Seen : Boolean := False;
 376       N_Ptr     : FM_Node_Ptr;
 377
 378    begin
 379       --  Output the basic contents of a master
 380
 381       --    Master   : 0x123456789
 382       --    Is_Hmgen : TURE <or> FALSE
 383       --    Base_Pool: null <or> 0x123456789
 384       --    Fin_Addr : null <or> 0x123456789
 385       --    Fin_Start: TRUE <or> FALSE
 386
 387       Put ("Master   : ");
 388       Put_Line (Address_Image (Master'Address));
 389
 390       Put ("Is_Hmgen : ");
 391       Put_Line (Master.Is_Homogeneous'Img);
 392
 393       Put ("Base_Pool: ");
 394       if Master.Base_Pool = null then
 395          Put_Line ("null");
 396       else
 397          Put_Line (Address_Image (Master.Base_Pool'Address));
 398       end if;
 399
 400       Put ("Fin_Addr : ");
 401       if Master.Finalize_Address = null then
 402          Put_Line ("null");
 403       else
 404          Put_Line (Address_Image (Master.Finalize_Address'Address));
 405       end if;
 406
 407       Put ("Fin_Start: ");
 408       Put_Line (Master.Finalization_Started'Img);
 409
 410       --  Output all chained elements. The format is the following:
 411
 412       --    ^ <or> ? <or> null
 413       --    |Header: 0x123456789 (dummy head)
 414       --    |  Prev: 0x123456789
 415       --    |  Next: 0x123456789
 416       --    V
 417
 418       --  ^ - the current element points back to the correct element
 419       --  ? - the current element points back to an erroneous element
 420       --  n - the current element points back to null
 421
 422       --  Header - the address of the list header
 423       --  Prev   - the address of the list header which the current element
 424       --           points back to
 425       --  Next   - the address of the list header which the current element
 426       --           points to
 427       --  (dummy head) - present if dummy head
 428
 429       N_Ptr := Head;
 430       while N_Ptr /= null loop  --  Should never be null
 431          Put_Line ("V");
 432
 433          --  We see the head initially; we want to exit when we see the head a
 434          --  second time.
 435
 436          if N_Ptr = Head then
 437             exit when Head_Seen;
 438
 439             Head_Seen := True;
 440          end if;
 441
 442          --  The current element is null. This should never happen since the
 443          --  list is circular.
 444
 445          if N_Ptr.Prev = null then
 446             Put_Line ("null (ERROR)");
 447
 448          --  The current element points back to the correct element
 449
 450          elsif N_Ptr.Prev.Next = N_Ptr then
 451             Put_Line ("^");
 452
 453          --  The current element points to an erroneous element
 454
 455          else
 456             Put_Line ("? (ERROR)");
 457          end if;
 458
 459          --  Output the header and fields
 460
 461          Put ("|Header: ");
 462          Put (Address_Image (N_Ptr.all'Address));
 463
 464          --  Detect the dummy head
 465
 466          if N_Ptr = Head then
 467             Put_Line (" (dummy head)");
 468          else
 469             Put_Line ("");
 470          end if;
 471
 472          Put ("|  Prev: ");
 473
 474          if N_Ptr.Prev = null then
 475             Put_Line ("null");
 476          else
 477             Put_Line (Address_Image (N_Ptr.Prev.all'Address));
 478          end if;
 479
 480          Put ("|  Next: ");
 481
 482          if N_Ptr.Next = null then
 483             Put_Line ("null");
 484          else
 485             Put_Line (Address_Image (N_Ptr.Next.all'Address));
 486          end if;
 487
 488          N_Ptr := N_Ptr.Next;
 489       end loop;
 490    end Print_Master;
 491
 492    -------------------
 493    -- Set_Base_Pool --
 494    -------------------
 495
 496    procedure Set_Base_Pool
 497      (Master   : in out Finalization_Master;
 498       Pool_Ptr : Any_Storage_Pool_Ptr)
 499    is
 500    begin
 501       Master.Base_Pool := Pool_Ptr;
 502    end Set_Base_Pool;
 503
 504    --------------------------
 505    -- Set_Finalize_Address --
 506    --------------------------
 507
 508    procedure Set_Finalize_Address
 509      (Master       : in out Finalization_Master;
 510       Fin_Addr_Ptr : Finalize_Address_Ptr)
 511    is
 512    begin
 513       --  Synchronization:
 514       --    Read  - finalization
 515       --    Write - allocation, outside
 516
 517       Lock_Task.all;
 518       Set_Finalize_Address_Unprotected (Master, Fin_Addr_Ptr);
 519       Unlock_Task.all;
 520    end Set_Finalize_Address;
 521
 522    --------------------------------------
 523    -- Set_Finalize_Address_Unprotected --
 524    --------------------------------------
 525
 526    procedure Set_Finalize_Address_Unprotected
 527      (Master       : in out Finalization_Master;
 528       Fin_Addr_Ptr : Finalize_Address_Ptr)
 529    is
 530    begin
 531       if Master.Finalize_Address = null then
 532          Master.Finalize_Address := Fin_Addr_Ptr;
 533       end if;
 534    end Set_Finalize_Address_Unprotected;
 535
 536    ----------------------------------------------------
 537    -- Set_Heterogeneous_Finalize_Address_Unprotected --
 538    ----------------------------------------------------
 539
 540    procedure Set_Heterogeneous_Finalize_Address_Unprotected
 541      (Obj          : System.Address;
 542       Fin_Addr_Ptr : Finalize_Address_Ptr)
 543    is
 544    begin
 545       Finalize_Address_Table.Set (Obj, Fin_Addr_Ptr);
 546    end Set_Heterogeneous_Finalize_Address_Unprotected;
 547
 548    --------------------------
 549    -- Set_Is_Heterogeneous --
 550    --------------------------
 551
 552    procedure Set_Is_Heterogeneous (Master : in out Finalization_Master) is
 553    begin
 554       --  Synchronization:
 555       --    Read  - finalization
 556       --    Write - outside
 557
 558       Lock_Task.all;
 559       Master.Is_Homogeneous := False;
 560       Unlock_Task.all;
 561    end Set_Is_Heterogeneous;
 562
 563 end System.Finalization_Masters;