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
63 overriding procedure Allocate
64 (Pool : in out Root_Storage_Pool_With_Subpools;
65 Storage_Address : out System.Address;
66 Size_In_Storage_Elements : System.Storage_Elements.Storage_Count;
67 Alignment : System.Storage_Elements.Storage_Count)
70 -- Dispatch to the user-defined implementations of Allocate_From_Subpool
71 -- and Default_Subpool_For_Pool.
74 (Root_Storage_Pool_With_Subpools'Class (Pool),
76 Size_In_Storage_Elements,
78 Default_Subpool_For_Pool
79 (Root_Storage_Pool_With_Subpools'Class (Pool)));
82 -----------------------------
83 -- Allocate_Any_Controlled --
84 -----------------------------
86 procedure Allocate_Any_Controlled
87 (Pool : in out Root_Storage_Pool'Class;
88 Context_Subpool : Subpool_Handle;
89 Context_Master : Finalization_Masters.Finalization_Master_Ptr;
90 Fin_Address : Finalization_Masters.Finalize_Address_Ptr;
91 Addr : out System.Address;
92 Storage_Size : System.Storage_Elements.Storage_Count;
93 Alignment : System.Storage_Elements.Storage_Count;
94 Is_Controlled : Boolean;
97 Is_Subpool_Allocation : constant Boolean :=
98 Pool in Root_Storage_Pool_With_Subpools'Class;
100 Master : Finalization_Master_Ptr := null;
103 N_Size : Storage_Count;
104 Subpool : Subpool_Handle := null;
106 Allocation_Locked : Boolean;
107 -- This flag stores the state of the associated collection
109 Header_And_Padding : Storage_Offset;
110 -- This offset includes the size of a FM_Node plus any additional
111 -- padding due to a larger alignment.
114 -- Step 1: Pool-related runtime checks
116 -- Allocation on a pool_with_subpools. In this scenario there is a
117 -- master for each subpool. The master of the access type is ignored.
119 if Is_Subpool_Allocation then
121 -- Case of an allocation without a Subpool_Handle. Dispatch to the
122 -- implementation of Default_Subpool_For_Pool.
124 if Context_Subpool = null then
126 Default_Subpool_For_Pool
127 (Root_Storage_Pool_With_Subpools'Class (Pool));
129 -- Allocation with a Subpool_Handle
132 Subpool := Context_Subpool;
135 -- Ensure proper ownership and chaining of the subpool
138 Root_Storage_Pool_With_Subpools'Class (Pool)'Unchecked_Access
139 or else Subpool.Node = null
140 or else Subpool.Node.Prev = null
141 or else Subpool.Node.Next = null
143 raise Program_Error with "incorrect owner of subpool";
146 Master := Subpool.Master'Unchecked_Access;
148 -- Allocation on a simple pool. In this scenario there is a master for
149 -- each access-to-controlled type. No context subpool should be present.
152 -- If the master is missing, then the expansion of the access type
153 -- failed to create one. This is a serious error.
155 if Context_Master = null then
157 with "missing master in pool allocation";
159 -- If a subpool is present, then this is the result of erroneous
160 -- allocator expansion. This is not a serious error, but it should
161 -- still be detected.
163 elsif Context_Subpool /= null then
165 with "subpool not required in pool allocation";
167 -- If the allocation is intended to be on a subpool, but the access
168 -- type's pool does not support subpools, then this is the result of
169 -- erroneous end-user code.
171 elsif On_Subpool then
173 with "pool of access type does not support subpools";
176 Master := Context_Master;
179 -- Step 2: Master, Finalize_Address-related runtime checks and size
182 -- Allocation of a descendant from [Limited_]Controlled, a class-wide
183 -- object or a record with controlled components.
185 if Is_Controlled then
188 -- Read - allocation, finalization
189 -- Write - finalization
192 Allocation_Locked := Finalization_Started (Master.all);
195 -- Do not allow the allocation of controlled objects while the
196 -- associated master is being finalized.
198 if Allocation_Locked then
199 raise Program_Error with "allocation after finalization started";
202 -- Check whether primitive Finalize_Address is available. If it is
203 -- not, then either the expansion of the designated type failed or
204 -- the expansion of the allocator failed. This is a serious error.
206 if Fin_Address = null then
208 with "primitive Finalize_Address not available";
211 -- The size must acount for the hidden header preceding the object.
212 -- Account for possible padding space before the header due to a
215 Header_And_Padding := Header_Size_With_Padding (Alignment);
217 N_Size := Storage_Size + Header_And_Padding;
219 -- Non-controlled allocation
222 N_Size := Storage_Size;
225 -- Step 3: Allocation of object
227 -- For descendants of Root_Storage_Pool_With_Subpools, dispatch to the
228 -- implementation of Allocate_From_Subpool.
230 if Is_Subpool_Allocation then
231 Allocate_From_Subpool
232 (Root_Storage_Pool_With_Subpools'Class (Pool),
233 N_Addr, N_Size, Alignment, Subpool);
235 -- For descendants of Root_Storage_Pool, dispatch to the implementation
239 Allocate (Pool, N_Addr, N_Size, Alignment);
242 -- Step 4: Attachment
244 if Is_Controlled then
247 -- Map the allocated memory into a FM_Node record. This converts the
248 -- top of the allocated bits into a list header. If there is padding
249 -- due to larger alignment, the header is placed right next to the
255 -- +-------+---------------+----------------------+
256 -- |Padding| Header | Object |
257 -- +-------+---------------+----------------------+
259 -- | +- Header_Size -+
261 -- +- Header_And_Padding --+
263 N_Ptr := Address_To_FM_Node_Ptr
264 (N_Addr + Header_And_Padding - Header_Offset);
266 -- Prepend the allocated object to the finalization master
269 -- Write - allocation, deallocation, finalization
271 Attach_Unprotected (N_Ptr, Objects (Master.all));
273 -- Move the address from the hidden list header to the start of the
274 -- object. This operation effectively hides the list header.
276 Addr := N_Addr + Header_And_Padding;
278 -- Homogeneous masters service the following:
280 -- 1) Allocations on / Deallocations from regular pools
281 -- 2) Named access types
282 -- 3) Most cases of anonymous access types usage
285 -- Read - allocation, finalization
288 if Master.Is_Homogeneous then
291 -- Read - finalization
292 -- Write - allocation, outside
294 Set_Finalize_Address_Unprotected (Master.all, Fin_Address);
296 -- Heterogeneous masters service the following:
298 -- 1) Allocations on / Deallocations from subpools
299 -- 2) Certain cases of anonymous access types usage
303 -- Read - finalization
304 -- Write - allocation, deallocation
306 Set_Heterogeneous_Finalize_Address_Unprotected (Addr, Fin_Address);
307 Finalize_Address_Table_In_Use := True;
312 -- Non-controlled allocation
317 end Allocate_Any_Controlled;
323 procedure Attach (N : not null SP_Node_Ptr; L : not null SP_Node_Ptr) is
325 -- Ensure that the node has not been attached already
327 pragma Assert (N.Prev = null and then N.Next = null);
338 -- Note: No need to unlock in case of an exception because the above
339 -- code can never raise one.
342 -------------------------------
343 -- Deallocate_Any_Controlled --
344 -------------------------------
346 procedure Deallocate_Any_Controlled
347 (Pool : in out Root_Storage_Pool'Class;
348 Addr : System.Address;
349 Storage_Size : System.Storage_Elements.Storage_Count;
350 Alignment : System.Storage_Elements.Storage_Count;
351 Is_Controlled : Boolean)
355 N_Size : Storage_Count;
357 Header_And_Padding : Storage_Offset;
358 -- This offset includes the size of a FM_Node plus any additional
359 -- padding due to a larger alignment.
362 -- Step 1: Detachment
364 if Is_Controlled then
367 -- Destroy the relation pair object - Finalize_Address since it is no
370 if Finalize_Address_Table_In_Use then
373 -- Read - finalization
374 -- Write - allocation, deallocation
376 Delete_Finalize_Address_Unprotected (Addr);
379 -- Account for possible padding space before the header due to a
382 Header_And_Padding := Header_Size_With_Padding (Alignment);
384 -- N_Addr N_Ptr Addr (from input)
387 -- +-------+---------------+----------------------+
388 -- |Padding| Header | Object |
389 -- +-------+---------------+----------------------+
391 -- | +- Header_Size -+
393 -- +- Header_And_Padding --+
395 -- Convert the bits preceding the object into a list header
397 N_Ptr := Address_To_FM_Node_Ptr (Addr - Header_Offset);
399 -- Detach the object from the related finalization master. This
400 -- action does not need to know the prior context used during
404 -- Write - allocation, deallocation, finalization
406 Detach_Unprotected (N_Ptr);
408 -- Move the address from the object to the beginning of the list
411 N_Addr := Addr - Header_And_Padding;
413 -- The size of the deallocated object must include the size of the
414 -- hidden list header.
416 N_Size := Storage_Size + Header_And_Padding;
422 N_Size := Storage_Size;
425 -- Step 2: Deallocation
427 -- Dispatch to the proper implementation of Deallocate. This action
428 -- covers both Root_Storage_Pool and Root_Storage_Pool_With_Subpools
431 Deallocate (Pool, N_Addr, N_Size, Alignment);
432 end Deallocate_Any_Controlled;
434 ------------------------------
435 -- Default_Subpool_For_Pool --
436 ------------------------------
438 function Default_Subpool_For_Pool
439 (Pool : Root_Storage_Pool_With_Subpools) return not null Subpool_Handle
443 return Pool.Subpools.Subpool;
444 end Default_Subpool_For_Pool;
450 procedure Detach (N : not null SP_Node_Ptr) is
452 -- Ensure that the node is attached to some list
454 pragma Assert (N.Next /= null and then N.Prev /= null);
458 N.Prev.Next := N.Next;
459 N.Next.Prev := N.Prev;
465 -- Note: No need to unlock in case of an exception because the above
466 -- code can never raise one.
473 overriding procedure Finalize (Controller : in out Pool_Controller) is
475 Finalize_Pool (Controller.Enclosing_Pool.all);
482 procedure Finalize_Pool (Pool : in out Root_Storage_Pool_With_Subpools) is
483 Curr_Ptr : SP_Node_Ptr;
484 Ex_Occur : Exception_Occurrence;
485 Raised : Boolean := False;
487 function Is_Empty_List (L : not null SP_Node_Ptr) return Boolean;
488 -- Determine whether a list contains only one element, the dummy head
494 function Is_Empty_List (L : not null SP_Node_Ptr) return Boolean is
496 return L.Next = L and then L.Prev = L;
499 -- Start of processing for Finalize_Pool
502 -- It is possible for multiple tasks to cause the finalization of a
503 -- common pool. Allow only one task to finalize the contents.
505 if Pool.Finalization_Started then
509 -- Lock the pool to prevent the creation of additional subpools while
510 -- the available ones are finalized. The pool remains locked because
511 -- either it is about to be deallocated or the associated access type
512 -- is about to go out of scope.
514 Pool.Finalization_Started := True;
516 while not Is_Empty_List (Pool.Subpools'Unchecked_Access) loop
517 Curr_Ptr := Pool.Subpools.Next;
519 -- Perform the following actions:
521 -- 1) Finalize all objects chained on the subpool's master
522 -- 2) Remove the the subpool from the owner's list of subpools
523 -- 3) Deallocate the doubly linked list node associated with the
527 Finalize_Subpool (Curr_Ptr.Subpool);
530 when Fin_Occur : others =>
533 Save_Occurrence (Ex_Occur, Fin_Occur);
538 -- If the finalization of a particular master failed, reraise the
542 Reraise_Occurrence (Ex_Occur);
546 ----------------------
547 -- Finalize_Subpool --
548 ----------------------
550 procedure Finalize_Subpool (Subpool : not null Subpool_Handle) is
552 -- Do nothing if the subpool was never used
554 if Subpool.Owner = null or else Subpool.Node = null then
558 -- Clean up all controlled objects chained on the subpool's master
560 Finalize (Subpool.Master);
562 -- Remove the subpool from its owner's list of subpools
564 Detach (Subpool.Node);
566 -- Destroy the associated doubly linked list node which was created in
567 -- Set_Pool_Of_Subpool.
570 end Finalize_Subpool;
572 ------------------------------
573 -- Header_Size_With_Padding --
574 ------------------------------
576 function Header_Size_With_Padding
577 (Alignment : System.Storage_Elements.Storage_Count)
578 return System.Storage_Elements.Storage_Count
580 Size : constant Storage_Count := Header_Size;
583 if Size mod Alignment = 0 then
586 -- Add enough padding to reach the nearest multiple of the alignment
590 return ((Size + Alignment - 1) / Alignment) * Alignment;
592 end Header_Size_With_Padding;
598 overriding procedure Initialize (Controller : in out Pool_Controller) is
600 Initialize_Pool (Controller.Enclosing_Pool.all);
603 ---------------------
604 -- Initialize_Pool --
605 ---------------------
607 procedure Initialize_Pool (Pool : in out Root_Storage_Pool_With_Subpools) is
609 -- The dummy head must point to itself in both directions
611 Pool.Subpools.Next := Pool.Subpools'Unchecked_Access;
612 Pool.Subpools.Prev := Pool.Subpools'Unchecked_Access;
615 ---------------------
616 -- Pool_Of_Subpool --
617 ---------------------
619 function Pool_Of_Subpool
620 (Subpool : not null Subpool_Handle)
621 return access Root_Storage_Pool_With_Subpools'Class
624 return Subpool.Owner;
631 procedure Print_Pool (Pool : Root_Storage_Pool_With_Subpools) is
632 Head : constant SP_Node_Ptr := Pool.Subpools'Unrestricted_Access;
633 Head_Seen : Boolean := False;
634 SP_Ptr : SP_Node_Ptr;
637 -- Output the contents of the pool
639 -- Pool : 0x123456789
640 -- Subpools : 0x123456789
641 -- Fin_Start : TRUE <or> FALSE
642 -- Controller: OK <or> NOK
645 Put_Line (Address_Image (Pool'Address));
648 Put_Line (Address_Image (Pool.Subpools'Address));
650 Put ("Fin_Start : ");
651 Put_Line (Pool.Finalization_Started'Img);
653 Put ("Controlled: ");
654 if Pool.Controller.Enclosing_Pool = Pool'Unrestricted_Access then
657 Put_Line ("NOK (ERROR)");
661 while SP_Ptr /= null loop -- Should never be null
664 -- We see the head initially; we want to exit when we see the head a
667 if SP_Ptr = Head then
673 -- The current element is null. This should never happend since the
676 if SP_Ptr.Prev = null then
677 Put_Line ("null (ERROR)");
679 -- The current element points back to the correct element
681 elsif SP_Ptr.Prev.Next = SP_Ptr then
684 -- The current element points to an erroneous element
687 Put_Line ("? (ERROR)");
690 -- Output the contents of the node
693 Put (Address_Image (SP_Ptr.all'Address));
694 if SP_Ptr = Head then
695 Put_Line (" (dummy head)");
702 if SP_Ptr.Prev = null then
705 Put_Line (Address_Image (SP_Ptr.Prev.all'Address));
710 if SP_Ptr.Next = null then
713 Put_Line (Address_Image (SP_Ptr.Next.all'Address));
718 if SP_Ptr.Subpool = null then
721 Put_Line (Address_Image (SP_Ptr.Subpool.all'Address));
724 SP_Ptr := SP_Ptr.Next;
732 procedure Print_Subpool (Subpool : Subpool_Handle) is
734 if Subpool = null then
739 -- Output the contents of a subpool
741 -- Owner : 0x123456789
742 -- Master: 0x123456789
743 -- Node : 0x123456789
746 if Subpool.Owner = null then
749 Put_Line (Address_Image (Subpool.Owner'Address));
753 Put_Line (Address_Image (Subpool.Master'Address));
756 if Subpool.Node = null then
759 if Subpool.Owner = null then
762 Put_Line (" (ERROR)");
765 Put_Line (Address_Image (Subpool.Node'Address));
768 Print_Master (Subpool.Master);
771 -------------------------
772 -- Set_Pool_Of_Subpool --
773 -------------------------
775 procedure Set_Pool_Of_Subpool
776 (Subpool : not null Subpool_Handle;
777 To : in out Root_Storage_Pool_With_Subpools'Class)
782 -- If the subpool is already owned, raise Program_Error. This is a
783 -- direct violation of the RM rules.
785 if Subpool.Owner /= null then
786 raise Program_Error with "subpool already belongs to a pool";
789 -- Prevent the creation of a new subpool while the owner is being
790 -- finalized. This is a serious error.
792 if To.Finalization_Started then
794 with "subpool creation after finalization started";
797 Subpool.Owner := To'Unchecked_Access;
799 -- Create a subpool node and decorate it. Since this node is not
800 -- allocated on the owner's pool, it must be explicitly destroyed by
801 -- Finalize_And_Detach.
803 N_Ptr := new SP_Node;
804 N_Ptr.Subpool := Subpool;
805 Subpool.Node := N_Ptr;
807 Attach (N_Ptr, To.Subpools'Unchecked_Access);
809 -- Mark the subpool's master as being a heterogeneous collection of
810 -- controlled objects.
812 Set_Is_Heterogeneous (Subpool.Master);
813 end Set_Pool_Of_Subpool;
815 end System.Storage_Pools.Subpools;