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