1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
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 --
9 -- Copyright (C) 2011, Free Software Foundation, Inc. --
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. --
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. --
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/>. --
27 -- GNAT was originally developed by the GNAT team at New York University. --
28 -- Extensive contributions were provided by Ada Core Technologies Inc. --
30 ------------------------------------------------------------------------------
32 with Ada.Exceptions; use Ada.Exceptions;
33 with Ada.Unchecked_Conversion;
34 with Ada.Unchecked_Deallocation;
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;
41 package body System.Storage_Pools.Subpools is
43 Finalize_Address_Table_In_Use : Boolean := False;
44 -- This flag should be set only when a successfull allocation on a subpool
45 -- has been performed and the associated Finalize_Address has been added to
46 -- the hash table in System.Finalization_Masters.
48 function Address_To_FM_Node_Ptr is
49 new Ada.Unchecked_Conversion (Address, FM_Node_Ptr);
51 procedure Attach (N : not null SP_Node_Ptr; L : not null SP_Node_Ptr);
52 -- Attach a subpool node to a pool
54 procedure Free is new Ada.Unchecked_Deallocation (SP_Node, SP_Node_Ptr);
56 procedure Detach (N : not null SP_Node_Ptr);
57 -- Unhook a subpool node from an arbitrary subpool list
59 function Nearest_Multiple_Rounded_Up
60 (Size : Storage_Count;
61 Alignment : Storage_Count) return Storage_Count;
62 -- Given arbitrary values of storage size and alignment, calculate the
63 -- nearest multiple of the alignment rounded up where size can fit.
69 overriding procedure Allocate
70 (Pool : in out Root_Storage_Pool_With_Subpools;
71 Storage_Address : out System.Address;
72 Size_In_Storage_Elements : System.Storage_Elements.Storage_Count;
73 Alignment : System.Storage_Elements.Storage_Count)
76 -- Dispatch to the user-defined implementations of Allocate_From_Subpool
77 -- and Default_Subpool_For_Pool.
80 (Root_Storage_Pool_With_Subpools'Class (Pool),
82 Size_In_Storage_Elements,
84 Default_Subpool_For_Pool
85 (Root_Storage_Pool_With_Subpools'Class (Pool)));
88 -----------------------------
89 -- Allocate_Any_Controlled --
90 -----------------------------
92 procedure Allocate_Any_Controlled
93 (Pool : in out Root_Storage_Pool'Class;
94 Context_Subpool : Subpool_Handle;
95 Context_Master : Finalization_Masters.Finalization_Master_Ptr;
96 Fin_Address : Finalization_Masters.Finalize_Address_Ptr;
97 Addr : out System.Address;
98 Storage_Size : System.Storage_Elements.Storage_Count;
99 Alignment : System.Storage_Elements.Storage_Count;
100 Is_Controlled : Boolean;
101 On_Subpool : Boolean)
103 Is_Subpool_Allocation : constant Boolean :=
104 Pool in Root_Storage_Pool_With_Subpools'Class;
106 Master : Finalization_Master_Ptr := null;
109 N_Size : Storage_Count;
110 Subpool : Subpool_Handle := null;
112 Header_And_Padding : Storage_Offset;
113 -- This offset includes the size of a FM_Node plus any additional
114 -- padding due to a larger alignment.
117 -- Step 1: Pool-related runtime checks
119 -- Allocation on a pool_with_subpools. In this scenario there is a
120 -- master for each subpool. The master of the access type is ignored.
122 if Is_Subpool_Allocation then
124 -- Case of an allocation without a Subpool_Handle. Dispatch to the
125 -- implementation of Default_Subpool_For_Pool.
127 if Context_Subpool = null then
129 Default_Subpool_For_Pool
130 (Root_Storage_Pool_With_Subpools'Class (Pool));
132 -- Allocation with a Subpool_Handle
135 Subpool := Context_Subpool;
138 -- Ensure proper ownership and chaining of the subpool
141 Root_Storage_Pool_With_Subpools'Class (Pool)'Unchecked_Access
142 or else Subpool.Node = null
143 or else Subpool.Node.Prev = null
144 or else Subpool.Node.Next = null
146 raise Program_Error with "incorrect owner of subpool";
149 Master := Subpool.Master'Unchecked_Access;
151 -- Allocation on a simple pool. In this scenario there is a master for
152 -- each access-to-controlled type. No context subpool should be present.
155 -- If the master is missing, then the expansion of the access type
156 -- failed to create one. This is a serious error.
158 if Context_Master = null then
159 raise Program_Error with "missing master in pool allocation";
162 -- If a subpool is present, then this is the result of erroneous
163 -- allocator expansion. This is not a serious error, but it should
164 -- still be detected.
166 if Context_Subpool /= null then
167 raise Program_Error with "subpool not required in pool allocation";
170 -- If the allocation is intended to be on a subpool, but the access
171 -- type's pool does not support subpools, then this is the result of
172 -- erroneous end-user code.
176 with "pool of access type does not support subpools";
179 Master := Context_Master;
182 -- Step 2: Master, Finalize_Address-related runtime checks and size
185 -- Allocation of a descendant from [Limited_]Controlled, a class-wide
186 -- object or a record with controlled components.
188 if Is_Controlled then
190 -- Do not allow the allocation of controlled objects while the
191 -- associated master is being finalized.
193 if Finalization_Started (Master.all) then
194 raise Program_Error with "allocation after finalization started";
197 -- Check whether primitive Finalize_Address is available. If it is
198 -- not, then either the expansion of the designated type failed or
199 -- the expansion of the allocator failed. This is a serious error.
201 if Fin_Address = null then
203 with "primitive Finalize_Address not available";
206 -- The size must acount for the hidden header preceding the object.
207 -- Account for possible padding space before the header due to a
210 Header_And_Padding :=
211 Nearest_Multiple_Rounded_Up
212 (Size => Header_Size,
213 Alignment => Alignment);
215 N_Size := Storage_Size + Header_And_Padding;
217 -- Non-controlled allocation
220 N_Size := Storage_Size;
223 -- Step 3: Allocation of object
225 -- For descendants of Root_Storage_Pool_With_Subpools, dispatch to the
226 -- implementation of Allocate_From_Subpool.
228 if Is_Subpool_Allocation then
229 Allocate_From_Subpool
230 (Root_Storage_Pool_With_Subpools'Class (Pool),
231 N_Addr, N_Size, Alignment, Subpool);
233 -- For descendants of Root_Storage_Pool, dispatch to the implementation
237 Allocate (Pool, N_Addr, N_Size, Alignment);
240 -- Step 4: Attachment
242 if Is_Controlled then
244 -- Map the allocated memory into a FM_Node record. This converts the
245 -- top of the allocated bits into a list header. If there is padding
246 -- due to larger alignment, the header is placed right next to the
252 -- +-------+---------------+----------------------+
253 -- |Padding| Header | Object |
254 -- +-------+---------------+----------------------+
256 -- | +- Header_Size -+
258 -- +- Header_And_Padding --+
260 N_Ptr := Address_To_FM_Node_Ptr
261 (N_Addr + Header_And_Padding - Header_Offset);
263 -- Prepend the allocated object to the finalization master
265 Attach (N_Ptr, Objects (Master.all));
267 -- Move the address from the hidden list header to the start of the
268 -- object. This operation effectively hides the list header.
270 Addr := N_Addr + Header_And_Padding;
272 -- Homogeneous masters service the following:
274 -- 1) Allocations on / Deallocations from regular pools
275 -- 2) Named access types
276 -- 3) Most cases of anonymous access types usage
278 if Master.Is_Homogeneous then
279 if Finalize_Address (Master.all) = null then
280 Set_Finalize_Address (Master.all, Fin_Address);
283 -- Heterogeneous masters service the following:
285 -- 1) Allocations on / Deallocations from subpools
286 -- 2) Certain cases of anonymous access types usage
289 Set_Finalize_Address (Addr, Fin_Address);
290 Finalize_Address_Table_In_Use := True;
293 -- Non-controlled allocation
298 end Allocate_Any_Controlled;
304 procedure Attach (N : not null SP_Node_Ptr; L : not null SP_Node_Ptr) is
306 -- Ensure that the node has not been attached already
308 pragma Assert (N.Prev = null and then N.Next = null);
319 -- Note: No need to unlock in case of an exception because the above
320 -- code can never raise one.
323 -------------------------------
324 -- Deallocate_Any_Controlled --
325 -------------------------------
327 procedure Deallocate_Any_Controlled
328 (Pool : in out Root_Storage_Pool'Class;
329 Addr : System.Address;
330 Storage_Size : System.Storage_Elements.Storage_Count;
331 Alignment : System.Storage_Elements.Storage_Count;
332 Is_Controlled : Boolean)
336 N_Size : Storage_Count;
338 Header_And_Padding : Storage_Offset;
339 -- This offset includes the size of a FM_Node plus any additional
340 -- padding due to a larger alignment.
343 -- Step 1: Detachment
345 if Is_Controlled then
347 -- Destroy the relation pair object - Finalize_Address since it is no
350 if Finalize_Address_Table_In_Use then
351 Delete_Finalize_Address (Addr);
354 -- Account for possible padding space before the header due to a
357 Header_And_Padding :=
358 Nearest_Multiple_Rounded_Up
359 (Size => Header_Size,
360 Alignment => Alignment);
362 -- N_Addr N_Ptr Addr (from input)
365 -- +-------+---------------+----------------------+
366 -- |Padding| Header | Object |
367 -- +-------+---------------+----------------------+
369 -- | +- Header_Size -+
371 -- +- Header_And_Padding --+
373 -- Convert the bits preceding the object into a list header
375 N_Ptr := Address_To_FM_Node_Ptr (Addr - Header_Offset);
377 -- Detach the object from the related finalization master. This
378 -- action does not need to know the prior context used during
383 -- Move the address from the object to the beginning of the list
386 N_Addr := Addr - Header_And_Padding;
388 -- The size of the deallocated object must include the size of the
389 -- hidden list header.
391 N_Size := Storage_Size + Header_And_Padding;
395 N_Size := Storage_Size;
398 -- Step 2: Deallocation
400 -- Dispatch to the proper implementation of Deallocate. This action
401 -- covers both Root_Storage_Pool and Root_Storage_Pool_With_Subpools
404 Deallocate (Pool, N_Addr, N_Size, Alignment);
405 end Deallocate_Any_Controlled;
411 procedure Detach (N : not null SP_Node_Ptr) is
413 -- Ensure that the node is attached to some list
415 pragma Assert (N.Next /= null and then N.Prev /= null);
419 N.Prev.Next := N.Next;
420 N.Next.Prev := N.Prev;
426 -- Note: No need to unlock in case of an exception because the above
427 -- code can never raise one.
434 overriding procedure Finalize (Controller : in out Pool_Controller) is
436 Finalize_Pool (Controller.Enclosing_Pool.all);
443 procedure Finalize_Pool (Pool : in out Root_Storage_Pool_With_Subpools) is
444 Curr_Ptr : SP_Node_Ptr;
445 Ex_Occur : Exception_Occurrence;
446 Raised : Boolean := False;
448 function Is_Empty_List (L : not null SP_Node_Ptr) return Boolean;
449 -- Determine whether a list contains only one element, the dummy head
455 function Is_Empty_List (L : not null SP_Node_Ptr) return Boolean is
457 return L.Next = L and then L.Prev = L;
460 -- Start of processing for Finalize_Pool
463 -- It is possible for multiple tasks to cause the finalization of a
464 -- common pool. Allow only one task to finalize the contents.
466 if Pool.Finalization_Started then
470 -- Lock the pool to prevent the creation of additional subpools while
471 -- the available ones are finalized. The pool remains locked because
472 -- either it is about to be deallocated or the associated access type
473 -- is about to go out of scope.
475 Pool.Finalization_Started := True;
477 while not Is_Empty_List (Pool.Subpools'Unchecked_Access) loop
478 Curr_Ptr := Pool.Subpools.Next;
480 -- Perform the following actions:
482 -- 1) Finalize all objects chained on the subpool's master
483 -- 2) Remove the the subpool from the owner's list of subpools
484 -- 3) Deallocate the doubly linked list node associated with the
488 Finalize_Subpool (Curr_Ptr.Subpool);
491 when Fin_Occur : others =>
494 Save_Occurrence (Ex_Occur, Fin_Occur);
499 -- If the finalization of a particular master failed, reraise the
503 Reraise_Occurrence (Ex_Occur);
507 ----------------------
508 -- Finalize_Subpool --
509 ----------------------
511 procedure Finalize_Subpool (Subpool : not null Subpool_Handle) is
513 -- Do nothing if the subpool was never used
515 if Subpool.Owner = null
516 or else Subpool.Node = null
521 -- Clean up all controlled objects chained on the subpool's master
523 Finalize (Subpool.Master);
525 -- Remove the subpool from its owner's list of subpools
527 Detach (Subpool.Node);
529 -- Destroy the associated doubly linked list node which was created in
530 -- Set_Pool_Of_Subpool.
533 end Finalize_Subpool;
539 overriding procedure Initialize (Controller : in out Pool_Controller) is
541 Initialize_Pool (Controller.Enclosing_Pool.all);
544 ---------------------
545 -- Initialize_Pool --
546 ---------------------
548 procedure Initialize_Pool (Pool : in out Root_Storage_Pool_With_Subpools) is
550 -- The dummy head must point to itself in both directions
552 Pool.Subpools.Next := Pool.Subpools'Unchecked_Access;
553 Pool.Subpools.Prev := Pool.Subpools'Unchecked_Access;
556 ---------------------------------
557 -- Nearest_Multiple_Rounded_Up --
558 ---------------------------------
560 function Nearest_Multiple_Rounded_Up
561 (Size : Storage_Count;
562 Alignment : Storage_Count) return Storage_Count
565 if Size mod Alignment = 0 then
568 -- Add enough padding to reach the nearest multiple of the alignment
572 return ((Size + Alignment - 1) / Alignment) * Alignment;
574 end Nearest_Multiple_Rounded_Up;
576 ---------------------
577 -- Pool_Of_Subpool --
578 ---------------------
580 function Pool_Of_Subpool (Subpool : not null Subpool_Handle)
581 return access Root_Storage_Pool_With_Subpools'Class is
583 return Subpool.Owner;
590 procedure Print_Pool (Pool : Root_Storage_Pool_With_Subpools) is
591 Head : constant SP_Node_Ptr := Pool.Subpools'Unrestricted_Access;
592 Head_Seen : Boolean := False;
593 SP_Ptr : SP_Node_Ptr;
596 -- Output the contents of the pool
598 -- Pool : 0x123456789
599 -- Subpools : 0x123456789
600 -- Fin_Start : TRUE <or> FALSE
601 -- Controller: OK <or> NOK
604 Put_Line (Address_Image (Pool'Address));
607 Put_Line (Address_Image (Pool.Subpools'Address));
609 Put ("Fin_Start : ");
610 Put_Line (Pool.Finalization_Started'Img);
612 Put ("Controlled: ");
613 if Pool.Controller.Enclosing_Pool = Pool'Unrestricted_Access then
616 Put_Line ("NOK (ERROR)");
620 while SP_Ptr /= null loop -- Should never be null
623 -- We see the head initially; we want to exit when we see the head a
626 if SP_Ptr = Head then
632 -- The current element is null. This should never happend since the
635 if SP_Ptr.Prev = null then
636 Put_Line ("null (ERROR)");
638 -- The current element points back to the correct element
640 elsif SP_Ptr.Prev.Next = SP_Ptr then
643 -- The current element points to an erroneous element
646 Put_Line ("? (ERROR)");
649 -- Output the contents of the node
652 Put (Address_Image (SP_Ptr.all'Address));
653 if SP_Ptr = Head then
654 Put_Line (" (dummy head)");
661 if SP_Ptr.Prev = null then
664 Put_Line (Address_Image (SP_Ptr.Prev.all'Address));
669 if SP_Ptr.Next = null then
672 Put_Line (Address_Image (SP_Ptr.Next.all'Address));
677 if SP_Ptr.Subpool = null then
680 Put_Line (Address_Image (SP_Ptr.Subpool.all'Address));
683 SP_Ptr := SP_Ptr.Next;
691 procedure Print_Subpool (Subpool : Subpool_Handle) is
693 if Subpool = null then
698 -- Output the contents of a subpool
700 -- Owner : 0x123456789
701 -- Master: 0x123456789
702 -- Node : 0x123456789
705 if Subpool.Owner = null then
708 Put_Line (Address_Image (Subpool.Owner'Address));
712 Put_Line (Address_Image (Subpool.Master'Address));
715 if Subpool.Node = null then
718 if Subpool.Owner = null then
721 Put_Line (" (ERROR)");
724 Put_Line (Address_Image (Subpool.Node'Address));
727 Print_Master (Subpool.Master);
730 -------------------------
731 -- Set_Pool_Of_Subpool --
732 -------------------------
734 procedure Set_Pool_Of_Subpool
735 (Subpool : not null Subpool_Handle;
736 Pool : in out Root_Storage_Pool_With_Subpools'Class)
741 -- If the subpool is already owned, raise Program_Error. This is a
742 -- direct violation of the RM rules.
744 if Subpool.Owner /= null then
745 raise Program_Error with "subpool already belongs to a pool";
748 -- Prevent the creation of a new subpool while the owner is being
749 -- finalized. This is a serious error.
751 if Pool.Finalization_Started then
753 with "subpool creation after finalization started";
756 Subpool.Owner := Pool'Unchecked_Access;
758 -- Create a subpool node and decorate it. Since this node is not
759 -- allocated on the owner's pool, it must be explicitly destroyed by
760 -- Finalize_And_Detach.
762 N_Ptr := new SP_Node;
763 N_Ptr.Subpool := Subpool;
764 Subpool.Node := N_Ptr;
766 Attach (N_Ptr, Pool.Subpools'Unchecked_Access);
768 -- Mark the subpool's master as being a heterogeneous collection of
769 -- controlled objects.
771 Set_Is_Heterogeneous (Subpool.Master);
772 end Set_Pool_Of_Subpool;
774 end System.Storage_Pools.Subpools;