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