GCC v8.2
[gcc.git] / gcc / ada / libgnat / 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-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
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 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
828 end System.Storage_Pools.Subpools;