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
444 return Pool.Subpools.Subpool;
445 end Default_Subpool_For_Pool;
451 procedure Detach (N : not null SP_Node_Ptr) is
453 -- Ensure that the node is attached to some list
455 pragma Assert (N.Next /= null and then N.Prev /= null);
459 N.Prev.Next := N.Next;
460 N.Next.Prev := N.Prev;
466 -- Note: No need to unlock in case of an exception because the above
467 -- code can never raise one.
474 overriding procedure Finalize (Controller : in out Pool_Controller) is
476 Finalize_Pool (Controller.Enclosing_Pool.all);
483 procedure Finalize_Pool (Pool : in out Root_Storage_Pool_With_Subpools) is
484 Curr_Ptr : SP_Node_Ptr;
485 Ex_Occur : Exception_Occurrence;
486 Raised : Boolean := False;
488 function Is_Empty_List (L : not null SP_Node_Ptr) return Boolean;
489 -- Determine whether a list contains only one element, the dummy head
495 function Is_Empty_List (L : not null SP_Node_Ptr) return Boolean is
497 return L.Next = L and then L.Prev = L;
500 -- Start of processing for Finalize_Pool
503 -- It is possible for multiple tasks to cause the finalization of a
504 -- common pool. Allow only one task to finalize the contents.
506 if Pool.Finalization_Started then
510 -- Lock the pool to prevent the creation of additional subpools while
511 -- the available ones are finalized. The pool remains locked because
512 -- either it is about to be deallocated or the associated access type
513 -- is about to go out of scope.
515 Pool.Finalization_Started := True;
517 while not Is_Empty_List (Pool.Subpools'Unchecked_Access) loop
518 Curr_Ptr := Pool.Subpools.Next;
520 -- Perform the following actions:
522 -- 1) Finalize all objects chained on the subpool's master
523 -- 2) Remove the the subpool from the owner's list of subpools
524 -- 3) Deallocate the doubly linked list node associated with the
528 Finalize_Subpool (Curr_Ptr.Subpool);
531 when Fin_Occur : others =>
534 Save_Occurrence (Ex_Occur, Fin_Occur);
539 -- If the finalization of a particular master failed, reraise the
543 Reraise_Occurrence (Ex_Occur);
547 ----------------------
548 -- Finalize_Subpool --
549 ----------------------
551 procedure Finalize_Subpool (Subpool : not null Subpool_Handle) is
553 -- Do nothing if the subpool was never used
555 if Subpool.Owner = null
556 or else Subpool.Node = null
561 -- Clean up all controlled objects chained on the subpool's master
563 Finalize (Subpool.Master);
565 -- Remove the subpool from its owner's list of subpools
567 Detach (Subpool.Node);
569 -- Destroy the associated doubly linked list node which was created in
570 -- Set_Pool_Of_Subpool.
573 end Finalize_Subpool;
575 ------------------------------
576 -- Header_Size_With_Padding --
577 ------------------------------
579 function Header_Size_With_Padding
580 (Alignment : System.Storage_Elements.Storage_Count)
581 return System.Storage_Elements.Storage_Count
583 Size : constant Storage_Count := Header_Size;
586 if Size mod Alignment = 0 then
589 -- Add enough padding to reach the nearest multiple of the alignment
593 return ((Size + Alignment - 1) / Alignment) * Alignment;
595 end Header_Size_With_Padding;
601 overriding procedure Initialize (Controller : in out Pool_Controller) is
603 Initialize_Pool (Controller.Enclosing_Pool.all);
606 ---------------------
607 -- Initialize_Pool --
608 ---------------------
610 procedure Initialize_Pool (Pool : in out Root_Storage_Pool_With_Subpools) is
612 -- The dummy head must point to itself in both directions
614 Pool.Subpools.Next := Pool.Subpools'Unchecked_Access;
615 Pool.Subpools.Prev := Pool.Subpools'Unchecked_Access;
618 ---------------------
619 -- Pool_Of_Subpool --
620 ---------------------
622 function Pool_Of_Subpool (Subpool : not null Subpool_Handle)
623 return access Root_Storage_Pool_With_Subpools'Class
626 return Subpool.Owner;
633 procedure Print_Pool (Pool : Root_Storage_Pool_With_Subpools) is
634 Head : constant SP_Node_Ptr := Pool.Subpools'Unrestricted_Access;
635 Head_Seen : Boolean := False;
636 SP_Ptr : SP_Node_Ptr;
639 -- Output the contents of the pool
641 -- Pool : 0x123456789
642 -- Subpools : 0x123456789
643 -- Fin_Start : TRUE <or> FALSE
644 -- Controller: OK <or> NOK
647 Put_Line (Address_Image (Pool'Address));
650 Put_Line (Address_Image (Pool.Subpools'Address));
652 Put ("Fin_Start : ");
653 Put_Line (Pool.Finalization_Started'Img);
655 Put ("Controlled: ");
656 if Pool.Controller.Enclosing_Pool = Pool'Unrestricted_Access then
659 Put_Line ("NOK (ERROR)");
663 while SP_Ptr /= null loop -- Should never be null
666 -- We see the head initially; we want to exit when we see the head a
669 if SP_Ptr = Head then
675 -- The current element is null. This should never happend since the
678 if SP_Ptr.Prev = null then
679 Put_Line ("null (ERROR)");
681 -- The current element points back to the correct element
683 elsif SP_Ptr.Prev.Next = SP_Ptr then
686 -- The current element points to an erroneous element
689 Put_Line ("? (ERROR)");
692 -- Output the contents of the node
695 Put (Address_Image (SP_Ptr.all'Address));
696 if SP_Ptr = Head then
697 Put_Line (" (dummy head)");
704 if SP_Ptr.Prev = null then
707 Put_Line (Address_Image (SP_Ptr.Prev.all'Address));
712 if SP_Ptr.Next = null then
715 Put_Line (Address_Image (SP_Ptr.Next.all'Address));
720 if SP_Ptr.Subpool = null then
723 Put_Line (Address_Image (SP_Ptr.Subpool.all'Address));
726 SP_Ptr := SP_Ptr.Next;
734 procedure Print_Subpool (Subpool : Subpool_Handle) is
736 if Subpool = null then
741 -- Output the contents of a subpool
743 -- Owner : 0x123456789
744 -- Master: 0x123456789
745 -- Node : 0x123456789
748 if Subpool.Owner = null then
751 Put_Line (Address_Image (Subpool.Owner'Address));
755 Put_Line (Address_Image (Subpool.Master'Address));
758 if Subpool.Node = null then
761 if Subpool.Owner = null then
764 Put_Line (" (ERROR)");
767 Put_Line (Address_Image (Subpool.Node'Address));
770 Print_Master (Subpool.Master);
773 -------------------------
774 -- Set_Pool_Of_Subpool --
775 -------------------------
777 procedure Set_Pool_Of_Subpool
778 (Subpool : not null Subpool_Handle;
779 To : in out Root_Storage_Pool_With_Subpools'Class)
784 -- If the subpool is already owned, raise Program_Error. This is a
785 -- direct violation of the RM rules.
787 if Subpool.Owner /= null then
788 raise Program_Error with "subpool already belongs to a pool";
791 -- Prevent the creation of a new subpool while the owner is being
792 -- finalized. This is a serious error.
794 if To.Finalization_Started then
796 with "subpool creation after finalization started";
799 Subpool.Owner := To'Unchecked_Access;
801 -- Create a subpool node and decorate it. Since this node is not
802 -- allocated on the owner's pool, it must be explicitly destroyed by
803 -- Finalize_And_Detach.
805 N_Ptr := new SP_Node;
806 N_Ptr.Subpool := Subpool;
807 Subpool.Node := N_Ptr;
809 Attach (N_Ptr, To.Subpools'Unchecked_Access);
811 -- Mark the subpool's master as being a heterogeneous collection of
812 -- controlled objects.
814 Set_Is_Heterogeneous (Subpool.Master);
815 end Set_Pool_Of_Subpool;
817 end System.Storage_Pools.Subpools;