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