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-2024, 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
;
34 with System
.Address_Image
;
35 with System
.IO
; use System
.IO
;
36 with System
.Soft_Links
; use System
.Soft_Links
;
37 with System
.Storage_Elements
; use System
.Storage_Elements
;
39 with System
.Storage_Pools
.Subpools
.Finalization
;
40 use System
.Storage_Pools
.Subpools
.Finalization
;
42 package body System
.Storage_Pools
.Subpools
is
44 procedure Attach
(N
: not null SP_Node_Ptr
; L
: not null SP_Node_Ptr
);
45 -- Attach a subpool node to a pool
47 -----------------------------------
48 -- Adjust_Controlled_Dereference --
49 -----------------------------------
51 procedure Adjust_Controlled_Dereference
52 (Addr
: in out System
.Address
;
53 Storage_Size
: in out System
.Storage_Elements
.Storage_Count
;
54 Alignment
: System
.Storage_Elements
.Storage_Count
)
56 Header_And_Padding
: constant Storage_Offset
:=
57 Header_Size_With_Padding
(Alignment
);
59 -- Expose the header and its padding by shifting the address from the
60 -- start of the object to the beginning of the padding.
62 Addr
:= Addr
- Header_And_Padding
;
64 -- Update the size to include the header and its padding
66 Storage_Size
:= Storage_Size
+ Header_And_Padding
;
67 end Adjust_Controlled_Dereference
;
73 overriding
procedure Allocate
74 (Pool
: in out Root_Storage_Pool_With_Subpools
;
75 Storage_Address
: out System
.Address
;
76 Size_In_Storage_Elements
: System
.Storage_Elements
.Storage_Count
;
77 Alignment
: System
.Storage_Elements
.Storage_Count
)
80 -- Dispatch to the user-defined implementations of Allocate_From_Subpool
81 -- and Default_Subpool_For_Pool.
84 (Root_Storage_Pool_With_Subpools
'Class (Pool
),
86 Size_In_Storage_Elements
,
88 Default_Subpool_For_Pool
89 (Root_Storage_Pool_With_Subpools
'Class (Pool
)));
92 -----------------------------
93 -- Allocate_Any_Controlled --
94 -----------------------------
96 procedure Allocate_Any_Controlled
97 (Pool
: in out Root_Storage_Pool
'Class;
98 Named_Subpool
: Subpool_Handle
;
100 Finalization_Primitives
.Finalization_Collection_Ptr
;
101 Addr
: out System
.Address
;
102 Storage_Size
: System
.Storage_Elements
.Storage_Count
;
103 Alignment
: System
.Storage_Elements
.Storage_Count
;
104 Is_Controlled
: Boolean;
105 On_Subpool
: Boolean)
107 use type System
.Finalization_Primitives
.Finalization_Collection_Ptr
;
109 Is_Subpool_Allocation
: constant Boolean :=
110 Pool
in Root_Storage_Pool_With_Subpools
'Class;
113 N_Alignment
: Storage_Count
;
114 N_Size
: Storage_Count
;
115 Subpool
: Subpool_Handle
;
117 Header_And_Padding
: Storage_Offset
;
118 -- This offset includes the size of a header plus an additional padding
119 -- due to a larger alignment of the object.
122 -- Step 1: Pool-related runtime checks
124 -- Allocation on a pool_with_subpools. In this scenario there is a
125 -- collection for each subpool. That of the access type is ignored.
127 if Is_Subpool_Allocation
then
129 -- Case of an allocation without a Subpool_Handle. Dispatch to the
130 -- implementation of Default_Subpool_For_Pool.
132 if Named_Subpool
= null then
134 Default_Subpool_For_Pool
135 (Root_Storage_Pool_With_Subpools
'Class (Pool
));
137 -- Allocation with a Subpool_Handle
140 Subpool
:= Named_Subpool
;
143 -- Ensure proper ownership and chaining of the subpool
146 Root_Storage_Pool_With_Subpools
'Class (Pool
)'Unchecked_Access
147 or else Subpool
.Node
= null
148 or else Subpool
.Node
.Prev
= null
149 or else Subpool
.Node
.Next
= null
151 raise Program_Error
with "incorrect owner of subpool";
154 Collection
:= Subpool
.Collection
'Unchecked_Access;
156 -- Allocation on a simple pool. In this scenario there is a collection
157 -- for each access-to-controlled type. No context subpool is allowed.
160 -- If the collection is missing, then the expansion of the access
161 -- type has failed to create one. This is a compiler bug.
164 (Collection
/= null, "no collection in pool allocation");
166 -- If a subpool is present, then this is the result of erroneous
167 -- allocator expansion. This is not a serious error, but it should
168 -- still be detected.
170 if Named_Subpool
/= null then
172 with "subpool not required in pool allocation";
175 -- If the allocation is intended to be on a subpool, but the access
176 -- type's pool does not support subpools, then this is the result of
177 -- incorrect end-user code.
181 with "pool of access type does not support subpools";
185 -- Step 2: Size and alignment calculations
187 -- Allocation of a descendant from [Limited_]Controlled, a class-wide
188 -- object or a record with controlled components.
190 if Is_Controlled
then
191 -- The size must account for the hidden header before the object.
192 -- Account for possible padding space before the header due to a
193 -- larger alignment of the object.
195 Header_And_Padding
:= Header_Size_With_Padding
(Alignment
);
197 N_Size
:= Storage_Size
+ Header_And_Padding
;
199 -- The alignment must account for the hidden header before the object
202 System
.Storage_Elements
.Storage_Count
'Max
203 (Alignment
, System
.Finalization_Primitives
.Header_Alignment
);
205 -- Non-controlled allocation
208 N_Size
:= Storage_Size
;
209 N_Alignment
:= Alignment
;
212 -- Step 3: Allocation of object
214 -- For descendants of Root_Storage_Pool_With_Subpools, dispatch to the
215 -- implementation of Allocate_From_Subpool.
217 if Is_Subpool_Allocation
then
218 Allocate_From_Subpool
219 (Root_Storage_Pool_With_Subpools
'Class (Pool
),
220 N_Addr
, N_Size
, N_Alignment
, Subpool
);
222 -- For descendants of Root_Storage_Pool, dispatch to the implementation
226 Allocate
(Pool
, N_Addr
, N_Size
, N_Alignment
);
229 -- Step 4: Displacement of address
231 if Is_Controlled
then
232 -- Move the address from the hidden list header to the start of the
233 -- object. If there is padding due to larger alignment of the object,
234 -- the padding is placed at the beginning. This effectively hides the
240 -- +-------+---------------+----------------------+
241 -- |Padding| Header | Object |
242 -- +-------+---------------+----------------------+
244 -- | +- Header_Size -+
246 -- +- Header_And_Padding --+
248 Addr
:= N_Addr
+ Header_And_Padding
;
250 -- Non-controlled allocation
255 end Allocate_Any_Controlled
;
261 procedure Attach
(N
: not null SP_Node_Ptr
; L
: not null SP_Node_Ptr
) is
263 -- Ensure that the node has not been attached already
265 pragma Assert
(N
.Prev
= null and then N
.Next
= null);
276 -- Note: No need to unlock in case of an exception because the above
277 -- code can never raise one.
280 -------------------------------
281 -- Deallocate_Any_Controlled --
282 -------------------------------
284 procedure Deallocate_Any_Controlled
285 (Pool
: in out Root_Storage_Pool
'Class;
286 Addr
: System
.Address
;
287 Storage_Size
: System
.Storage_Elements
.Storage_Count
;
288 Alignment
: System
.Storage_Elements
.Storage_Count
;
289 Is_Controlled
: Boolean)
292 N_Alignment
: Storage_Count
;
293 N_Size
: Storage_Count
;
295 Header_And_Padding
: Storage_Offset
;
296 -- This offset includes the size of a header plus an additional padding
297 -- due to a larger alignment of the object.
300 -- Step 1: Displacement of address
302 if Is_Controlled
then
303 -- Account for possible padding space before the header due to a
306 Header_And_Padding
:= Header_Size_With_Padding
(Alignment
);
311 -- +-------+---------------+----------------------+
312 -- |Padding| Header | Object |
313 -- +-------+---------------+----------------------+
315 -- | +- Header_Size -+
317 -- +- Header_And_Padding --+
319 -- Move the address from the object to the beginning of the header
321 N_Addr
:= Addr
- Header_And_Padding
;
323 -- The size of the deallocated object must include that of the header
325 N_Size
:= Storage_Size
+ Header_And_Padding
;
327 -- The alignment must account for the hidden header before the object
330 System
.Storage_Elements
.Storage_Count
'Max
331 (Alignment
, System
.Finalization_Primitives
.Header_Alignment
);
335 N_Size
:= Storage_Size
;
336 N_Alignment
:= Alignment
;
339 -- Step 2: Deallocation of object
341 -- Dispatch to the proper implementation of Deallocate. This action
342 -- covers both Root_Storage_Pool and Root_Storage_Pool_With_Subpools
345 Deallocate
(Pool
, N_Addr
, N_Size
, N_Alignment
);
346 end Deallocate_Any_Controlled
;
348 ------------------------------
349 -- Default_Subpool_For_Pool --
350 ------------------------------
352 function Default_Subpool_For_Pool
353 (Pool
: in out Root_Storage_Pool_With_Subpools
)
354 return not null Subpool_Handle
356 pragma Unreferenced
(Pool
);
358 return raise Program_Error
with
359 "default Default_Subpool_For_Pool called; must be overridden";
360 end Default_Subpool_For_Pool
;
366 procedure Detach
(N
: not null SP_Node_Ptr
) is
368 -- Ensure that the node is attached to some list
370 pragma Assert
(N
.Next
/= null and then N
.Prev
/= null);
374 N
.Prev
.Next
:= N
.Next
;
375 N
.Next
.Prev
:= N
.Prev
;
381 -- Note: No need to unlock in case of an exception because the above
382 -- code can never raise one.
389 overriding
procedure Finalize
(Controller
: in out Pool_Controller
) is
391 Finalize_Pool
(Controller
.Enclosing_Pool
.all);
398 procedure Finalize_Pool
(Pool
: in out Root_Storage_Pool_With_Subpools
) is
399 Curr_Ptr
: SP_Node_Ptr
;
400 Ex_Occur
: Exception_Occurrence
;
401 Raised
: Boolean := False;
403 function Is_Empty_List
(L
: not null SP_Node_Ptr
) return Boolean;
404 -- Determine whether a list contains only one element, the dummy head
410 function Is_Empty_List
(L
: not null SP_Node_Ptr
) return Boolean is
412 return L
.Next
= L
and then L
.Prev
= L
;
415 -- Start of processing for Finalize_Pool
418 -- It is possible for multiple tasks to cause the finalization of a
419 -- common pool. Allow only one task to finalize the contents.
421 if Pool
.Finalization_Started
then
425 -- Lock the pool to prevent the creation of additional subpools while
426 -- the available ones are finalized. The pool remains locked because
427 -- either it is about to be deallocated or the associated access type
428 -- is about to go out of scope.
430 Pool
.Finalization_Started
:= True;
432 while not Is_Empty_List
(Pool
.Subpools
'Unchecked_Access) loop
433 Curr_Ptr
:= Pool
.Subpools
.Next
;
435 -- Perform the following actions:
437 -- 1) Finalize all objects chained on the subpool's collection
438 -- 2) Remove the subpool from the owner's list of subpools
439 -- 3) Deallocate the doubly linked list node associated with the
441 -- 4) Call Deallocate_Subpool
444 Finalize_And_Deallocate
(Curr_Ptr
.Subpool
);
447 when Fin_Occur
: others =>
450 Save_Occurrence
(Ex_Occur
, Fin_Occur
);
455 -- If the finalization of a particular collection failed, reraise the
459 Reraise_Occurrence
(Ex_Occur
);
463 ------------------------------
464 -- Header_Size_With_Padding --
465 ------------------------------
467 function Header_Size_With_Padding
468 (Alignment
: System
.Storage_Elements
.Storage_Count
)
469 return System
.Storage_Elements
.Storage_Count
471 Size
: constant Storage_Count
:=
472 System
.Finalization_Primitives
.Header_Size
;
475 if Size
mod Alignment
= 0 then
478 -- Add enough padding to reach the nearest multiple of the alignment
482 return ((Size
+ Alignment
- 1) / Alignment
) * Alignment
;
484 end Header_Size_With_Padding
;
490 overriding
procedure Initialize
(Controller
: in out Pool_Controller
) is
492 Initialize_Pool
(Controller
.Enclosing_Pool
.all);
495 ---------------------
496 -- Initialize_Pool --
497 ---------------------
499 procedure Initialize_Pool
(Pool
: in out Root_Storage_Pool_With_Subpools
) is
501 -- The dummy head must point to itself in both directions
503 Pool
.Subpools
.Next
:= Pool
.Subpools
'Unchecked_Access;
504 Pool
.Subpools
.Prev
:= Pool
.Subpools
'Unchecked_Access;
507 ---------------------
508 -- Pool_Of_Subpool --
509 ---------------------
511 function Pool_Of_Subpool
512 (Subpool
: not null Subpool_Handle
)
513 return access Root_Storage_Pool_With_Subpools
'Class
516 return Subpool
.Owner
;
523 procedure Print_Pool
(Pool
: Root_Storage_Pool_With_Subpools
) is
524 Head
: constant SP_Node_Ptr
:= Pool
.Subpools
'Unrestricted_Access;
525 Head_Seen
: Boolean := False;
526 SP_Ptr
: SP_Node_Ptr
;
529 -- Output the contents of the pool
531 -- Pool : 0x123456789
532 -- Subpools : 0x123456789
533 -- Fin_Start : TRUE <or> FALSE
534 -- Controller: OK <or> NOK
537 Put_Line
(Address_Image
(Pool
'Address));
540 Put_Line
(Address_Image
(Pool
.Subpools
'Address));
542 Put
("Fin_Start : ");
543 Put_Line
(Pool
.Finalization_Started
'Img);
545 Put
("Controlled: ");
546 if Pool
.Controller
.Enclosing_Pool
= Pool
'Unrestricted_Access then
549 Put_Line
("NOK (ERROR)");
553 while SP_Ptr
/= null loop -- Should never be null
556 -- We see the head initially; we want to exit when we see the head a
559 if SP_Ptr
= Head
then
565 -- The current element is null. This should never happend since the
568 if SP_Ptr
.Prev
= null then
569 Put_Line
("null (ERROR)");
571 -- The current element points back to the correct element
573 elsif SP_Ptr
.Prev
.Next
= SP_Ptr
then
576 -- The current element points to an erroneous element
579 Put_Line
("? (ERROR)");
582 -- Output the contents of the node
585 Put
(Address_Image
(SP_Ptr
.all'Address));
586 if SP_Ptr
= Head
then
587 Put_Line
(" (dummy head)");
594 if SP_Ptr
.Prev
= null then
597 Put_Line
(Address_Image
(SP_Ptr
.Prev
.all'Address));
602 if SP_Ptr
.Next
= null then
605 Put_Line
(Address_Image
(SP_Ptr
.Next
.all'Address));
610 if SP_Ptr
.Subpool
= null then
613 Put_Line
(Address_Image
(SP_Ptr
.Subpool
.all'Address));
616 SP_Ptr
:= SP_Ptr
.Next
;
624 procedure Print_Subpool
(Subpool
: Subpool_Handle
) is
626 if Subpool
= null then
631 -- Output the contents of a subpool
633 -- Owner : 0x123456789
634 -- Collection: 0x123456789
635 -- Node : 0x123456789
638 if Subpool
.Owner
= null then
641 Put_Line
(Address_Image
(Subpool
.Owner
'Address));
644 Put
("Collection: ");
645 Put_Line
(Address_Image
(Subpool
.Collection
'Address));
648 if Subpool
.Node
= null then
651 if Subpool
.Owner
= null then
654 Put_Line
(" (ERROR)");
657 Put_Line
(Address_Image
(Subpool
.Node
'Address));
661 -------------------------
662 -- Set_Pool_Of_Subpool --
663 -------------------------
665 procedure Set_Pool_Of_Subpool
666 (Subpool
: not null Subpool_Handle
;
667 To
: in out Root_Storage_Pool_With_Subpools
'Class)
672 -- If the subpool is already owned, raise Program_Error. This is a
673 -- direct violation of the RM rules.
675 if Subpool
.Owner
/= null then
676 raise Program_Error
with "subpool already belongs to a pool";
679 -- Prevent the creation of a new subpool while the owner is being
680 -- finalized. This is a serious error.
682 if To
.Finalization_Started
then
684 with "subpool creation after finalization started";
687 Subpool
.Owner
:= To
'Unchecked_Access;
689 -- Create a subpool node and decorate it. Since this node is not
690 -- allocated on the owner's pool, it must be explicitly destroyed by
691 -- Finalize_And_Detach.
693 N_Ptr
:= new SP_Node
;
694 N_Ptr
.Subpool
:= Subpool
;
695 Subpool
.Node
:= N_Ptr
;
697 Attach
(N_Ptr
, To
.Subpools
'Unchecked_Access);
698 end Set_Pool_Of_Subpool
;
700 end System
.Storage_Pools
.Subpools
;