gcc/ada/libgnat/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) 2015-2017, 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_Size;
 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    -- Initialize --
 332    ----------------
 333
 334    overriding procedure Initialize (Master : in out Finalization_Master) is
 335    begin
 336       --  The dummy head must point to itself in both directions
 337
 338       Master.Objects.Next := Master.Objects'Unchecked_Access;
 339       Master.Objects.Prev := Master.Objects'Unchecked_Access;
 340    end Initialize;
 341
 342    --------------------
 343    -- Is_Homogeneous --
 344    --------------------
 345
 346    function Is_Homogeneous (Master : Finalization_Master) return Boolean is
 347    begin
 348       return Master.Is_Homogeneous;
 349    end Is_Homogeneous;
 350
 351    -------------
 352    -- Objects --
 353    -------------
 354
 355    function Objects (Master : Finalization_Master) return FM_Node_Ptr is
 356    begin
 357       return Master.Objects'Unrestricted_Access;
 358    end Objects;
 359
 360    ------------------
 361    -- Print_Master --
 362    ------------------
 363
 364    procedure Print_Master (Master : Finalization_Master) is
 365       Head      : constant FM_Node_Ptr := Master.Objects'Unrestricted_Access;
 366       Head_Seen : Boolean := False;
 367       N_Ptr     : FM_Node_Ptr;
 368
 369    begin
 370       --  Output the basic contents of a master
 371
 372       --    Master   : 0x123456789
 373       --    Is_Hmgen : TURE <or> FALSE
 374       --    Base_Pool: null <or> 0x123456789
 375       --    Fin_Addr : null <or> 0x123456789
 376       --    Fin_Start: TRUE <or> FALSE
 377
 378       Put ("Master   : ");
 379       Put_Line (Address_Image (Master'Address));
 380
 381       Put ("Is_Hmgen : ");
 382       Put_Line (Master.Is_Homogeneous'Img);
 383
 384       Put ("Base_Pool: ");
 385       if Master.Base_Pool = null then
 386          Put_Line ("null");
 387       else
 388          Put_Line (Address_Image (Master.Base_Pool'Address));
 389       end if;
 390
 391       Put ("Fin_Addr : ");
 392       if Master.Finalize_Address = null then
 393          Put_Line ("null");
 394       else
 395          Put_Line (Address_Image (Master.Finalize_Address'Address));
 396       end if;
 397
 398       Put ("Fin_Start: ");
 399       Put_Line (Master.Finalization_Started'Img);
 400
 401       --  Output all chained elements. The format is the following:
 402
 403       --    ^ <or> ? <or> null
 404       --    |Header: 0x123456789 (dummy head)
 405       --    |  Prev: 0x123456789
 406       --    |  Next: 0x123456789
 407       --    V
 408
 409       --  ^ - the current element points back to the correct element
 410       --  ? - the current element points back to an erroneous element
 411       --  n - the current element points back to null
 412
 413       --  Header - the address of the list header
 414       --  Prev   - the address of the list header which the current element
 415       --           points back to
 416       --  Next   - the address of the list header which the current element
 417       --           points to
 418       --  (dummy head) - present if dummy head
 419
 420       N_Ptr := Head;
 421       while N_Ptr /= null loop  --  Should never be null
 422          Put_Line ("V");
 423
 424          --  We see the head initially; we want to exit when we see the head a
 425          --  second time.
 426
 427          if N_Ptr = Head then
 428             exit when Head_Seen;
 429
 430             Head_Seen := True;
 431          end if;
 432
 433          --  The current element is null. This should never happen since the
 434          --  list is circular.
 435
 436          if N_Ptr.Prev = null then
 437             Put_Line ("null (ERROR)");
 438
 439          --  The current element points back to the correct element
 440
 441          elsif N_Ptr.Prev.Next = N_Ptr then
 442             Put_Line ("^");
 443
 444          --  The current element points to an erroneous element
 445
 446          else
 447             Put_Line ("? (ERROR)");
 448          end if;
 449
 450          --  Output the header and fields
 451
 452          Put ("|Header: ");
 453          Put (Address_Image (N_Ptr.all'Address));
 454
 455          --  Detect the dummy head
 456
 457          if N_Ptr = Head then
 458             Put_Line (" (dummy head)");
 459          else
 460             Put_Line ("");
 461          end if;
 462
 463          Put ("|  Prev: ");
 464
 465          if N_Ptr.Prev = null then
 466             Put_Line ("null");
 467          else
 468             Put_Line (Address_Image (N_Ptr.Prev.all'Address));
 469          end if;
 470
 471          Put ("|  Next: ");
 472
 473          if N_Ptr.Next = null then
 474             Put_Line ("null");
 475          else
 476             Put_Line (Address_Image (N_Ptr.Next.all'Address));
 477          end if;
 478
 479          N_Ptr := N_Ptr.Next;
 480       end loop;
 481    end Print_Master;
 482
 483    -------------------
 484    -- Set_Base_Pool --
 485    -------------------
 486
 487    procedure Set_Base_Pool
 488      (Master   : in out Finalization_Master;
 489       Pool_Ptr : Any_Storage_Pool_Ptr)
 490    is
 491    begin
 492       Master.Base_Pool := Pool_Ptr;
 493    end Set_Base_Pool;
 494
 495    --------------------------
 496    -- Set_Finalize_Address --
 497    --------------------------
 498
 499    procedure Set_Finalize_Address
 500      (Master       : in out Finalization_Master;
 501       Fin_Addr_Ptr : Finalize_Address_Ptr)
 502    is
 503    begin
 504       --  Synchronization:
 505       --    Read  - finalization
 506       --    Write - allocation, outside
 507
 508       Lock_Task.all;
 509       Set_Finalize_Address_Unprotected (Master, Fin_Addr_Ptr);
 510       Unlock_Task.all;
 511    end Set_Finalize_Address;
 512
 513    --------------------------------------
 514    -- Set_Finalize_Address_Unprotected --
 515    --------------------------------------
 516
 517    procedure Set_Finalize_Address_Unprotected
 518      (Master       : in out Finalization_Master;
 519       Fin_Addr_Ptr : Finalize_Address_Ptr)
 520    is
 521    begin
 522       if Master.Finalize_Address = null then
 523          Master.Finalize_Address := Fin_Addr_Ptr;
 524       end if;
 525    end Set_Finalize_Address_Unprotected;
 526
 527    ----------------------------------------------------
 528    -- Set_Heterogeneous_Finalize_Address_Unprotected --
 529    ----------------------------------------------------
 530
 531    procedure Set_Heterogeneous_Finalize_Address_Unprotected
 532      (Obj          : System.Address;
 533       Fin_Addr_Ptr : Finalize_Address_Ptr)
 534    is
 535    begin
 536       Finalize_Address_Table.Set (Obj, Fin_Addr_Ptr);
 537    end Set_Heterogeneous_Finalize_Address_Unprotected;
 538
 539    --------------------------
 540    -- Set_Is_Heterogeneous --
 541    --------------------------
 542
 543    procedure Set_Is_Heterogeneous (Master : in out Finalization_Master) is
 544    begin
 545       --  Synchronization:
 546       --    Read  - finalization
 547       --    Write - outside
 548
 549       Lock_Task.all;
 550       Master.Is_Homogeneous := False;
 551       Unlock_Task.all;
 552    end Set_Is_Heterogeneous;
 553
 554 end System.Finalization_Masters;