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-2012, 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 -----------------------------------
60 -- Adjust_Controlled_Dereference --
61 -----------------------------------
63 procedure Adjust_Controlled_Dereference
64 (Addr
: in out System
.Address
;
65 Storage_Size
: in out System
.Storage_Elements
.Storage_Count
;
66 Alignment
: System
.Storage_Elements
.Storage_Count
)
68 Header_And_Padding
: constant Storage_Offset
:=
69 Header_Size_With_Padding
(Alignment
);
71 -- Expose the two hidden pointers by shifting the address from the
72 -- start of the object to the FM_Node equivalent of the pointers.
74 Addr
:= Addr
- Header_And_Padding
;
76 -- Update the size of the object to include the two pointers
78 Storage_Size
:= Storage_Size
+ Header_And_Padding
;
79 end Adjust_Controlled_Dereference
;
85 overriding
procedure Allocate
86 (Pool
: in out Root_Storage_Pool_With_Subpools
;
87 Storage_Address
: out System
.Address
;
88 Size_In_Storage_Elements
: System
.Storage_Elements
.Storage_Count
;
89 Alignment
: System
.Storage_Elements
.Storage_Count
)
92 -- Dispatch to the user-defined implementations of Allocate_From_Subpool
93 -- and Default_Subpool_For_Pool.
96 (Root_Storage_Pool_With_Subpools
'Class (Pool
),
98 Size_In_Storage_Elements
,
100 Default_Subpool_For_Pool
101 (Root_Storage_Pool_With_Subpools
'Class (Pool
)));
104 -----------------------------
105 -- Allocate_Any_Controlled --
106 -----------------------------
108 procedure Allocate_Any_Controlled
109 (Pool
: in out Root_Storage_Pool
'Class;
110 Context_Subpool
: Subpool_Handle
;
111 Context_Master
: Finalization_Masters
.Finalization_Master_Ptr
;
112 Fin_Address
: Finalization_Masters
.Finalize_Address_Ptr
;
113 Addr
: out System
.Address
;
114 Storage_Size
: System
.Storage_Elements
.Storage_Count
;
115 Alignment
: System
.Storage_Elements
.Storage_Count
;
116 Is_Controlled
: Boolean;
117 On_Subpool
: Boolean)
119 Is_Subpool_Allocation
: constant Boolean :=
120 Pool
in Root_Storage_Pool_With_Subpools
'Class;
122 Master
: Finalization_Master_Ptr
:= null;
125 N_Size
: Storage_Count
;
126 Subpool
: Subpool_Handle
:= null;
128 Allocation_Locked
: Boolean;
129 -- This flag stores the state of the associated collection
131 Header_And_Padding
: Storage_Offset
;
132 -- This offset includes the size of a FM_Node plus any additional
133 -- padding due to a larger alignment.
136 -- Step 1: Pool-related runtime checks
138 -- Allocation on a pool_with_subpools. In this scenario there is a
139 -- master for each subpool. The master of the access type is ignored.
141 if Is_Subpool_Allocation
then
143 -- Case of an allocation without a Subpool_Handle. Dispatch to the
144 -- implementation of Default_Subpool_For_Pool.
146 if Context_Subpool
= null then
148 Default_Subpool_For_Pool
149 (Root_Storage_Pool_With_Subpools
'Class (Pool
));
151 -- Allocation with a Subpool_Handle
154 Subpool
:= Context_Subpool
;
157 -- Ensure proper ownership and chaining of the subpool
160 Root_Storage_Pool_With_Subpools
'Class (Pool
)'Unchecked_Access
161 or else Subpool
.Node
= null
162 or else Subpool
.Node
.Prev
= null
163 or else Subpool
.Node
.Next
= null
165 raise Program_Error
with "incorrect owner of subpool";
168 Master
:= Subpool
.Master
'Unchecked_Access;
170 -- Allocation on a simple pool. In this scenario there is a master for
171 -- each access-to-controlled type. No context subpool should be present.
174 -- If the master is missing, then the expansion of the access type
175 -- failed to create one. This is a serious error.
177 if Context_Master
= null then
179 with "missing master in pool allocation";
181 -- If a subpool is present, then this is the result of erroneous
182 -- allocator expansion. This is not a serious error, but it should
183 -- still be detected.
185 elsif Context_Subpool
/= null then
187 with "subpool not required in pool allocation";
189 -- If the allocation is intended to be on a subpool, but the access
190 -- type's pool does not support subpools, then this is the result of
191 -- erroneous end-user code.
193 elsif On_Subpool
then
195 with "pool of access type does not support subpools";
198 Master
:= Context_Master
;
201 -- Step 2: Master, Finalize_Address-related runtime checks and size
204 -- Allocation of a descendant from [Limited_]Controlled, a class-wide
205 -- object or a record with controlled components.
207 if Is_Controlled
then
210 -- Read - allocation, finalization
211 -- Write - finalization
214 Allocation_Locked
:= Finalization_Started
(Master
.all);
217 -- Do not allow the allocation of controlled objects while the
218 -- associated master is being finalized.
220 if Allocation_Locked
then
221 raise Program_Error
with "allocation after finalization started";
224 -- Check whether primitive Finalize_Address is available. If it is
225 -- not, then either the expansion of the designated type failed or
226 -- the expansion of the allocator failed. This is a serious error.
228 if Fin_Address
= null then
230 with "primitive Finalize_Address not available";
233 -- The size must acount for the hidden header preceding the object.
234 -- Account for possible padding space before the header due to a
237 Header_And_Padding
:= Header_Size_With_Padding
(Alignment
);
239 N_Size
:= Storage_Size
+ Header_And_Padding
;
241 -- Non-controlled allocation
244 N_Size
:= Storage_Size
;
247 -- Step 3: Allocation of object
249 -- For descendants of Root_Storage_Pool_With_Subpools, dispatch to the
250 -- implementation of Allocate_From_Subpool.
252 if Is_Subpool_Allocation
then
253 Allocate_From_Subpool
254 (Root_Storage_Pool_With_Subpools
'Class (Pool
),
255 N_Addr
, N_Size
, Alignment
, Subpool
);
257 -- For descendants of Root_Storage_Pool, dispatch to the implementation
261 Allocate
(Pool
, N_Addr
, N_Size
, Alignment
);
264 -- Step 4: Attachment
266 if Is_Controlled
then
269 -- Map the allocated memory into a FM_Node record. This converts the
270 -- top of the allocated bits into a list header. If there is padding
271 -- due to larger alignment, the header is placed right next to the
277 -- +-------+---------------+----------------------+
278 -- |Padding| Header | Object |
279 -- +-------+---------------+----------------------+
281 -- | +- Header_Size -+
283 -- +- Header_And_Padding --+
285 N_Ptr
:= Address_To_FM_Node_Ptr
286 (N_Addr
+ Header_And_Padding
- Header_Offset
);
288 -- Prepend the allocated object to the finalization master
291 -- Write - allocation, deallocation, finalization
293 Attach_Unprotected
(N_Ptr
, Objects
(Master
.all));
295 -- Move the address from the hidden list header to the start of the
296 -- object. This operation effectively hides the list header.
298 Addr
:= N_Addr
+ Header_And_Padding
;
300 -- Homogeneous masters service the following:
302 -- 1) Allocations on / Deallocations from regular pools
303 -- 2) Named access types
304 -- 3) Most cases of anonymous access types usage
307 -- Read - allocation, finalization
310 if Master
.Is_Homogeneous
then
313 -- Read - finalization
314 -- Write - allocation, outside
316 Set_Finalize_Address_Unprotected
(Master
.all, Fin_Address
);
318 -- Heterogeneous masters service the following:
320 -- 1) Allocations on / Deallocations from subpools
321 -- 2) Certain cases of anonymous access types usage
325 -- Read - finalization
326 -- Write - allocation, deallocation
328 Set_Heterogeneous_Finalize_Address_Unprotected
(Addr
, Fin_Address
);
329 Finalize_Address_Table_In_Use
:= True;
334 -- Non-controlled allocation
339 end Allocate_Any_Controlled
;
345 procedure Attach
(N
: not null SP_Node_Ptr
; L
: not null SP_Node_Ptr
) is
347 -- Ensure that the node has not been attached already
349 pragma Assert
(N
.Prev
= null and then N
.Next
= null);
360 -- Note: No need to unlock in case of an exception because the above
361 -- code can never raise one.
364 -------------------------------
365 -- Deallocate_Any_Controlled --
366 -------------------------------
368 procedure Deallocate_Any_Controlled
369 (Pool
: in out Root_Storage_Pool
'Class;
370 Addr
: System
.Address
;
371 Storage_Size
: System
.Storage_Elements
.Storage_Count
;
372 Alignment
: System
.Storage_Elements
.Storage_Count
;
373 Is_Controlled
: Boolean)
377 N_Size
: Storage_Count
;
379 Header_And_Padding
: Storage_Offset
;
380 -- This offset includes the size of a FM_Node plus any additional
381 -- padding due to a larger alignment.
384 -- Step 1: Detachment
386 if Is_Controlled
then
389 -- Destroy the relation pair object - Finalize_Address since it is no
392 if Finalize_Address_Table_In_Use
then
395 -- Read - finalization
396 -- Write - allocation, deallocation
398 Delete_Finalize_Address_Unprotected
(Addr
);
401 -- Account for possible padding space before the header due to a
404 Header_And_Padding
:= Header_Size_With_Padding
(Alignment
);
406 -- N_Addr N_Ptr Addr (from input)
409 -- +-------+---------------+----------------------+
410 -- |Padding| Header | Object |
411 -- +-------+---------------+----------------------+
413 -- | +- Header_Size -+
415 -- +- Header_And_Padding --+
417 -- Convert the bits preceding the object into a list header
419 N_Ptr
:= Address_To_FM_Node_Ptr
(Addr
- Header_Offset
);
421 -- Detach the object from the related finalization master. This
422 -- action does not need to know the prior context used during
426 -- Write - allocation, deallocation, finalization
428 Detach_Unprotected
(N_Ptr
);
430 -- Move the address from the object to the beginning of the list
433 N_Addr
:= Addr
- Header_And_Padding
;
435 -- The size of the deallocated object must include the size of the
436 -- hidden list header.
438 N_Size
:= Storage_Size
+ Header_And_Padding
;
444 N_Size
:= Storage_Size
;
447 -- Step 2: Deallocation
449 -- Dispatch to the proper implementation of Deallocate. This action
450 -- covers both Root_Storage_Pool and Root_Storage_Pool_With_Subpools
453 Deallocate
(Pool
, N_Addr
, N_Size
, Alignment
);
454 end Deallocate_Any_Controlled
;
456 ------------------------------
457 -- Default_Subpool_For_Pool --
458 ------------------------------
460 function Default_Subpool_For_Pool
461 (Pool
: Root_Storage_Pool_With_Subpools
) return not null Subpool_Handle
465 return Pool
.Subpools
.Subpool
;
466 end Default_Subpool_For_Pool
;
472 procedure Detach
(N
: not null SP_Node_Ptr
) is
474 -- Ensure that the node is attached to some list
476 pragma Assert
(N
.Next
/= null and then N
.Prev
/= null);
480 N
.Prev
.Next
:= N
.Next
;
481 N
.Next
.Prev
:= N
.Prev
;
487 -- Note: No need to unlock in case of an exception because the above
488 -- code can never raise one.
495 overriding
procedure Finalize
(Controller
: in out Pool_Controller
) is
497 Finalize_Pool
(Controller
.Enclosing_Pool
.all);
504 procedure Finalize_Pool
(Pool
: in out Root_Storage_Pool_With_Subpools
) is
505 Curr_Ptr
: SP_Node_Ptr
;
506 Ex_Occur
: Exception_Occurrence
;
507 Raised
: Boolean := False;
509 function Is_Empty_List
(L
: not null SP_Node_Ptr
) return Boolean;
510 -- Determine whether a list contains only one element, the dummy head
516 function Is_Empty_List
(L
: not null SP_Node_Ptr
) return Boolean is
518 return L
.Next
= L
and then L
.Prev
= L
;
521 -- Start of processing for Finalize_Pool
524 -- It is possible for multiple tasks to cause the finalization of a
525 -- common pool. Allow only one task to finalize the contents.
527 if Pool
.Finalization_Started
then
531 -- Lock the pool to prevent the creation of additional subpools while
532 -- the available ones are finalized. The pool remains locked because
533 -- either it is about to be deallocated or the associated access type
534 -- is about to go out of scope.
536 Pool
.Finalization_Started
:= True;
538 while not Is_Empty_List
(Pool
.Subpools
'Unchecked_Access) loop
539 Curr_Ptr
:= Pool
.Subpools
.Next
;
541 -- Perform the following actions:
543 -- 1) Finalize all objects chained on the subpool's master
544 -- 2) Remove the the subpool from the owner's list of subpools
545 -- 3) Deallocate the doubly linked list node associated with the
549 Finalize_Subpool
(Curr_Ptr
.Subpool
);
552 when Fin_Occur
: others =>
555 Save_Occurrence
(Ex_Occur
, Fin_Occur
);
560 -- If the finalization of a particular master failed, reraise the
564 Reraise_Occurrence
(Ex_Occur
);
568 ----------------------
569 -- Finalize_Subpool --
570 ----------------------
572 procedure Finalize_Subpool
(Subpool
: not null Subpool_Handle
) is
574 -- Do nothing if the subpool was never used
576 if Subpool
.Owner
= null or else Subpool
.Node
= null then
580 -- Clean up all controlled objects chained on the subpool's master
582 Finalize
(Subpool
.Master
);
584 -- Remove the subpool from its owner's list of subpools
586 Detach
(Subpool
.Node
);
588 -- Destroy the associated doubly linked list node which was created in
589 -- Set_Pool_Of_Subpool.
592 end Finalize_Subpool
;
594 ------------------------------
595 -- Header_Size_With_Padding --
596 ------------------------------
598 function Header_Size_With_Padding
599 (Alignment
: System
.Storage_Elements
.Storage_Count
)
600 return System
.Storage_Elements
.Storage_Count
602 Size
: constant Storage_Count
:= Header_Size
;
605 if Size
mod Alignment
= 0 then
608 -- Add enough padding to reach the nearest multiple of the alignment
612 return ((Size
+ Alignment
- 1) / Alignment
) * Alignment
;
614 end Header_Size_With_Padding
;
620 overriding
procedure Initialize
(Controller
: in out Pool_Controller
) is
622 Initialize_Pool
(Controller
.Enclosing_Pool
.all);
625 ---------------------
626 -- Initialize_Pool --
627 ---------------------
629 procedure Initialize_Pool
(Pool
: in out Root_Storage_Pool_With_Subpools
) is
631 -- The dummy head must point to itself in both directions
633 Pool
.Subpools
.Next
:= Pool
.Subpools
'Unchecked_Access;
634 Pool
.Subpools
.Prev
:= Pool
.Subpools
'Unchecked_Access;
637 ---------------------
638 -- Pool_Of_Subpool --
639 ---------------------
641 function Pool_Of_Subpool
642 (Subpool
: not null Subpool_Handle
)
643 return access Root_Storage_Pool_With_Subpools
'Class
646 return Subpool
.Owner
;
653 procedure Print_Pool
(Pool
: Root_Storage_Pool_With_Subpools
) is
654 Head
: constant SP_Node_Ptr
:= Pool
.Subpools
'Unrestricted_Access;
655 Head_Seen
: Boolean := False;
656 SP_Ptr
: SP_Node_Ptr
;
659 -- Output the contents of the pool
661 -- Pool : 0x123456789
662 -- Subpools : 0x123456789
663 -- Fin_Start : TRUE <or> FALSE
664 -- Controller: OK <or> NOK
667 Put_Line
(Address_Image
(Pool
'Address));
670 Put_Line
(Address_Image
(Pool
.Subpools
'Address));
672 Put
("Fin_Start : ");
673 Put_Line
(Pool
.Finalization_Started
'Img);
675 Put
("Controlled: ");
676 if Pool
.Controller
.Enclosing_Pool
= Pool
'Unrestricted_Access then
679 Put_Line
("NOK (ERROR)");
683 while SP_Ptr
/= null loop -- Should never be null
686 -- We see the head initially; we want to exit when we see the head a
689 if SP_Ptr
= Head
then
695 -- The current element is null. This should never happend since the
698 if SP_Ptr
.Prev
= null then
699 Put_Line
("null (ERROR)");
701 -- The current element points back to the correct element
703 elsif SP_Ptr
.Prev
.Next
= SP_Ptr
then
706 -- The current element points to an erroneous element
709 Put_Line
("? (ERROR)");
712 -- Output the contents of the node
715 Put
(Address_Image
(SP_Ptr
.all'Address));
716 if SP_Ptr
= Head
then
717 Put_Line
(" (dummy head)");
724 if SP_Ptr
.Prev
= null then
727 Put_Line
(Address_Image
(SP_Ptr
.Prev
.all'Address));
732 if SP_Ptr
.Next
= null then
735 Put_Line
(Address_Image
(SP_Ptr
.Next
.all'Address));
740 if SP_Ptr
.Subpool
= null then
743 Put_Line
(Address_Image
(SP_Ptr
.Subpool
.all'Address));
746 SP_Ptr
:= SP_Ptr
.Next
;
754 procedure Print_Subpool
(Subpool
: Subpool_Handle
) is
756 if Subpool
= null then
761 -- Output the contents of a subpool
763 -- Owner : 0x123456789
764 -- Master: 0x123456789
765 -- Node : 0x123456789
768 if Subpool
.Owner
= null then
771 Put_Line
(Address_Image
(Subpool
.Owner
'Address));
775 Put_Line
(Address_Image
(Subpool
.Master
'Address));
778 if Subpool
.Node
= null then
781 if Subpool
.Owner
= null then
784 Put_Line
(" (ERROR)");
787 Put_Line
(Address_Image
(Subpool
.Node
'Address));
790 Print_Master
(Subpool
.Master
);
793 -------------------------
794 -- Set_Pool_Of_Subpool --
795 -------------------------
797 procedure Set_Pool_Of_Subpool
798 (Subpool
: not null Subpool_Handle
;
799 To
: in out Root_Storage_Pool_With_Subpools
'Class)
804 -- If the subpool is already owned, raise Program_Error. This is a
805 -- direct violation of the RM rules.
807 if Subpool
.Owner
/= null then
808 raise Program_Error
with "subpool already belongs to a pool";
811 -- Prevent the creation of a new subpool while the owner is being
812 -- finalized. This is a serious error.
814 if To
.Finalization_Started
then
816 with "subpool creation after finalization started";
819 Subpool
.Owner
:= To
'Unchecked_Access;
821 -- Create a subpool node and decorate it. Since this node is not
822 -- allocated on the owner's pool, it must be explicitly destroyed by
823 -- Finalize_And_Detach.
825 N_Ptr
:= new SP_Node
;
826 N_Ptr
.Subpool
:= Subpool
;
827 Subpool
.Node
:= N_Ptr
;
829 Attach
(N_Ptr
, To
.Subpools
'Unchecked_Access);
831 -- Mark the subpool's master as being a heterogeneous collection of
832 -- controlled objects.
834 Set_Is_Heterogeneous
(Subpool
.Master
);
835 end Set_Pool_Of_Subpool
;
837 end System
.Storage_Pools
.Subpools
;