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