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-2012, 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_Offset); 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_Offset); 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 : Root_Storage_Pool_With_Subpools) return not null Subpool_Handle 460 is 461 begin 462 raise Program_Error; 463 return Pool.Subpools.Subpool; 464 end Default_Subpool_For_Pool; 465 466 ------------ 467 -- Detach -- 468 ------------ 469 470 procedure Detach (N : not null SP_Node_Ptr) is 471 begin 472 -- Ensure that the node is attached to some list 473 474 pragma Assert (N.Next /= null and then N.Prev /= null); 475 476 Lock_Task.all; 477 478 N.Prev.Next := N.Next; 479 N.Next.Prev := N.Prev; 480 N.Prev := null; 481 N.Next := null; 482 483 Unlock_Task.all; 484 485 -- Note: No need to unlock in case of an exception because the above 486 -- code can never raise one. 487 end Detach; 488 489 -------------- 490 -- Finalize -- 491 -------------- 492 493 overriding procedure Finalize (Controller : in out Pool_Controller) is 494 begin 495 Finalize_Pool (Controller.Enclosing_Pool.all); 496 end Finalize; 497 498 ------------------- 499 -- Finalize_Pool -- 500 ------------------- 501 502 procedure Finalize_Pool (Pool : in out Root_Storage_Pool_With_Subpools) is 503 Curr_Ptr : SP_Node_Ptr; 504 Ex_Occur : Exception_Occurrence; 505 Raised : Boolean := False; 506 507 function Is_Empty_List (L : not null SP_Node_Ptr) return Boolean; 508 -- Determine whether a list contains only one element, the dummy head 509 510 ------------------- 511 -- Is_Empty_List -- 512 ------------------- 513 514 function Is_Empty_List (L : not null SP_Node_Ptr) return Boolean is 515 begin 516 return L.Next = L and then L.Prev = L; 517 end Is_Empty_List; 518 519 -- Start of processing for Finalize_Pool 520 521 begin 522 -- It is possible for multiple tasks to cause the finalization of a 523 -- common pool. Allow only one task to finalize the contents. 524 525 if Pool.Finalization_Started then 526 return; 527 end if; 528 529 -- Lock the pool to prevent the creation of additional subpools while 530 -- the available ones are finalized. The pool remains locked because 531 -- either it is about to be deallocated or the associated access type 532 -- is about to go out of scope. 533 534 Pool.Finalization_Started := True; 535 536 while not Is_Empty_List (Pool.Subpools'Unchecked_Access) loop 537 Curr_Ptr := Pool.Subpools.Next; 538 539 -- Perform the following actions: 540 541 -- 1) Finalize all objects chained on the subpool's master 542 -- 2) Remove the the subpool from the owner's list of subpools 543 -- 3) Deallocate the doubly linked list node associated with the 544 -- subpool. 545 -- 4) Call Deallocate_Subpool 546 547 begin 548 Finalize_And_Deallocate (Curr_Ptr.Subpool); 549 550 exception 551 when Fin_Occur : others => 552 if not Raised then 553 Raised := True; 554 Save_Occurrence (Ex_Occur, Fin_Occur); 555 end if; 556 end; 557 end loop; 558 559 -- If the finalization of a particular master failed, reraise the 560 -- exception now. 561 562 if Raised then 563 Reraise_Occurrence (Ex_Occur); 564 end if; 565 end Finalize_Pool; 566 567 ------------------------------ 568 -- Header_Size_With_Padding -- 569 ------------------------------ 570 571 function Header_Size_With_Padding 572 (Alignment : System.Storage_Elements.Storage_Count) 573 return System.Storage_Elements.Storage_Count 574 is 575 Size : constant Storage_Count := Header_Size; 576 577 begin 578 if Size mod Alignment = 0 then 579 return Size; 580 581 -- Add enough padding to reach the nearest multiple of the alignment 582 -- rounding up. 583 584 else 585 return ((Size + Alignment - 1) / Alignment) * Alignment; 586 end if; 587 end Header_Size_With_Padding; 588 589 ---------------- 590 -- Initialize -- 591 ---------------- 592 593 overriding procedure Initialize (Controller : in out Pool_Controller) is 594 begin 595 Initialize_Pool (Controller.Enclosing_Pool.all); 596 end Initialize; 597 598 --------------------- 599 -- Initialize_Pool -- 600 --------------------- 601 602 procedure Initialize_Pool (Pool : in out Root_Storage_Pool_With_Subpools) is 603 begin 604 -- The dummy head must point to itself in both directions 605 606 Pool.Subpools.Next := Pool.Subpools'Unchecked_Access; 607 Pool.Subpools.Prev := Pool.Subpools'Unchecked_Access; 608 end Initialize_Pool; 609 610 --------------------- 611 -- Pool_Of_Subpool -- 612 --------------------- 613 614 function Pool_Of_Subpool 615 (Subpool : not null Subpool_Handle) 616 return access Root_Storage_Pool_With_Subpools'Class 617 is 618 begin 619 return Subpool.Owner; 620 end Pool_Of_Subpool; 621 622 ---------------- 623 -- Print_Pool -- 624 ---------------- 625 626 procedure Print_Pool (Pool : Root_Storage_Pool_With_Subpools) is 627 Head : constant SP_Node_Ptr := Pool.Subpools'Unrestricted_Access; 628 Head_Seen : Boolean := False; 629 SP_Ptr : SP_Node_Ptr; 630 631 begin 632 -- Output the contents of the pool 633 634 -- Pool : 0x123456789 635 -- Subpools : 0x123456789 636 -- Fin_Start : TRUE <or> FALSE 637 -- Controller: OK <or> NOK 638 639 Put ("Pool : "); 640 Put_Line (Address_Image (Pool'Address)); 641 642 Put ("Subpools : "); 643 Put_Line (Address_Image (Pool.Subpools'Address)); 644 645 Put ("Fin_Start : "); 646 Put_Line (Pool.Finalization_Started'Img); 647 648 Put ("Controlled: "); 649 if Pool.Controller.Enclosing_Pool = Pool'Unrestricted_Access then 650 Put_Line ("OK"); 651 else 652 Put_Line ("NOK (ERROR)"); 653 end if; 654 655 SP_Ptr := Head; 656 while SP_Ptr /= null loop -- Should never be null 657 Put_Line ("V"); 658 659 -- We see the head initially; we want to exit when we see the head a 660 -- second time. 661 662 if SP_Ptr = Head then 663 exit when Head_Seen; 664 665 Head_Seen := True; 666 end if; 667 668 -- The current element is null. This should never happend since the 669 -- list is circular. 670 671 if SP_Ptr.Prev = null then 672 Put_Line ("null (ERROR)"); 673 674 -- The current element points back to the correct element 675 676 elsif SP_Ptr.Prev.Next = SP_Ptr then 677 Put_Line ("^"); 678 679 -- The current element points to an erroneous element 680 681 else 682 Put_Line ("? (ERROR)"); 683 end if; 684 685 -- Output the contents of the node 686 687 Put ("|Header: "); 688 Put (Address_Image (SP_Ptr.all'Address)); 689 if SP_Ptr = Head then 690 Put_Line (" (dummy head)"); 691 else 692 Put_Line (""); 693 end if; 694 695 Put ("| Prev: "); 696 697 if SP_Ptr.Prev = null then 698 Put_Line ("null"); 699 else 700 Put_Line (Address_Image (SP_Ptr.Prev.all'Address)); 701 end if; 702 703 Put ("| Next: "); 704 705 if SP_Ptr.Next = null then 706 Put_Line ("null"); 707 else 708 Put_Line (Address_Image (SP_Ptr.Next.all'Address)); 709 end if; 710 711 Put ("| Subp: "); 712 713 if SP_Ptr.Subpool = null then 714 Put_Line ("null"); 715 else 716 Put_Line (Address_Image (SP_Ptr.Subpool.all'Address)); 717 end if; 718 719 SP_Ptr := SP_Ptr.Next; 720 end loop; 721 end Print_Pool; 722 723 ------------------- 724 -- Print_Subpool -- 725 ------------------- 726 727 procedure Print_Subpool (Subpool : Subpool_Handle) is 728 begin 729 if Subpool = null then 730 Put_Line ("null"); 731 return; 732 end if; 733 734 -- Output the contents of a subpool 735 736 -- Owner : 0x123456789 737 -- Master: 0x123456789 738 -- Node : 0x123456789 739 740 Put ("Owner : "); 741 if Subpool.Owner = null then 742 Put_Line ("null"); 743 else 744 Put_Line (Address_Image (Subpool.Owner'Address)); 745 end if; 746 747 Put ("Master: "); 748 Put_Line (Address_Image (Subpool.Master'Address)); 749 750 Put ("Node : "); 751 if Subpool.Node = null then 752 Put ("null"); 753 754 if Subpool.Owner = null then 755 Put_Line (" OK"); 756 else 757 Put_Line (" (ERROR)"); 758 end if; 759 else 760 Put_Line (Address_Image (Subpool.Node'Address)); 761 end if; 762 763 Print_Master (Subpool.Master); 764 end Print_Subpool; 765 766 ------------------------- 767 -- Set_Pool_Of_Subpool -- 768 ------------------------- 769 770 procedure Set_Pool_Of_Subpool 771 (Subpool : not null Subpool_Handle; 772 To : in out Root_Storage_Pool_With_Subpools'Class) 773 is 774 N_Ptr : SP_Node_Ptr; 775 776 begin 777 -- If the subpool is already owned, raise Program_Error. This is a 778 -- direct violation of the RM rules. 779 780 if Subpool.Owner /= null then 781 raise Program_Error with "subpool already belongs to a pool"; 782 end if; 783 784 -- Prevent the creation of a new subpool while the owner is being 785 -- finalized. This is a serious error. 786 787 if To.Finalization_Started then 788 raise Program_Error 789 with "subpool creation after finalization started"; 790 end if; 791 792 Subpool.Owner := To'Unchecked_Access; 793 794 -- Create a subpool node and decorate it. Since this node is not 795 -- allocated on the owner's pool, it must be explicitly destroyed by 796 -- Finalize_And_Detach. 797 798 N_Ptr := new SP_Node; 799 N_Ptr.Subpool := Subpool; 800 Subpool.Node := N_Ptr; 801 802 Attach (N_Ptr, To.Subpools'Unchecked_Access); 803 804 -- Mark the subpool's master as being a heterogeneous collection of 805 -- controlled objects. 806 807 Set_Is_Heterogeneous (Subpool.Master); 808 end Set_Pool_Of_Subpool; 809 810end System.Storage_Pools.Subpools; 811