gcc/ada/s-stposu.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT COMPILER COMPONENTS                         --
   4 --                                                                          --
   5 --        S Y S T E M . S T O R A G E _ P O O L S . S U B P O O L S         --
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                                                                          --
   9 --            Copyright (C) 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 with System.Address_Image;
  36 with System.Finalization_Masters; use System.Finalization_Masters;
  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
  41 package body System.Storage_Pools.Subpools is
  42
  43    Finalize_Address_Table_In_Use : Boolean := False;
  44    --  This flag should be set only when a successfull allocation on a subpool
  45    --  has been performed and the associated Finalize_Address has been added to
  46    --  the hash table in System.Finalization_Masters.
  47
  48    function Address_To_FM_Node_Ptr is
  49      new Ada.Unchecked_Conversion (Address, FM_Node_Ptr);
  50
  51    procedure Attach (N : not null SP_Node_Ptr; L : not null SP_Node_Ptr);
  52    --  Attach a subpool node to a pool
  53
  54    procedure Free is new Ada.Unchecked_Deallocation (SP_Node, SP_Node_Ptr);
  55
  56    procedure Detach (N : not null SP_Node_Ptr);
  57    --  Unhook a subpool node from an arbitrary subpool list
  58
  59    --------------
  60    -- Allocate --
  61    --------------
  62
  63    overriding procedure Allocate
  64      (Pool                     : in out Root_Storage_Pool_With_Subpools;
  65       Storage_Address          : out System.Address;
  66       Size_In_Storage_Elements : System.Storage_Elements.Storage_Count;
  67       Alignment                : System.Storage_Elements.Storage_Count)
  68    is
  69    begin
  70       --  Dispatch to the user-defined implementations of Allocate_From_Subpool
  71       --  and Default_Subpool_For_Pool.
  72
  73       Allocate_From_Subpool
  74         (Root_Storage_Pool_With_Subpools'Class (Pool),
  75          Storage_Address,
  76          Size_In_Storage_Elements,
  77          Alignment,
  78          Default_Subpool_For_Pool
  79            (Root_Storage_Pool_With_Subpools'Class (Pool)));
  80    end Allocate;
  81
  82    -----------------------------
  83    -- Allocate_Any_Controlled --
  84    -----------------------------
  85
  86    procedure Allocate_Any_Controlled
  87      (Pool            : in out Root_Storage_Pool'Class;
  88       Context_Subpool : Subpool_Handle;
  89       Context_Master  : Finalization_Masters.Finalization_Master_Ptr;
  90       Fin_Address     : Finalization_Masters.Finalize_Address_Ptr;
  91       Addr            : out System.Address;
  92       Storage_Size    : System.Storage_Elements.Storage_Count;
  93       Alignment       : System.Storage_Elements.Storage_Count;
  94       Is_Controlled   : Boolean;
  95       On_Subpool      : Boolean)
  96    is
  97       Is_Subpool_Allocation : constant Boolean :=
  98                                 Pool in Root_Storage_Pool_With_Subpools'Class;
  99
 100       Master  : Finalization_Master_Ptr := null;
 101       N_Addr  : Address;
 102       N_Ptr   : FM_Node_Ptr;
 103       N_Size  : Storage_Count;
 104       Subpool : Subpool_Handle := null;
 105
 106       Allocation_Locked : Boolean;
 107       --  This flag stores the state of the associated collection
 108
 109       Header_And_Padding : Storage_Offset;
 110       --  This offset includes the size of a FM_Node plus any additional
 111       --  padding due to a larger alignment.
 112
 113    begin
 114       --  Step 1: Pool-related runtime checks
 115
 116       --  Allocation on a pool_with_subpools. In this scenario there is a
 117       --  master for each subpool. The master of the access type is ignored.
 118
 119       if Is_Subpool_Allocation then
 120
 121          --  Case of an allocation without a Subpool_Handle. Dispatch to the
 122          --  implementation of Default_Subpool_For_Pool.
 123
 124          if Context_Subpool = null then
 125             Subpool :=
 126               Default_Subpool_For_Pool
 127                 (Root_Storage_Pool_With_Subpools'Class (Pool));
 128
 129          --  Allocation with a Subpool_Handle
 130
 131          else
 132             Subpool := Context_Subpool;
 133          end if;
 134
 135          --  Ensure proper ownership and chaining of the subpool
 136
 137          if Subpool.Owner /=
 138               Root_Storage_Pool_With_Subpools'Class (Pool)'Unchecked_Access
 139            or else Subpool.Node = null
 140            or else Subpool.Node.Prev = null
 141            or else Subpool.Node.Next = null
 142          then
 143             raise Program_Error with "incorrect owner of subpool";
 144          end if;
 145
 146          Master := Subpool.Master'Unchecked_Access;
 147
 148       --  Allocation on a simple pool. In this scenario there is a master for
 149       --  each access-to-controlled type. No context subpool should be present.
 150
 151       else
 152          --  If the master is missing, then the expansion of the access type
 153          --  failed to create one. This is a serious error.
 154
 155          if Context_Master = null then
 156             raise Program_Error
 157               with "missing master in pool allocation";
 158
 159          --  If a subpool is present, then this is the result of erroneous
 160          --  allocator expansion. This is not a serious error, but it should
 161          --  still be detected.
 162
 163          elsif Context_Subpool /= null then
 164             raise Program_Error
 165               with "subpool not required in pool allocation";
 166
 167          --  If the allocation is intended to be on a subpool, but the access
 168          --  type's pool does not support subpools, then this is the result of
 169          --  erroneous end-user code.
 170
 171          elsif On_Subpool then
 172             raise Program_Error
 173               with "pool of access type does not support subpools";
 174          end if;
 175
 176          Master := Context_Master;
 177       end if;
 178
 179       --  Step 2: Master, Finalize_Address-related runtime checks and size
 180       --  calculations.
 181
 182       --  Allocation of a descendant from [Limited_]Controlled, a class-wide
 183       --  object or a record with controlled components.
 184
 185       if Is_Controlled then
 186
 187          --  Synchronization:
 188          --    Read  - allocation, finalization
 189          --    Write - finalization
 190
 191          Lock_Task.all;
 192          Allocation_Locked := Finalization_Started (Master.all);
 193          Unlock_Task.all;
 194
 195          --  Do not allow the allocation of controlled objects while the
 196          --  associated master is being finalized.
 197
 198          if Allocation_Locked then
 199             raise Program_Error with "allocation after finalization started";
 200          end if;
 201
 202          --  Check whether primitive Finalize_Address is available. If it is
 203          --  not, then either the expansion of the designated type failed or
 204          --  the expansion of the allocator failed. This is a serious error.
 205
 206          if Fin_Address = null then
 207             raise Program_Error
 208               with "primitive Finalize_Address not available";
 209          end if;
 210
 211          --  The size must acount for the hidden header preceding the object.
 212          --  Account for possible padding space before the header due to a
 213          --  larger alignment.
 214
 215          Header_And_Padding := Header_Size_With_Padding (Alignment);
 216
 217          N_Size := Storage_Size + Header_And_Padding;
 218
 219       --  Non-controlled allocation
 220
 221       else
 222          N_Size := Storage_Size;
 223       end if;
 224
 225       --  Step 3: Allocation of object
 226
 227       --  For descendants of Root_Storage_Pool_With_Subpools, dispatch to the
 228       --  implementation of Allocate_From_Subpool.
 229
 230       if Is_Subpool_Allocation then
 231          Allocate_From_Subpool
 232            (Root_Storage_Pool_With_Subpools'Class (Pool),
 233             N_Addr, N_Size, Alignment, Subpool);
 234
 235       --  For descendants of Root_Storage_Pool, dispatch to the implementation
 236       --  of Allocate.
 237
 238       else
 239          Allocate (Pool, N_Addr, N_Size, Alignment);
 240       end if;
 241
 242       --  Step 4: Attachment
 243
 244       if Is_Controlled then
 245          Lock_Task.all;
 246
 247          --  Map the allocated memory into a FM_Node record. This converts the
 248          --  top of the allocated bits into a list header. If there is padding
 249          --  due to larger alignment, the header is placed right next to the
 250          --  object:
 251
 252          --     N_Addr  N_Ptr
 253          --     |       |
 254          --     V       V
 255          --     +-------+---------------+----------------------+
 256          --     |Padding|    Header     |        Object        |
 257          --     +-------+---------------+----------------------+
 258          --     ^       ^               ^
 259          --     |       +- Header_Size -+
 260          --     |                       |
 261          --     +- Header_And_Padding --+
 262
 263          N_Ptr := Address_To_FM_Node_Ptr
 264                     (N_Addr + Header_And_Padding - Header_Offset);
 265
 266          --  Prepend the allocated object to the finalization master
 267
 268          --  Synchronization:
 269          --    Write - allocation, deallocation, finalization
 270
 271          Attach_Unprotected (N_Ptr, Objects (Master.all));
 272
 273          --  Move the address from the hidden list header to the start of the
 274          --  object. This operation effectively hides the list header.
 275
 276          Addr := N_Addr + Header_And_Padding;
 277
 278          --  Homogeneous masters service the following:
 279
 280          --    1) Allocations on / Deallocations from regular pools
 281          --    2) Named access types
 282          --    3) Most cases of anonymous access types usage
 283
 284          --  Synchronization:
 285          --    Read  - allocation, finalization
 286          --    Write - outside
 287
 288          if Master.Is_Homogeneous then
 289
 290             --  Synchronization:
 291             --    Read  - finalization
 292             --    Write - allocation, outside
 293
 294             Set_Finalize_Address_Unprotected (Master.all, Fin_Address);
 295
 296          --  Heterogeneous masters service the following:
 297
 298          --    1) Allocations on / Deallocations from subpools
 299          --    2) Certain cases of anonymous access types usage
 300
 301          else
 302             --  Synchronization:
 303             --    Read  - finalization
 304             --    Write - allocation, deallocation
 305
 306             Set_Heterogeneous_Finalize_Address_Unprotected (Addr, Fin_Address);
 307             Finalize_Address_Table_In_Use := True;
 308          end if;
 309
 310          Unlock_Task.all;
 311
 312       --  Non-controlled allocation
 313
 314       else
 315          Addr := N_Addr;
 316       end if;
 317    end Allocate_Any_Controlled;
 318
 319    ------------
 320    -- Attach --
 321    ------------
 322
 323    procedure Attach (N : not null SP_Node_Ptr; L : not null SP_Node_Ptr) is
 324    begin
 325       --  Ensure that the node has not been attached already
 326
 327       pragma Assert (N.Prev = null and then N.Next = null);
 328
 329       Lock_Task.all;
 330
 331       L.Next.Prev := N;
 332       N.Next := L.Next;
 333       L.Next := N;
 334       N.Prev := L;
 335
 336       Unlock_Task.all;
 337
 338       --  Note: No need to unlock in case of an exception because the above
 339       --  code can never raise one.
 340    end Attach;
 341
 342    -------------------------------
 343    -- Deallocate_Any_Controlled --
 344    -------------------------------
 345
 346    procedure Deallocate_Any_Controlled
 347      (Pool          : in out Root_Storage_Pool'Class;
 348       Addr          : System.Address;
 349       Storage_Size  : System.Storage_Elements.Storage_Count;
 350       Alignment     : System.Storage_Elements.Storage_Count;
 351       Is_Controlled : Boolean)
 352    is
 353       N_Addr : Address;
 354       N_Ptr  : FM_Node_Ptr;
 355       N_Size : Storage_Count;
 356
 357       Header_And_Padding : Storage_Offset;
 358       --  This offset includes the size of a FM_Node plus any additional
 359       --  padding due to a larger alignment.
 360
 361    begin
 362       --  Step 1: Detachment
 363
 364       if Is_Controlled then
 365          Lock_Task.all;
 366
 367          --  Destroy the relation pair object - Finalize_Address since it is no
 368          --  longer needed.
 369
 370          if Finalize_Address_Table_In_Use then
 371
 372             --  Synchronization:
 373             --    Read  - finalization
 374             --    Write - allocation, deallocation
 375
 376             Delete_Finalize_Address_Unprotected (Addr);
 377          end if;
 378
 379          --  Account for possible padding space before the header due to a
 380          --  larger alignment.
 381
 382          Header_And_Padding := Header_Size_With_Padding (Alignment);
 383
 384          --    N_Addr  N_Ptr           Addr (from input)
 385          --    |       |               |
 386          --    V       V               V
 387          --    +-------+---------------+----------------------+
 388          --    |Padding|    Header     |        Object        |
 389          --    +-------+---------------+----------------------+
 390          --    ^       ^               ^
 391          --    |       +- Header_Size -+
 392          --    |                       |
 393          --    +- Header_And_Padding --+
 394
 395          --  Convert the bits preceding the object into a list header
 396
 397          N_Ptr := Address_To_FM_Node_Ptr (Addr - Header_Offset);
 398
 399          --  Detach the object from the related finalization master. This
 400          --  action does not need to know the prior context used during
 401          --  allocation.
 402
 403          --  Synchronization:
 404          --    Write - allocation, deallocation, finalization
 405
 406          Detach_Unprotected (N_Ptr);
 407
 408          --  Move the address from the object to the beginning of the list
 409          --  header.
 410
 411          N_Addr := Addr - Header_And_Padding;
 412
 413          --  The size of the deallocated object must include the size of the
 414          --  hidden list header.
 415
 416          N_Size := Storage_Size + Header_And_Padding;
 417
 418          Unlock_Task.all;
 419
 420       else
 421          N_Addr := Addr;
 422          N_Size := Storage_Size;
 423       end if;
 424
 425       --  Step 2: Deallocation
 426
 427       --  Dispatch to the proper implementation of Deallocate. This action
 428       --  covers both Root_Storage_Pool and Root_Storage_Pool_With_Subpools
 429       --  implementations.
 430
 431       Deallocate (Pool, N_Addr, N_Size, Alignment);
 432    end Deallocate_Any_Controlled;
 433
 434    ------------------------------
 435    -- Default_Subpool_For_Pool --
 436    ------------------------------
 437
 438    function Default_Subpool_For_Pool
 439      (Pool : Root_Storage_Pool_With_Subpools) return not null Subpool_Handle
 440    is
 441    begin
 442       raise Program_Error;
 443       return Pool.Subpools.Subpool;
 444    end Default_Subpool_For_Pool;
 445
 446    ------------
 447    -- Detach --
 448    ------------
 449
 450    procedure Detach (N : not null SP_Node_Ptr) is
 451    begin
 452       --  Ensure that the node is attached to some list
 453
 454       pragma Assert (N.Next /= null and then N.Prev /= null);
 455
 456       Lock_Task.all;
 457
 458       N.Prev.Next := N.Next;
 459       N.Next.Prev := N.Prev;
 460       N.Prev := null;
 461       N.Next := null;
 462
 463       Unlock_Task.all;
 464
 465       --  Note: No need to unlock in case of an exception because the above
 466       --  code can never raise one.
 467    end Detach;
 468
 469    --------------
 470    -- Finalize --
 471    --------------
 472
 473    overriding procedure Finalize (Controller : in out Pool_Controller) is
 474    begin
 475       Finalize_Pool (Controller.Enclosing_Pool.all);
 476    end Finalize;
 477
 478    -------------------
 479    -- Finalize_Pool --
 480    -------------------
 481
 482    procedure Finalize_Pool (Pool : in out Root_Storage_Pool_With_Subpools) is
 483       Curr_Ptr : SP_Node_Ptr;
 484       Ex_Occur : Exception_Occurrence;
 485       Raised   : Boolean := False;
 486
 487       function Is_Empty_List (L : not null SP_Node_Ptr) return Boolean;
 488       --  Determine whether a list contains only one element, the dummy head
 489
 490       -------------------
 491       -- Is_Empty_List --
 492       -------------------
 493
 494       function Is_Empty_List (L : not null SP_Node_Ptr) return Boolean is
 495       begin
 496          return L.Next = L and then L.Prev = L;
 497       end Is_Empty_List;
 498
 499    --  Start of processing for Finalize_Pool
 500
 501    begin
 502       --  It is possible for multiple tasks to cause the finalization of a
 503       --  common pool. Allow only one task to finalize the contents.
 504
 505       if Pool.Finalization_Started then
 506          return;
 507       end if;
 508
 509       --  Lock the pool to prevent the creation of additional subpools while
 510       --  the available ones are finalized. The pool remains locked because
 511       --  either it is about to be deallocated or the associated access type
 512       --  is about to go out of scope.
 513
 514       Pool.Finalization_Started := True;
 515
 516       while not Is_Empty_List (Pool.Subpools'Unchecked_Access) loop
 517          Curr_Ptr := Pool.Subpools.Next;
 518
 519          --  Perform the following actions:
 520
 521          --    1) Finalize all objects chained on the subpool's master
 522          --    2) Remove the the subpool from the owner's list of subpools
 523          --    3) Deallocate the doubly linked list node associated with the
 524          --       subpool.
 525
 526          begin
 527             Finalize_Subpool (Curr_Ptr.Subpool);
 528
 529          exception
 530             when Fin_Occur : others =>
 531                if not Raised then
 532                   Raised := True;
 533                   Save_Occurrence (Ex_Occur, Fin_Occur);
 534                end if;
 535          end;
 536       end loop;
 537
 538       --  If the finalization of a particular master failed, reraise the
 539       --  exception now.
 540
 541       if Raised then
 542          Reraise_Occurrence (Ex_Occur);
 543       end if;
 544    end Finalize_Pool;
 545
 546    ----------------------
 547    -- Finalize_Subpool --
 548    ----------------------
 549
 550    procedure Finalize_Subpool (Subpool : not null Subpool_Handle) is
 551    begin
 552       --  Do nothing if the subpool was never used
 553
 554       if Subpool.Owner = null or else Subpool.Node = null then
 555          return;
 556       end if;
 557
 558       --  Clean up all controlled objects chained on the subpool's master
 559
 560       Finalize (Subpool.Master);
 561
 562       --  Remove the subpool from its owner's list of subpools
 563
 564       Detach (Subpool.Node);
 565
 566       --  Destroy the associated doubly linked list node which was created in
 567       --  Set_Pool_Of_Subpool.
 568
 569       Free (Subpool.Node);
 570    end Finalize_Subpool;
 571
 572    ------------------------------
 573    -- Header_Size_With_Padding --
 574    ------------------------------
 575
 576    function Header_Size_With_Padding
 577      (Alignment : System.Storage_Elements.Storage_Count)
 578       return System.Storage_Elements.Storage_Count
 579    is
 580       Size : constant Storage_Count := Header_Size;
 581
 582    begin
 583       if Size mod Alignment = 0 then
 584          return Size;
 585
 586       --  Add enough padding to reach the nearest multiple of the alignment
 587       --  rounding up.
 588
 589       else
 590          return ((Size + Alignment - 1) / Alignment) * Alignment;
 591       end if;
 592    end Header_Size_With_Padding;
 593
 594    ----------------
 595    -- Initialize --
 596    ----------------
 597
 598    overriding procedure Initialize (Controller : in out Pool_Controller) is
 599    begin
 600       Initialize_Pool (Controller.Enclosing_Pool.all);
 601    end Initialize;
 602
 603    ---------------------
 604    -- Initialize_Pool --
 605    ---------------------
 606
 607    procedure Initialize_Pool (Pool : in out Root_Storage_Pool_With_Subpools) is
 608    begin
 609       --  The dummy head must point to itself in both directions
 610
 611       Pool.Subpools.Next := Pool.Subpools'Unchecked_Access;
 612       Pool.Subpools.Prev := Pool.Subpools'Unchecked_Access;
 613    end Initialize_Pool;
 614
 615    ---------------------
 616    -- Pool_Of_Subpool --
 617    ---------------------
 618
 619    function Pool_Of_Subpool
 620      (Subpool : not null Subpool_Handle)
 621       return access Root_Storage_Pool_With_Subpools'Class
 622    is
 623    begin
 624       return Subpool.Owner;
 625    end Pool_Of_Subpool;
 626
 627    ----------------
 628    -- Print_Pool --
 629    ----------------
 630
 631    procedure Print_Pool (Pool : Root_Storage_Pool_With_Subpools) is
 632       Head      : constant SP_Node_Ptr := Pool.Subpools'Unrestricted_Access;
 633       Head_Seen : Boolean := False;
 634       SP_Ptr    : SP_Node_Ptr;
 635
 636    begin
 637       --  Output the contents of the pool
 638
 639       --    Pool      : 0x123456789
 640       --    Subpools  : 0x123456789
 641       --    Fin_Start : TRUE <or> FALSE
 642       --    Controller: OK <or> NOK
 643
 644       Put ("Pool      : ");
 645       Put_Line (Address_Image (Pool'Address));
 646
 647       Put ("Subpools  : ");
 648       Put_Line (Address_Image (Pool.Subpools'Address));
 649
 650       Put ("Fin_Start : ");
 651       Put_Line (Pool.Finalization_Started'Img);
 652
 653       Put ("Controlled: ");
 654       if Pool.Controller.Enclosing_Pool = Pool'Unrestricted_Access then
 655          Put_Line ("OK");
 656       else
 657          Put_Line ("NOK (ERROR)");
 658       end if;
 659
 660       SP_Ptr := Head;
 661       while SP_Ptr /= null loop  --  Should never be null
 662          Put_Line ("V");
 663
 664          --  We see the head initially; we want to exit when we see the head a
 665          --  second time.
 666
 667          if SP_Ptr = Head then
 668             exit when Head_Seen;
 669
 670             Head_Seen := True;
 671          end if;
 672
 673          --  The current element is null. This should never happend since the
 674          --  list is circular.
 675
 676          if SP_Ptr.Prev = null then
 677             Put_Line ("null (ERROR)");
 678
 679          --  The current element points back to the correct element
 680
 681          elsif SP_Ptr.Prev.Next = SP_Ptr then
 682             Put_Line ("^");
 683
 684          --  The current element points to an erroneous element
 685
 686          else
 687             Put_Line ("? (ERROR)");
 688          end if;
 689
 690          --  Output the contents of the node
 691
 692          Put ("|Header: ");
 693          Put (Address_Image (SP_Ptr.all'Address));
 694          if SP_Ptr = Head then
 695             Put_Line (" (dummy head)");
 696          else
 697             Put_Line ("");
 698          end if;
 699
 700          Put ("|  Prev: ");
 701
 702          if SP_Ptr.Prev = null then
 703             Put_Line ("null");
 704          else
 705             Put_Line (Address_Image (SP_Ptr.Prev.all'Address));
 706          end if;
 707
 708          Put ("|  Next: ");
 709
 710          if SP_Ptr.Next = null then
 711             Put_Line ("null");
 712          else
 713             Put_Line (Address_Image (SP_Ptr.Next.all'Address));
 714          end if;
 715
 716          Put ("|  Subp: ");
 717
 718          if SP_Ptr.Subpool = null then
 719             Put_Line ("null");
 720          else
 721             Put_Line (Address_Image (SP_Ptr.Subpool.all'Address));
 722          end if;
 723
 724          SP_Ptr := SP_Ptr.Next;
 725       end loop;
 726    end Print_Pool;
 727
 728    -------------------
 729    -- Print_Subpool --
 730    -------------------
 731
 732    procedure Print_Subpool (Subpool : Subpool_Handle) is
 733    begin
 734       if Subpool = null then
 735          Put_Line ("null");
 736          return;
 737       end if;
 738
 739       --  Output the contents of a subpool
 740
 741       --    Owner : 0x123456789
 742       --    Master: 0x123456789
 743       --    Node  : 0x123456789
 744
 745       Put ("Owner : ");
 746       if Subpool.Owner = null then
 747          Put_Line ("null");
 748       else
 749          Put_Line (Address_Image (Subpool.Owner'Address));
 750       end if;
 751
 752       Put ("Master: ");
 753       Put_Line (Address_Image (Subpool.Master'Address));
 754
 755       Put ("Node  : ");
 756       if Subpool.Node = null then
 757          Put ("null");
 758
 759          if Subpool.Owner = null then
 760             Put_Line (" OK");
 761          else
 762             Put_Line (" (ERROR)");
 763          end if;
 764       else
 765          Put_Line (Address_Image (Subpool.Node'Address));
 766       end if;
 767
 768       Print_Master (Subpool.Master);
 769    end Print_Subpool;
 770
 771    -------------------------
 772    -- Set_Pool_Of_Subpool --
 773    -------------------------
 774
 775    procedure Set_Pool_Of_Subpool
 776      (Subpool : not null Subpool_Handle;
 777       To      : in out Root_Storage_Pool_With_Subpools'Class)
 778    is
 779       N_Ptr : SP_Node_Ptr;
 780
 781    begin
 782       --  If the subpool is already owned, raise Program_Error. This is a
 783       --  direct violation of the RM rules.
 784
 785       if Subpool.Owner /= null then
 786          raise Program_Error with "subpool already belongs to a pool";
 787       end if;
 788
 789       --  Prevent the creation of a new subpool while the owner is being
 790       --  finalized. This is a serious error.
 791
 792       if To.Finalization_Started then
 793          raise Program_Error
 794            with "subpool creation after finalization started";
 795       end if;
 796
 797       Subpool.Owner := To'Unchecked_Access;
 798
 799       --  Create a subpool node and decorate it. Since this node is not
 800       --  allocated on the owner's pool, it must be explicitly destroyed by
 801       --  Finalize_And_Detach.
 802
 803       N_Ptr := new SP_Node;
 804       N_Ptr.Subpool := Subpool;
 805       Subpool.Node := N_Ptr;
 806
 807       Attach (N_Ptr, To.Subpools'Unchecked_Access);
 808
 809       --  Mark the subpool's master as being a heterogeneous collection of
 810       --  controlled objects.
 811
 812       Set_Is_Heterogeneous (Subpool.Master);
 813    end Set_Pool_Of_Subpool;
 814
 815 end System.Storage_Pools.Subpools;