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-2023, 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
;
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 with System
.Storage_Pools
.Subpools
.Finalization
;
42 use System
.Storage_Pools
.Subpools
.Finalization
;
44 package body System
.Storage_Pools
.Subpools
is
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.
51 function Address_To_FM_Node_Ptr
is
52 new Ada
.Unchecked_Conversion
(Address
, FM_Node_Ptr
);
54 procedure Attach
(N
: not null SP_Node_Ptr
; L
: not null SP_Node_Ptr
);
55 -- Attach a subpool node to a pool
57 -----------------------------------
58 -- Adjust_Controlled_Dereference --
59 -----------------------------------
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
)
66 Header_And_Padding
: constant Storage_Offset
:=
67 Header_Size_With_Padding
(Alignment
);
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.
72 Addr
:= Addr
- Header_And_Padding
;
74 -- Update the size of the object to include the two pointers
76 Storage_Size
:= Storage_Size
+ Header_And_Padding
;
77 end Adjust_Controlled_Dereference
;
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
)
90 -- Dispatch to the user-defined implementations of Allocate_From_Subpool
91 -- and Default_Subpool_For_Pool.
94 (Root_Storage_Pool_With_Subpools
'Class (Pool
),
96 Size_In_Storage_Elements
,
98 Default_Subpool_For_Pool
99 (Root_Storage_Pool_With_Subpools
'Class (Pool
)));
102 -----------------------------
103 -- Allocate_Any_Controlled --
104 -----------------------------
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)
117 Is_Subpool_Allocation
: constant Boolean :=
118 Pool
in Root_Storage_Pool_With_Subpools
'Class;
120 Master
: Finalization_Master_Ptr
:= null;
123 N_Size
: Storage_Count
;
124 Subpool
: Subpool_Handle
:= null;
125 Lock_Taken
: Boolean := False;
127 Header_And_Padding
: Storage_Offset
;
128 -- This offset includes the size of a FM_Node plus any additional
129 -- padding due to a larger alignment.
132 -- Step 1: Pool-related runtime checks
134 -- Allocation on a pool_with_subpools. In this scenario there is a
135 -- master for each subpool. The master of the access type is ignored.
137 if Is_Subpool_Allocation
then
139 -- Case of an allocation without a Subpool_Handle. Dispatch to the
140 -- implementation of Default_Subpool_For_Pool.
142 if Context_Subpool
= null then
144 Default_Subpool_For_Pool
145 (Root_Storage_Pool_With_Subpools
'Class (Pool
));
147 -- Allocation with a Subpool_Handle
150 Subpool
:= Context_Subpool
;
153 -- Ensure proper ownership and chaining of the subpool
156 Root_Storage_Pool_With_Subpools
'Class (Pool
)'Unchecked_Access
157 or else Subpool
.Node
= null
158 or else Subpool
.Node
.Prev
= null
159 or else Subpool
.Node
.Next
= null
161 raise Program_Error
with "incorrect owner of subpool";
164 Master
:= Subpool
.Master
'Unchecked_Access;
166 -- Allocation on a simple pool. In this scenario there is a master for
167 -- each access-to-controlled type. No context subpool should be present.
170 -- If the master is missing, then the expansion of the access type
171 -- failed to create one. This is a compiler bug.
174 (Context_Master
/= null, "missing master in pool allocation");
176 -- If a subpool is present, then this is the result of erroneous
177 -- allocator expansion. This is not a serious error, but it should
178 -- still be detected.
180 if Context_Subpool
/= null then
182 with "subpool not required in pool allocation";
185 -- If the allocation is intended to be on a subpool, but the access
186 -- type's pool does not support subpools, then this is the result of
187 -- incorrect end-user code.
191 with "pool of access type does not support subpools";
194 Master
:= Context_Master
;
197 -- Step 2: Master, Finalize_Address-related runtime checks and size
200 -- Allocation of a descendant from [Limited_]Controlled, a class-wide
201 -- object or a record with controlled components.
203 if Is_Controlled
then
206 -- Read - allocation, finalization
207 -- Write - finalization
212 -- Do not allow the allocation of controlled objects while the
213 -- associated master is being finalized.
215 if Finalization_Started
(Master
.all) then
216 raise Program_Error
with "allocation after finalization started";
219 -- Check whether primitive Finalize_Address is available. If it is
220 -- not, then either the expansion of the designated type failed or
221 -- the expansion of the allocator failed. This is a compiler bug.
224 (Fin_Address
/= null, "primitive Finalize_Address not available");
226 -- The size must account for the hidden header preceding the object.
227 -- Account for possible padding space before the header due to a
230 Header_And_Padding
:= Header_Size_With_Padding
(Alignment
);
232 N_Size
:= Storage_Size
+ Header_And_Padding
;
234 -- Non-controlled allocation
237 N_Size
:= Storage_Size
;
240 -- Step 3: Allocation of object
242 -- For descendants of Root_Storage_Pool_With_Subpools, dispatch to the
243 -- implementation of Allocate_From_Subpool.
245 if Is_Subpool_Allocation
then
246 Allocate_From_Subpool
247 (Root_Storage_Pool_With_Subpools
'Class (Pool
),
248 N_Addr
, N_Size
, Alignment
, Subpool
);
250 -- For descendants of Root_Storage_Pool, dispatch to the implementation
254 Allocate
(Pool
, N_Addr
, N_Size
, Alignment
);
257 -- Step 4: Attachment
259 if Is_Controlled
then
261 -- Note that we already did "Lock_Task.all;" in Step 2 above
263 -- Map the allocated memory into a FM_Node record. This converts the
264 -- top of the allocated bits into a list header. If there is padding
265 -- due to larger alignment, the header is placed right next to the
271 -- +-------+---------------+----------------------+
272 -- |Padding| Header | Object |
273 -- +-------+---------------+----------------------+
275 -- | +- Header_Size -+
277 -- +- Header_And_Padding --+
280 Address_To_FM_Node_Ptr
(N_Addr
+ Header_And_Padding
- Header_Size
);
282 -- Prepend the allocated object to the finalization master
285 -- Write - allocation, deallocation, finalization
287 Attach_Unprotected
(N_Ptr
, Objects
(Master
.all));
289 -- Move the address from the hidden list header to the start of the
290 -- object. This operation effectively hides the list header.
292 Addr
:= N_Addr
+ Header_And_Padding
;
294 -- Homogeneous masters service the following:
296 -- 1) Allocations on / Deallocations from regular pools
297 -- 2) Named access types
298 -- 3) Most cases of anonymous access types usage
301 -- Read - allocation, finalization
304 if Master
.Is_Homogeneous
then
307 -- Read - finalization
308 -- Write - allocation, outside
310 Set_Finalize_Address_Unprotected
(Master
.all, Fin_Address
);
312 -- Heterogeneous masters service the following:
314 -- 1) Allocations on / Deallocations from subpools
315 -- 2) Certain cases of anonymous access types usage
319 -- Read - finalization
320 -- Write - allocation, deallocation
322 Set_Heterogeneous_Finalize_Address_Unprotected
(Addr
, Fin_Address
);
323 Finalize_Address_Table_In_Use
:= True;
329 -- Non-controlled allocation
338 -- Unlock the task in case the allocation step failed and reraise the
346 end Allocate_Any_Controlled
;
352 procedure Attach
(N
: not null SP_Node_Ptr
; L
: not null SP_Node_Ptr
) is
354 -- Ensure that the node has not been attached already
356 pragma Assert
(N
.Prev
= null and then N
.Next
= null);
367 -- Note: No need to unlock in case of an exception because the above
368 -- code can never raise one.
371 -------------------------------
372 -- Deallocate_Any_Controlled --
373 -------------------------------
375 procedure Deallocate_Any_Controlled
376 (Pool
: in out Root_Storage_Pool
'Class;
377 Addr
: System
.Address
;
378 Storage_Size
: System
.Storage_Elements
.Storage_Count
;
379 Alignment
: System
.Storage_Elements
.Storage_Count
;
380 Is_Controlled
: Boolean)
384 N_Size
: Storage_Count
;
386 Header_And_Padding
: Storage_Offset
;
387 -- This offset includes the size of a FM_Node plus any additional
388 -- padding due to a larger alignment.
391 -- Step 1: Detachment
393 if Is_Controlled
then
397 -- Destroy the relation pair object - Finalize_Address since it is
400 if Finalize_Address_Table_In_Use
then
403 -- Read - finalization
404 -- Write - allocation, deallocation
406 Delete_Finalize_Address_Unprotected
(Addr
);
409 -- Account for possible padding space before the header due to a
412 Header_And_Padding
:= Header_Size_With_Padding
(Alignment
);
414 -- N_Addr N_Ptr Addr (from input)
417 -- +-------+---------------+----------------------+
418 -- |Padding| Header | Object |
419 -- +-------+---------------+----------------------+
421 -- | +- Header_Size -+
423 -- +- Header_And_Padding --+
425 -- Convert the bits preceding the object into a list header
427 N_Ptr
:= Address_To_FM_Node_Ptr
(Addr
- Header_Size
);
429 -- Detach the object from the related finalization master. This
430 -- action does not need to know the prior context used during
434 -- Write - allocation, deallocation, finalization
436 Detach_Unprotected
(N_Ptr
);
438 -- Move the address from the object to the beginning of the list
441 N_Addr
:= Addr
- Header_And_Padding
;
443 -- The size of the deallocated object must include the size of the
444 -- hidden list header.
446 N_Size
:= Storage_Size
+ Header_And_Padding
;
453 -- Unlock the task in case the computations performed above
454 -- fail for some reason.
461 N_Size
:= Storage_Size
;
464 -- Step 2: Deallocation
466 -- Dispatch to the proper implementation of Deallocate. This action
467 -- covers both Root_Storage_Pool and Root_Storage_Pool_With_Subpools
470 Deallocate
(Pool
, N_Addr
, N_Size
, Alignment
);
471 end Deallocate_Any_Controlled
;
473 ------------------------------
474 -- Default_Subpool_For_Pool --
475 ------------------------------
477 function Default_Subpool_For_Pool
478 (Pool
: in out Root_Storage_Pool_With_Subpools
)
479 return not null Subpool_Handle
481 pragma Unreferenced
(Pool
);
483 return raise Program_Error
with
484 "default Default_Subpool_For_Pool called; must be overridden";
485 end Default_Subpool_For_Pool
;
491 procedure Detach
(N
: not null SP_Node_Ptr
) is
493 -- Ensure that the node is attached to some list
495 pragma Assert
(N
.Next
/= null and then N
.Prev
/= null);
499 N
.Prev
.Next
:= N
.Next
;
500 N
.Next
.Prev
:= N
.Prev
;
506 -- Note: No need to unlock in case of an exception because the above
507 -- code can never raise one.
514 overriding
procedure Finalize
(Controller
: in out Pool_Controller
) is
516 Finalize_Pool
(Controller
.Enclosing_Pool
.all);
523 procedure Finalize_Pool
(Pool
: in out Root_Storage_Pool_With_Subpools
) is
524 Curr_Ptr
: SP_Node_Ptr
;
525 Ex_Occur
: Exception_Occurrence
;
526 Raised
: Boolean := False;
528 function Is_Empty_List
(L
: not null SP_Node_Ptr
) return Boolean;
529 -- Determine whether a list contains only one element, the dummy head
535 function Is_Empty_List
(L
: not null SP_Node_Ptr
) return Boolean is
537 return L
.Next
= L
and then L
.Prev
= L
;
540 -- Start of processing for Finalize_Pool
543 -- It is possible for multiple tasks to cause the finalization of a
544 -- common pool. Allow only one task to finalize the contents.
546 if Pool
.Finalization_Started
then
550 -- Lock the pool to prevent the creation of additional subpools while
551 -- the available ones are finalized. The pool remains locked because
552 -- either it is about to be deallocated or the associated access type
553 -- is about to go out of scope.
555 Pool
.Finalization_Started
:= True;
557 while not Is_Empty_List
(Pool
.Subpools
'Unchecked_Access) loop
558 Curr_Ptr
:= Pool
.Subpools
.Next
;
560 -- Perform the following actions:
562 -- 1) Finalize all objects chained on the subpool's master
563 -- 2) Remove the subpool from the owner's list of subpools
564 -- 3) Deallocate the doubly linked list node associated with the
566 -- 4) Call Deallocate_Subpool
569 Finalize_And_Deallocate
(Curr_Ptr
.Subpool
);
572 when Fin_Occur
: others =>
575 Save_Occurrence
(Ex_Occur
, Fin_Occur
);
580 -- If the finalization of a particular master failed, reraise the
584 Reraise_Occurrence
(Ex_Occur
);
588 ------------------------------
589 -- Header_Size_With_Padding --
590 ------------------------------
592 function Header_Size_With_Padding
593 (Alignment
: System
.Storage_Elements
.Storage_Count
)
594 return System
.Storage_Elements
.Storage_Count
596 Size
: constant Storage_Count
:= Header_Size
;
599 if Size
mod Alignment
= 0 then
602 -- Add enough padding to reach the nearest multiple of the alignment
606 return ((Size
+ Alignment
- 1) / Alignment
) * Alignment
;
608 end Header_Size_With_Padding
;
614 overriding
procedure Initialize
(Controller
: in out Pool_Controller
) is
616 Initialize_Pool
(Controller
.Enclosing_Pool
.all);
619 ---------------------
620 -- Initialize_Pool --
621 ---------------------
623 procedure Initialize_Pool
(Pool
: in out Root_Storage_Pool_With_Subpools
) is
625 -- The dummy head must point to itself in both directions
627 Pool
.Subpools
.Next
:= Pool
.Subpools
'Unchecked_Access;
628 Pool
.Subpools
.Prev
:= Pool
.Subpools
'Unchecked_Access;
631 ---------------------
632 -- Pool_Of_Subpool --
633 ---------------------
635 function Pool_Of_Subpool
636 (Subpool
: not null Subpool_Handle
)
637 return access Root_Storage_Pool_With_Subpools
'Class
640 return Subpool
.Owner
;
647 procedure Print_Pool
(Pool
: Root_Storage_Pool_With_Subpools
) is
648 Head
: constant SP_Node_Ptr
:= Pool
.Subpools
'Unrestricted_Access;
649 Head_Seen
: Boolean := False;
650 SP_Ptr
: SP_Node_Ptr
;
653 -- Output the contents of the pool
655 -- Pool : 0x123456789
656 -- Subpools : 0x123456789
657 -- Fin_Start : TRUE <or> FALSE
658 -- Controller: OK <or> NOK
661 Put_Line
(Address_Image
(Pool
'Address));
664 Put_Line
(Address_Image
(Pool
.Subpools
'Address));
666 Put
("Fin_Start : ");
667 Put_Line
(Pool
.Finalization_Started
'Img);
669 Put
("Controlled: ");
670 if Pool
.Controller
.Enclosing_Pool
= Pool
'Unrestricted_Access then
673 Put_Line
("NOK (ERROR)");
677 while SP_Ptr
/= null loop -- Should never be null
680 -- We see the head initially; we want to exit when we see the head a
683 if SP_Ptr
= Head
then
689 -- The current element is null. This should never happend since the
692 if SP_Ptr
.Prev
= null then
693 Put_Line
("null (ERROR)");
695 -- The current element points back to the correct element
697 elsif SP_Ptr
.Prev
.Next
= SP_Ptr
then
700 -- The current element points to an erroneous element
703 Put_Line
("? (ERROR)");
706 -- Output the contents of the node
709 Put
(Address_Image
(SP_Ptr
.all'Address));
710 if SP_Ptr
= Head
then
711 Put_Line
(" (dummy head)");
718 if SP_Ptr
.Prev
= null then
721 Put_Line
(Address_Image
(SP_Ptr
.Prev
.all'Address));
726 if SP_Ptr
.Next
= null then
729 Put_Line
(Address_Image
(SP_Ptr
.Next
.all'Address));
734 if SP_Ptr
.Subpool
= null then
737 Put_Line
(Address_Image
(SP_Ptr
.Subpool
.all'Address));
740 SP_Ptr
:= SP_Ptr
.Next
;
748 procedure Print_Subpool
(Subpool
: Subpool_Handle
) is
750 if Subpool
= null then
755 -- Output the contents of a subpool
757 -- Owner : 0x123456789
758 -- Master: 0x123456789
759 -- Node : 0x123456789
762 if Subpool
.Owner
= null then
765 Put_Line
(Address_Image
(Subpool
.Owner
'Address));
769 Put_Line
(Address_Image
(Subpool
.Master
'Address));
772 if Subpool
.Node
= null then
775 if Subpool
.Owner
= null then
778 Put_Line
(" (ERROR)");
781 Put_Line
(Address_Image
(Subpool
.Node
'Address));
784 Print_Master
(Subpool
.Master
);
787 -------------------------
788 -- Set_Pool_Of_Subpool --
789 -------------------------
791 procedure Set_Pool_Of_Subpool
792 (Subpool
: not null Subpool_Handle
;
793 To
: in out Root_Storage_Pool_With_Subpools
'Class)
798 -- If the subpool is already owned, raise Program_Error. This is a
799 -- direct violation of the RM rules.
801 if Subpool
.Owner
/= null then
802 raise Program_Error
with "subpool already belongs to a pool";
805 -- Prevent the creation of a new subpool while the owner is being
806 -- finalized. This is a serious error.
808 if To
.Finalization_Started
then
810 with "subpool creation after finalization started";
813 Subpool
.Owner
:= To
'Unchecked_Access;
815 -- Create a subpool node and decorate it. Since this node is not
816 -- allocated on the owner's pool, it must be explicitly destroyed by
817 -- Finalize_And_Detach.
819 N_Ptr
:= new SP_Node
;
820 N_Ptr
.Subpool
:= Subpool
;
821 Subpool
.Node
:= N_Ptr
;
823 Attach
(N_Ptr
, To
.Subpools
'Unchecked_Access);
825 -- Mark the subpool's master as being a heterogeneous collection of
826 -- controlled objects.
828 Set_Is_Heterogeneous
(Subpool
.Master
);
829 end Set_Pool_Of_Subpool
;
831 end System
.Storage_Pools
.Subpools
;