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