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