File : s-stposu.adb
1 ------------------------------------------------------------------------------
2 -- --
3 -- GNAT COMPILER COMPONENTS --
4 -- --
5 -- S Y S T E M . S T O R A G E _ P O O L S . S U B P O O L S --
6 -- --
7 -- B o d y --
8 -- --
9 -- Copyright (C) 2011-2016, 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 -- --
19 -- --
20 -- --
21 -- --
22 -- You should have received a copy of the GNU General Public License and --
23 -- a copy of the GCC Runtime Library Exception along with this program; --
24 -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
25 -- <http://www.gnu.org/licenses/>. --
26 -- --
27 -- GNAT was originally developed by the GNAT team at New York University. --
28 -- Extensive contributions were provided by Ada Core Technologies Inc. --
29 -- --
30 ------------------------------------------------------------------------------
31
32 with Ada.Exceptions; use Ada.Exceptions;
33 with Ada.Unchecked_Conversion;
34
35 with System.Address_Image;
36 with System.Finalization_Masters; use System.Finalization_Masters;
37 with System.IO; use System.IO;
38 with System.Soft_Links; use System.Soft_Links;
39 with System.Storage_Elements; use System.Storage_Elements;
40
41 with System.Storage_Pools.Subpools.Finalization;
42 use System.Storage_Pools.Subpools.Finalization;
43
44 package 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 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 acount 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
828 end System.Storage_Pools.Subpools;