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