gcc/ada/a-fihema.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT COMPILER COMPONENTS                         --
   4 --                                                                          --
   5 --     A D A . F I N A L I Z A T I O N . H E A P _ M A N A G E M E N T      --
   6 --                                                                          --
   7 --                                B o d y                                   --
   8 --                                                                          --
   9 --          Copyright (C) 2008-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 with Ada.Unchecked_Conversion;
  34 with Ada.Unchecked_Deallocation;
  35
  36 with System;                  use System;
  37 with System.Address_Image;
  38 with System.IO;               use System.IO;
  39 with System.Soft_Links;       use System.Soft_Links;
  40 with System.Storage_Elements; use System.Storage_Elements;
  41 with System.Storage_Pools;    use System.Storage_Pools;
  42
  43 package body Ada.Finalization.Heap_Management is
  44
  45    Header_Size   : constant Storage_Count  := Node'Size / Storage_Unit;
  46    --  Size of the header in bytes. Added to Storage_Size requested by
  47    --  Allocate/Deallocate to determine the Storage_Size passed to the
  48    --  underlying pool.
  49
  50    Header_Offset : constant Storage_Offset := Header_Size;
  51    --  Offset from the header to the actual object. Used to get from the
  52    --  address of a header to the address of the actual object, and vice-versa.
  53
  54    function Address_To_Node_Ptr is
  55      new Ada.Unchecked_Conversion (Address, Node_Ptr);
  56
  57    procedure Attach (N : Node_Ptr; L : Node_Ptr);
  58    --  Prepend a node to a list
  59
  60    procedure Detach (N : Node_Ptr);
  61    --  Unhook a node from an arbitrary list
  62
  63    procedure Free is new Ada.Unchecked_Deallocation (Node, Node_Ptr);
  64
  65    ---------------------------
  66    -- Add_Offset_To_Address --
  67    ---------------------------
  68
  69    function Add_Offset_To_Address
  70      (Addr   : System.Address;
  71       Offset : System.Storage_Elements.Storage_Offset) return System.Address
  72    is
  73    begin
  74       return System.Storage_Elements."+" (Addr, Offset);
  75    end Add_Offset_To_Address;
  76
  77    --------------
  78    -- Allocate --
  79    --------------
  80
  81    procedure Allocate
  82      (Collection   : in out Finalization_Collection;
  83       Addr         : out System.Address;
  84       Storage_Size : System.Storage_Elements.Storage_Count;
  85       Alignment    : System.Storage_Elements.Storage_Count;
  86       Needs_Header : Boolean := True)
  87    is
  88    begin
  89       --  Allocation of an object with controlled parts
  90
  91       if Needs_Header then
  92
  93          --  Do not allow the allocation of controlled objects while the
  94          --  associated collection is being finalized.
  95
  96          if Collection.Finalization_Started then
  97             raise Program_Error with "allocation after finalization started";
  98          end if;
  99
 100          declare
 101             N_Addr : Address;
 102             N_Ptr  : Node_Ptr;
 103
 104          begin
 105             --  Use the underlying pool to allocate enough space for the object
 106             --  and the list header. The returned address points to the list
 107             --  header. If locking is necessary, it will be done by the
 108             --  underlying pool.
 109
 110             Allocate
 111               (Collection.Base_Pool.all,
 112                N_Addr,
 113                Storage_Size + Header_Size,
 114                Alignment);
 115
 116             --  Map the allocated memory into a Node record. This converts the
 117             --  top of the allocated bits into a list header.
 118
 119             N_Ptr := Address_To_Node_Ptr (N_Addr);
 120             Attach (N_Ptr, Collection.Objects);
 121
 122             --  Move the address from Prev to the start of the object. This
 123             --  operation effectively hides the list header.
 124
 125             Addr := N_Addr + Header_Offset;
 126          end;
 127
 128       --  Allocation of a non-controlled object
 129
 130       else
 131          Allocate
 132            (Collection.Base_Pool.all,
 133             Addr,
 134             Storage_Size,
 135             Alignment);
 136       end if;
 137    end Allocate;
 138
 139    ------------
 140    -- Attach --
 141    ------------
 142
 143    procedure Attach (N : Node_Ptr; L : Node_Ptr) is
 144    begin
 145       Lock_Task.all;
 146
 147       L.Next.Prev := N;
 148       N.Next := L.Next;
 149       L.Next := N;
 150       N.Prev := L;
 151
 152       Unlock_Task.all;
 153
 154    exception
 155       when others =>
 156          Unlock_Task.all;
 157          raise;
 158    end Attach;
 159
 160    ---------------
 161    -- Base_Pool --
 162    ---------------
 163
 164    function Base_Pool
 165      (Collection : Finalization_Collection) return Any_Storage_Pool_Ptr
 166    is
 167    begin
 168       return Collection.Base_Pool;
 169    end Base_Pool;
 170
 171    ----------------
 172    -- Deallocate --
 173    ----------------
 174
 175    procedure Deallocate
 176      (Collection   : in out Finalization_Collection;
 177       Addr         : System.Address;
 178       Storage_Size : System.Storage_Elements.Storage_Count;
 179       Alignment    : System.Storage_Elements.Storage_Count;
 180       Has_Header   : Boolean := True)
 181    is
 182    begin
 183       --  Deallocation of an object with controlled parts
 184
 185       if Has_Header then
 186          declare
 187             N_Addr : Address;
 188             N_Ptr  : Node_Ptr;
 189
 190          begin
 191             --  Move the address from the object to the beginning of the list
 192             --  header.
 193
 194             N_Addr := Addr - Header_Offset;
 195
 196             --  Converts the bits preceding the object into a list header
 197
 198             N_Ptr := Address_To_Node_Ptr (N_Addr);
 199             Detach (N_Ptr);
 200
 201             --  Use the underlying pool to destroy the object along with the
 202             --  list header.
 203
 204             Deallocate
 205               (Collection.Base_Pool.all,
 206                N_Addr,
 207                Storage_Size + Header_Size,
 208                Alignment);
 209          end;
 210
 211       --  Deallocation of a non-controlled object
 212
 213       else
 214          Deallocate
 215            (Collection.Base_Pool.all,
 216             Addr,
 217             Storage_Size,
 218             Alignment);
 219       end if;
 220    end Deallocate;
 221
 222    ------------
 223    -- Detach --
 224    ------------
 225
 226    procedure Detach (N : Node_Ptr) is
 227    begin
 228       Lock_Task.all;
 229
 230       if N.Prev /= null
 231         and then N.Next /= null
 232       then
 233          N.Prev.Next := N.Next;
 234          N.Next.Prev := N.Prev;
 235          N.Prev := null;
 236          N.Next := null;
 237       end if;
 238
 239       Unlock_Task.all;
 240
 241    exception
 242       when others =>
 243          Unlock_Task.all;
 244          raise;
 245    end Detach;
 246
 247    --------------
 248    -- Finalize --
 249    --------------
 250
 251    overriding procedure Finalize
 252      (Collection : in out Finalization_Collection)
 253    is
 254       function Head (L : Node_Ptr) return Node_Ptr;
 255       --  Return the node that comes after the dummy head
 256
 257       function Is_Dummy_Head (N : Node_Ptr) return Boolean;
 258       --  Determine whether a node acts as a dummy head. Such nodes do not
 259       --  have an actual "object" attached to them and point to themselves.
 260
 261       function Is_Empty_List (L : Node_Ptr) return Boolean;
 262       --  Determine whether a list is empty
 263
 264       function Node_Ptr_To_Address (N : Node_Ptr) return Address;
 265       --  Not the reverse of Address_To_Node_Ptr. Return the address of the
 266       --  object following the list header.
 267
 268       ----------
 269       -- Head --
 270       ----------
 271
 272       function Head (L : Node_Ptr) return Node_Ptr is
 273       begin
 274          return L.Next;
 275       end Head;
 276
 277       -------------------
 278       -- Is_Dummy_Head --
 279       -------------------
 280
 281       function Is_Dummy_Head (N : Node_Ptr) return Boolean is
 282       begin
 283          --  To be a dummy head, the node must point to itself in both
 284          --  directions.
 285
 286          return
 287            N.Next /= null
 288              and then N.Next = N
 289              and then N.Prev /= null
 290              and then N.Prev = N;
 291       end Is_Dummy_Head;
 292
 293       -------------------
 294       -- Is_Empty_List --
 295       -------------------
 296
 297       function Is_Empty_List (L : Node_Ptr) return Boolean is
 298       begin
 299          return L = null or else Is_Dummy_Head (L);
 300       end Is_Empty_List;
 301
 302       -------------------------
 303       -- Node_Ptr_To_Address --
 304       -------------------------
 305
 306       function Node_Ptr_To_Address (N : Node_Ptr) return Address is
 307       begin
 308          return N.all'Address + Header_Offset;
 309       end Node_Ptr_To_Address;
 310
 311       Curr_Ptr : Node_Ptr;
 312       Ex_Occur : Exception_Occurrence;
 313       Next_Ptr : Node_Ptr;
 314       Raised   : Boolean := False;
 315
 316    --  Start of processing for Finalize
 317
 318    begin
 319       --  Set Finalization_Started to prevent any allocations of objects with
 320       --  controlled parts during finalization. The associated access type is
 321       --  about to go out of scope; Finalization_Started is never again
 322       --  modified.
 323
 324       Collection.Finalization_Started := True;
 325
 326       while not Is_Empty_List (Collection.Objects) loop
 327
 328          --  Find the real head of the collection, skipping the dummy head
 329
 330          Curr_Ptr := Head (Collection.Objects);
 331
 332          --  If the dummy head is the only remaining node, all real objects
 333          --  have already been detached and finalized.
 334
 335          if Is_Dummy_Head (Curr_Ptr) then
 336             exit;
 337          end if;
 338
 339          --  Store the next node now since the detachment will destroy the
 340          --  reference to it.
 341
 342          Next_Ptr := Curr_Ptr.Next;
 343
 344          --  Remove the current node from the list
 345
 346          Detach (Curr_Ptr);
 347
 348          --  ??? Kludge: Don't do anything until the proper place to set
 349          --  primitive Finalize_Address has been determined.
 350
 351          if Collection.Finalize_Address /= null then
 352             begin
 353                Collection.Finalize_Address (Node_Ptr_To_Address (Curr_Ptr));
 354
 355             exception
 356                when Fin_Except : others =>
 357                   if not Raised then
 358                      Raised := True;
 359                      Save_Occurrence (Ex_Occur, Fin_Except);
 360                   end if;
 361             end;
 362          end if;
 363
 364          Curr_Ptr := Next_Ptr;
 365       end loop;
 366
 367       --  Deallocate the dummy head
 368
 369       Free (Collection.Objects);
 370
 371       --  If the finalization of a particular node raised an exception, reraise
 372       --  it after the remainder of the list has been finalized.
 373
 374       if Raised then
 375          Reraise_Occurrence (Ex_Occur);
 376       end if;
 377    end Finalize;
 378
 379    ----------------
 380    -- Initialize --
 381    ----------------
 382
 383    overriding procedure Initialize
 384      (Collection : in out Finalization_Collection)
 385    is
 386    begin
 387       Collection.Objects := new Node;
 388
 389       --  The dummy head must point to itself in both directions
 390
 391       Collection.Objects.Next := Collection.Objects;
 392       Collection.Objects.Prev := Collection.Objects;
 393    end Initialize;
 394
 395    ----------
 396    -- pcol --
 397    ----------
 398
 399    procedure pcol (Collection : Finalization_Collection) is
 400       Head_Seen : Boolean := False;
 401       N_Ptr     : Node_Ptr;
 402
 403    begin
 404       --  Output the basic contents of the collection
 405
 406       --    Collection: 0x123456789
 407       --    Base_Pool : null <or> 0x123456789
 408       --    Fin_Addr  : null <or> 0x123456789
 409       --    Fin_Start : TRUE <or> FALSE
 410
 411       Put ("Collection: ");
 412       Put_Line (Address_Image (Collection'Address));
 413
 414       Put ("Base_Pool : ");
 415       if Collection.Base_Pool = null then
 416          Put_Line (" null");
 417       else
 418          Put_Line (Address_Image (Collection.Base_Pool'Address));
 419       end if;
 420
 421       Put ("Fin_Addr  : ");
 422       if Collection.Finalize_Address = null then
 423          Put_Line ("null");
 424       else
 425          Put_Line (Address_Image (Collection.Finalize_Address'Address));
 426       end if;
 427
 428       Put ("Fin_Start : ");
 429       Put_Line (Collection.Finalization_Started'Img);
 430
 431       --  Output all chained elements. The format is the following:
 432
 433       --    ^ <or> ? <or> null
 434       --    |Header: 0x123456789 (dummy head)
 435       --    |  Prev: 0x123456789
 436       --    |  Next: 0x123456789
 437       --    V
 438
 439       --  ^ - the current element points back to the correct element
 440       --  ? - the current element points back to an erroneous element
 441       --  n - the current element points back to null
 442
 443       --  Header - the address of the list header
 444       --  Prev   - the address of the list header which the current element
 445       --         - points back to
 446       --  Next   - the address of the list header which the current element
 447       --         - points to
 448       --  (dummy head) - present if dummy head
 449
 450       N_Ptr := Collection.Objects;
 451
 452       while N_Ptr /= null loop
 453          Put_Line ("V");
 454
 455          --  The current node is the head. If we have already traversed the
 456          --  chain, the head will be encountered again since the chain is
 457          --  circular.
 458
 459          if N_Ptr = Collection.Objects then
 460             if Head_Seen then
 461                exit;
 462             else
 463                Head_Seen := True;
 464             end if;
 465          end if;
 466
 467          --  The current element is null. This should never happen since the
 468          --  list is circular.
 469
 470          if N_Ptr.Prev = null then
 471             Put_Line ("null (ERROR)");
 472
 473          --  The current element points back to the correct element
 474
 475          elsif N_Ptr.Prev.Next = N_Ptr then
 476             Put_Line ("^");
 477
 478          --  The current element points to an erroneous element
 479
 480          else
 481             Put_Line ("? (ERROR)");
 482          end if;
 483
 484          --  Output the header and fields
 485
 486          Put ("|Header: ");
 487          Put (Address_Image (N_Ptr.all'Address));
 488
 489          --  Detect the dummy head
 490
 491          if N_Ptr = Collection.Objects then
 492             Put_Line (" (dummy head)");
 493          else
 494             Put_Line ("");
 495          end if;
 496
 497          Put ("|  Prev: ");
 498          if N_Ptr.Prev = null then
 499             Put_Line ("null");
 500          else
 501             Put_Line (Address_Image (N_Ptr.Prev.all'Address));
 502          end if;
 503
 504          Put ("|  Next: ");
 505          if N_Ptr.Next = null then
 506             Put_Line ("null");
 507          else
 508             Put_Line (Address_Image (N_Ptr.Next.all'Address));
 509          end if;
 510
 511          N_Ptr := N_Ptr.Next;
 512       end loop;
 513    end pcol;
 514
 515    ------------------------------
 516    -- Set_Finalize_Address_Ptr --
 517    ------------------------------
 518
 519    procedure Set_Finalize_Address_Ptr
 520      (Collection : in out Finalization_Collection;
 521       Proc_Ptr   : Finalize_Address_Ptr)
 522    is
 523    begin
 524       Collection.Finalize_Address := Proc_Ptr;
 525    end Set_Finalize_Address_Ptr;
 526
 527    --------------------------
 528    -- Set_Storage_Pool_Ptr --
 529    --------------------------
 530
 531    procedure Set_Storage_Pool_Ptr
 532      (Collection : in out Finalization_Collection;
 533       Pool_Ptr   : Any_Storage_Pool_Ptr)
 534    is
 535    begin
 536       Collection.Base_Pool := Pool_Ptr;
 537    end Set_Storage_Pool_Ptr;
 538
 539 end Ada.Finalization.Heap_Management;