]>
Commit | Line | Data |
---|---|---|
d3f70b35 AC |
1 | ------------------------------------------------------------------------------ |
2 | -- -- | |
3 | -- GNAT COMPILER COMPONENTS -- | |
4 | -- -- | |
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 -- | |
6 | -- -- | |
7 | -- B o d y -- | |
8 | -- -- | |
4b490c1e | 9 | -- Copyright (C) 2011-2020, Free Software Foundation, Inc. -- |
d3f70b35 | 10 | -- -- |
d3f70b35 AC |
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. -- | |
17 | -- -- | |
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. -- | |
21 | -- -- | |
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/>. -- | |
26 | -- -- | |
27 | -- GNAT was originally developed by the GNAT team at New York University. -- | |
28 | -- Extensive contributions were provided by Ada Core Technologies Inc. -- | |
29 | -- -- | |
30 | ------------------------------------------------------------------------------ | |
31 | ||
60b68e56 | 32 | with Ada.Exceptions; use Ada.Exceptions; |
14f0f659 | 33 | with Ada.Unchecked_Conversion; |
60b68e56 | 34 | |
14f0f659 | 35 | with System.Address_Image; |
d3f70b35 | 36 | with System.Finalization_Masters; use System.Finalization_Masters; |
14f0f659 | 37 | with System.IO; use System.IO; |
d3f70b35 AC |
38 | with System.Soft_Links; use System.Soft_Links; |
39 | with System.Storage_Elements; use System.Storage_Elements; | |
60b68e56 | 40 | |
5707e389 AC |
41 | with System.Storage_Pools.Subpools.Finalization; |
42 | use System.Storage_Pools.Subpools.Finalization; | |
d3f70b35 AC |
43 | |
44 | package body System.Storage_Pools.Subpools is | |
45 | ||
14f0f659 | 46 | Finalize_Address_Table_In_Use : Boolean := False; |
211e7410 | 47 | -- This flag should be set only when a successful allocation on a subpool |
14f0f659 AC |
48 | -- has been performed and the associated Finalize_Address has been added to |
49 | -- the hash table in System.Finalization_Masters. | |
50 | ||
51 | function Address_To_FM_Node_Ptr is | |
52 | new Ada.Unchecked_Conversion (Address, FM_Node_Ptr); | |
53 | ||
d3f70b35 AC |
54 | procedure Attach (N : not null SP_Node_Ptr; L : not null SP_Node_Ptr); |
55 | -- Attach a subpool node to a pool | |
56 | ||
8777c5a6 AC |
57 | ----------------------------------- |
58 | -- Adjust_Controlled_Dereference -- | |
59 | ----------------------------------- | |
60 | ||
b0d71355 HK |
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) | |
65 | is | |
66 | Header_And_Padding : constant Storage_Offset := | |
67 | Header_Size_With_Padding (Alignment); | |
68 | begin | |
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. | |
71 | ||
72 | Addr := Addr - Header_And_Padding; | |
73 | ||
74 | -- Update the size of the object to include the two pointers | |
75 | ||
76 | Storage_Size := Storage_Size + Header_And_Padding; | |
77 | end Adjust_Controlled_Dereference; | |
78 | ||
d3f70b35 AC |
79 | -------------- |
80 | -- Allocate -- | |
81 | -------------- | |
82 | ||
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) | |
88 | is | |
89 | begin | |
d3f70b35 AC |
90 | -- Dispatch to the user-defined implementations of Allocate_From_Subpool |
91 | -- and Default_Subpool_For_Pool. | |
92 | ||
93 | Allocate_From_Subpool | |
94 | (Root_Storage_Pool_With_Subpools'Class (Pool), | |
95 | Storage_Address, | |
96 | Size_In_Storage_Elements, | |
97 | Alignment, | |
98 | Default_Subpool_For_Pool | |
99 | (Root_Storage_Pool_With_Subpools'Class (Pool))); | |
100 | end Allocate; | |
101 | ||
102 | ----------------------------- | |
103 | -- Allocate_Any_Controlled -- | |
104 | ----------------------------- | |
105 | ||
106 | procedure Allocate_Any_Controlled | |
107 | (Pool : in out Root_Storage_Pool'Class; | |
ca5af305 AC |
108 | Context_Subpool : Subpool_Handle; |
109 | Context_Master : Finalization_Masters.Finalization_Master_Ptr; | |
110 | Fin_Address : Finalization_Masters.Finalize_Address_Ptr; | |
d3f70b35 AC |
111 | Addr : out System.Address; |
112 | Storage_Size : System.Storage_Elements.Storage_Count; | |
113 | Alignment : System.Storage_Elements.Storage_Count; | |
ca5af305 AC |
114 | Is_Controlled : Boolean; |
115 | On_Subpool : Boolean) | |
d3f70b35 | 116 | is |
d3f70b35 | 117 | Is_Subpool_Allocation : constant Boolean := |
d3cb4cc0 | 118 | Pool in Root_Storage_Pool_With_Subpools'Class; |
d3f70b35 AC |
119 | |
120 | Master : Finalization_Master_Ptr := null; | |
121 | N_Addr : Address; | |
122 | N_Ptr : FM_Node_Ptr; | |
123 | N_Size : Storage_Count; | |
124 | Subpool : Subpool_Handle := null; | |
125 | ||
d3cb4cc0 AC |
126 | Header_And_Padding : Storage_Offset; |
127 | -- This offset includes the size of a FM_Node plus any additional | |
128 | -- padding due to a larger alignment. | |
129 | ||
d3f70b35 AC |
130 | begin |
131 | -- Step 1: Pool-related runtime checks | |
132 | ||
133 | -- Allocation on a pool_with_subpools. In this scenario there is a | |
ca5af305 | 134 | -- master for each subpool. The master of the access type is ignored. |
d3f70b35 AC |
135 | |
136 | if Is_Subpool_Allocation then | |
137 | ||
138 | -- Case of an allocation without a Subpool_Handle. Dispatch to the | |
139 | -- implementation of Default_Subpool_For_Pool. | |
140 | ||
141 | if Context_Subpool = null then | |
142 | Subpool := | |
143 | Default_Subpool_For_Pool | |
144 | (Root_Storage_Pool_With_Subpools'Class (Pool)); | |
145 | ||
d3f70b35 AC |
146 | -- Allocation with a Subpool_Handle |
147 | ||
148 | else | |
149 | Subpool := Context_Subpool; | |
ca5af305 | 150 | end if; |
d3f70b35 | 151 | |
ca5af305 | 152 | -- Ensure proper ownership and chaining of the subpool |
d3f70b35 | 153 | |
ca5af305 AC |
154 | if Subpool.Owner /= |
155 | Root_Storage_Pool_With_Subpools'Class (Pool)'Unchecked_Access | |
156 | or else Subpool.Node = null | |
157 | or else Subpool.Node.Prev = null | |
158 | or else Subpool.Node.Next = null | |
159 | then | |
160 | raise Program_Error with "incorrect owner of subpool"; | |
d3f70b35 AC |
161 | end if; |
162 | ||
163 | Master := Subpool.Master'Unchecked_Access; | |
164 | ||
165 | -- Allocation on a simple pool. In this scenario there is a master for | |
166 | -- each access-to-controlled type. No context subpool should be present. | |
167 | ||
168 | else | |
d3f70b35 | 169 | -- If the master is missing, then the expansion of the access type |
1e60643a | 170 | -- failed to create one. This is a compiler bug. |
d3f70b35 | 171 | |
1e60643a AC |
172 | pragma Assert |
173 | (Context_Master /= null, "missing master in pool allocation"); | |
d3f70b35 AC |
174 | |
175 | -- If a subpool is present, then this is the result of erroneous | |
176 | -- allocator expansion. This is not a serious error, but it should | |
177 | -- still be detected. | |
178 | ||
1e60643a | 179 | if Context_Subpool /= null then |
86f0e17a AC |
180 | raise Program_Error |
181 | with "subpool not required in pool allocation"; | |
1e60643a | 182 | end if; |
d3f70b35 | 183 | |
ca5af305 AC |
184 | -- If the allocation is intended to be on a subpool, but the access |
185 | -- type's pool does not support subpools, then this is the result of | |
1e60643a | 186 | -- incorrect end-user code. |
ca5af305 | 187 | |
1e60643a | 188 | if On_Subpool then |
ca5af305 AC |
189 | raise Program_Error |
190 | with "pool of access type does not support subpools"; | |
191 | end if; | |
192 | ||
d3f70b35 AC |
193 | Master := Context_Master; |
194 | end if; | |
195 | ||
14f0f659 | 196 | -- Step 2: Master, Finalize_Address-related runtime checks and size |
ca5af305 | 197 | -- calculations. |
d3f70b35 AC |
198 | |
199 | -- Allocation of a descendant from [Limited_]Controlled, a class-wide | |
200 | -- object or a record with controlled components. | |
201 | ||
202 | if Is_Controlled then | |
203 | ||
86f0e17a AC |
204 | -- Synchronization: |
205 | -- Read - allocation, finalization | |
206 | -- Write - finalization | |
207 | ||
208 | Lock_Task.all; | |
86f0e17a | 209 | |
d3f70b35 AC |
210 | -- Do not allow the allocation of controlled objects while the |
211 | -- associated master is being finalized. | |
212 | ||
1e60643a | 213 | if Finalization_Started (Master.all) then |
d3f70b35 AC |
214 | raise Program_Error with "allocation after finalization started"; |
215 | end if; | |
216 | ||
ca5af305 AC |
217 | -- Check whether primitive Finalize_Address is available. If it is |
218 | -- not, then either the expansion of the designated type failed or | |
1e60643a | 219 | -- the expansion of the allocator failed. This is a compiler bug. |
ca5af305 | 220 | |
1e60643a AC |
221 | pragma Assert |
222 | (Fin_Address /= null, "primitive Finalize_Address not available"); | |
ca5af305 | 223 | |
5764ee3c | 224 | -- The size must account for the hidden header preceding the object. |
d3cb4cc0 AC |
225 | -- Account for possible padding space before the header due to a |
226 | -- larger alignment. | |
227 | ||
ca20a08e | 228 | Header_And_Padding := Header_Size_With_Padding (Alignment); |
d3f70b35 | 229 | |
d3cb4cc0 | 230 | N_Size := Storage_Size + Header_And_Padding; |
d3f70b35 AC |
231 | |
232 | -- Non-controlled allocation | |
233 | ||
234 | else | |
235 | N_Size := Storage_Size; | |
236 | end if; | |
237 | ||
238 | -- Step 3: Allocation of object | |
239 | ||
240 | -- For descendants of Root_Storage_Pool_With_Subpools, dispatch to the | |
241 | -- implementation of Allocate_From_Subpool. | |
242 | ||
243 | if Is_Subpool_Allocation then | |
244 | Allocate_From_Subpool | |
245 | (Root_Storage_Pool_With_Subpools'Class (Pool), | |
246 | N_Addr, N_Size, Alignment, Subpool); | |
247 | ||
248 | -- For descendants of Root_Storage_Pool, dispatch to the implementation | |
249 | -- of Allocate. | |
250 | ||
251 | else | |
252 | Allocate (Pool, N_Addr, N_Size, Alignment); | |
253 | end if; | |
254 | ||
255 | -- Step 4: Attachment | |
256 | ||
257 | if Is_Controlled then | |
558fbeb0 HK |
258 | |
259 | -- Note that we already did "Lock_Task.all;" in Step 2 above | |
d3f70b35 AC |
260 | |
261 | -- Map the allocated memory into a FM_Node record. This converts the | |
d3cb4cc0 AC |
262 | -- top of the allocated bits into a list header. If there is padding |
263 | -- due to larger alignment, the header is placed right next to the | |
264 | -- object: | |
265 | ||
ca5af305 AC |
266 | -- N_Addr N_Ptr |
267 | -- | | | |
268 | -- V V | |
269 | -- +-------+---------------+----------------------+ | |
270 | -- |Padding| Header | Object | | |
271 | -- +-------+---------------+----------------------+ | |
272 | -- ^ ^ ^ | |
273 | -- | +- Header_Size -+ | |
274 | -- | | | |
275 | -- +- Header_And_Padding --+ | |
d3cb4cc0 | 276 | |
558fbeb0 HK |
277 | N_Ptr := |
278 | Address_To_FM_Node_Ptr (N_Addr + Header_And_Padding - Header_Size); | |
d3f70b35 | 279 | |
d3f70b35 AC |
280 | -- Prepend the allocated object to the finalization master |
281 | ||
86f0e17a AC |
282 | -- Synchronization: |
283 | -- Write - allocation, deallocation, finalization | |
284 | ||
285 | Attach_Unprotected (N_Ptr, Objects (Master.all)); | |
3a613a36 | 286 | |
d3f70b35 AC |
287 | -- Move the address from the hidden list header to the start of the |
288 | -- object. This operation effectively hides the list header. | |
289 | ||
d3cb4cc0 | 290 | Addr := N_Addr + Header_And_Padding; |
7134062a | 291 | |
3647ca26 | 292 | -- Homogeneous masters service the following: |
996c8821 | 293 | |
3647ca26 HK |
294 | -- 1) Allocations on / Deallocations from regular pools |
295 | -- 2) Named access types | |
296 | -- 3) Most cases of anonymous access types usage | |
14f0f659 | 297 | |
86f0e17a AC |
298 | -- Synchronization: |
299 | -- Read - allocation, finalization | |
300 | -- Write - outside | |
301 | ||
3647ca26 | 302 | if Master.Is_Homogeneous then |
86f0e17a AC |
303 | |
304 | -- Synchronization: | |
305 | -- Read - finalization | |
306 | -- Write - allocation, outside | |
307 | ||
308 | Set_Finalize_Address_Unprotected (Master.all, Fin_Address); | |
3647ca26 HK |
309 | |
310 | -- Heterogeneous masters service the following: | |
996c8821 | 311 | |
3647ca26 HK |
312 | -- 1) Allocations on / Deallocations from subpools |
313 | -- 2) Certain cases of anonymous access types usage | |
314 | ||
315 | else | |
86f0e17a AC |
316 | -- Synchronization: |
317 | -- Read - finalization | |
318 | -- Write - allocation, deallocation | |
319 | ||
320 | Set_Heterogeneous_Finalize_Address_Unprotected (Addr, Fin_Address); | |
3647ca26 | 321 | Finalize_Address_Table_In_Use := True; |
14f0f659 AC |
322 | end if; |
323 | ||
86f0e17a AC |
324 | Unlock_Task.all; |
325 | ||
14f0f659 AC |
326 | -- Non-controlled allocation |
327 | ||
d3f70b35 AC |
328 | else |
329 | Addr := N_Addr; | |
330 | end if; | |
1e60643a AC |
331 | |
332 | exception | |
333 | when others => | |
558fbeb0 HK |
334 | |
335 | -- Unlock the task in case the allocation step failed and reraise the | |
336 | -- exception. | |
1e60643a AC |
337 | |
338 | if Is_Controlled then | |
339 | Unlock_Task.all; | |
340 | end if; | |
341 | ||
342 | raise; | |
d3f70b35 AC |
343 | end Allocate_Any_Controlled; |
344 | ||
345 | ------------ | |
346 | -- Attach -- | |
347 | ------------ | |
348 | ||
349 | procedure Attach (N : not null SP_Node_Ptr; L : not null SP_Node_Ptr) is | |
350 | begin | |
ca5af305 AC |
351 | -- Ensure that the node has not been attached already |
352 | ||
353 | pragma Assert (N.Prev = null and then N.Next = null); | |
354 | ||
d3f70b35 AC |
355 | Lock_Task.all; |
356 | ||
357 | L.Next.Prev := N; | |
358 | N.Next := L.Next; | |
359 | L.Next := N; | |
360 | N.Prev := L; | |
361 | ||
362 | Unlock_Task.all; | |
363 | ||
364 | -- Note: No need to unlock in case of an exception because the above | |
365 | -- code can never raise one. | |
366 | end Attach; | |
367 | ||
368 | ------------------------------- | |
369 | -- Deallocate_Any_Controlled -- | |
370 | ------------------------------- | |
371 | ||
372 | procedure Deallocate_Any_Controlled | |
373 | (Pool : in out Root_Storage_Pool'Class; | |
374 | Addr : System.Address; | |
375 | Storage_Size : System.Storage_Elements.Storage_Count; | |
376 | Alignment : System.Storage_Elements.Storage_Count; | |
ca5af305 | 377 | Is_Controlled : Boolean) |
d3f70b35 AC |
378 | is |
379 | N_Addr : Address; | |
380 | N_Ptr : FM_Node_Ptr; | |
381 | N_Size : Storage_Count; | |
382 | ||
d3cb4cc0 AC |
383 | Header_And_Padding : Storage_Offset; |
384 | -- This offset includes the size of a FM_Node plus any additional | |
385 | -- padding due to a larger alignment. | |
386 | ||
d3f70b35 AC |
387 | begin |
388 | -- Step 1: Detachment | |
389 | ||
390 | if Is_Controlled then | |
86f0e17a | 391 | Lock_Task.all; |
e9c9d122 | 392 | |
1e60643a AC |
393 | begin |
394 | -- Destroy the relation pair object - Finalize_Address since it is | |
395 | -- no longer needed. | |
14f0f659 | 396 | |
1e60643a | 397 | if Finalize_Address_Table_In_Use then |
86f0e17a | 398 | |
1e60643a AC |
399 | -- Synchronization: |
400 | -- Read - finalization | |
401 | -- Write - allocation, deallocation | |
86f0e17a | 402 | |
1e60643a AC |
403 | Delete_Finalize_Address_Unprotected (Addr); |
404 | end if; | |
14f0f659 | 405 | |
1e60643a AC |
406 | -- Account for possible padding space before the header due to a |
407 | -- larger alignment. | |
e9c9d122 | 408 | |
1e60643a | 409 | Header_And_Padding := Header_Size_With_Padding (Alignment); |
d3f70b35 | 410 | |
1e60643a AC |
411 | -- N_Addr N_Ptr Addr (from input) |
412 | -- | | | | |
413 | -- V V V | |
414 | -- +-------+---------------+----------------------+ | |
415 | -- |Padding| Header | Object | | |
416 | -- +-------+---------------+----------------------+ | |
417 | -- ^ ^ ^ | |
418 | -- | +- Header_Size -+ | |
419 | -- | | | |
420 | -- +- Header_And_Padding --+ | |
d3f70b35 | 421 | |
1e60643a | 422 | -- Convert the bits preceding the object into a list header |
d3f70b35 | 423 | |
1e60643a | 424 | N_Ptr := Address_To_FM_Node_Ptr (Addr - Header_Size); |
d3f70b35 | 425 | |
1e60643a AC |
426 | -- Detach the object from the related finalization master. This |
427 | -- action does not need to know the prior context used during | |
428 | -- allocation. | |
d3f70b35 | 429 | |
1e60643a AC |
430 | -- Synchronization: |
431 | -- Write - allocation, deallocation, finalization | |
86f0e17a | 432 | |
1e60643a | 433 | Detach_Unprotected (N_Ptr); |
d3f70b35 | 434 | |
1e60643a AC |
435 | -- Move the address from the object to the beginning of the list |
436 | -- header. | |
d3cb4cc0 | 437 | |
1e60643a | 438 | N_Addr := Addr - Header_And_Padding; |
d3cb4cc0 | 439 | |
1e60643a AC |
440 | -- The size of the deallocated object must include the size of the |
441 | -- hidden list header. | |
d3f70b35 | 442 | |
1e60643a | 443 | N_Size := Storage_Size + Header_And_Padding; |
7134062a | 444 | |
1e60643a AC |
445 | Unlock_Task.all; |
446 | ||
447 | exception | |
448 | when others => | |
558fbeb0 HK |
449 | |
450 | -- Unlock the task in case the computations performed above | |
451 | -- fail for some reason. | |
86f0e17a | 452 | |
1e60643a AC |
453 | Unlock_Task.all; |
454 | raise; | |
455 | end; | |
d3f70b35 AC |
456 | else |
457 | N_Addr := Addr; | |
458 | N_Size := Storage_Size; | |
459 | end if; | |
460 | ||
461 | -- Step 2: Deallocation | |
462 | ||
463 | -- Dispatch to the proper implementation of Deallocate. This action | |
464 | -- covers both Root_Storage_Pool and Root_Storage_Pool_With_Subpools | |
465 | -- implementations. | |
466 | ||
467 | Deallocate (Pool, N_Addr, N_Size, Alignment); | |
468 | end Deallocate_Any_Controlled; | |
469 | ||
7b2aafc9 HK |
470 | ------------------------------ |
471 | -- Default_Subpool_For_Pool -- | |
472 | ------------------------------ | |
473 | ||
474 | function Default_Subpool_For_Pool | |
50ea6357 AC |
475 | (Pool : in out Root_Storage_Pool_With_Subpools) |
476 | return not null Subpool_Handle | |
7b2aafc9 | 477 | is |
50ea6357 | 478 | pragma Unreferenced (Pool); |
7b2aafc9 | 479 | begin |
50ea6357 AC |
480 | return raise Program_Error with |
481 | "default Default_Subpool_For_Pool called; must be overridden"; | |
7b2aafc9 HK |
482 | end Default_Subpool_For_Pool; |
483 | ||
d3f70b35 AC |
484 | ------------ |
485 | -- Detach -- | |
486 | ------------ | |
487 | ||
488 | procedure Detach (N : not null SP_Node_Ptr) is | |
489 | begin | |
ca5af305 | 490 | -- Ensure that the node is attached to some list |
d3f70b35 AC |
491 | |
492 | pragma Assert (N.Next /= null and then N.Prev /= null); | |
493 | ||
494 | Lock_Task.all; | |
495 | ||
496 | N.Prev.Next := N.Next; | |
497 | N.Next.Prev := N.Prev; | |
14f0f659 AC |
498 | N.Prev := null; |
499 | N.Next := null; | |
d3f70b35 AC |
500 | |
501 | Unlock_Task.all; | |
502 | ||
503 | -- Note: No need to unlock in case of an exception because the above | |
504 | -- code can never raise one. | |
505 | end Detach; | |
506 | ||
507 | -------------- | |
508 | -- Finalize -- | |
509 | -------------- | |
510 | ||
ca5af305 AC |
511 | overriding procedure Finalize (Controller : in out Pool_Controller) is |
512 | begin | |
513 | Finalize_Pool (Controller.Enclosing_Pool.all); | |
514 | end Finalize; | |
515 | ||
516 | ------------------- | |
517 | -- Finalize_Pool -- | |
518 | ------------------- | |
519 | ||
520 | procedure Finalize_Pool (Pool : in out Root_Storage_Pool_With_Subpools) is | |
d3f70b35 AC |
521 | Curr_Ptr : SP_Node_Ptr; |
522 | Ex_Occur : Exception_Occurrence; | |
d3f70b35 AC |
523 | Raised : Boolean := False; |
524 | ||
14f0f659 AC |
525 | function Is_Empty_List (L : not null SP_Node_Ptr) return Boolean; |
526 | -- Determine whether a list contains only one element, the dummy head | |
527 | ||
528 | ------------------- | |
529 | -- Is_Empty_List -- | |
530 | ------------------- | |
531 | ||
532 | function Is_Empty_List (L : not null SP_Node_Ptr) return Boolean is | |
533 | begin | |
534 | return L.Next = L and then L.Prev = L; | |
535 | end Is_Empty_List; | |
536 | ||
537 | -- Start of processing for Finalize_Pool | |
538 | ||
d3f70b35 | 539 | begin |
d3f70b35 AC |
540 | -- It is possible for multiple tasks to cause the finalization of a |
541 | -- common pool. Allow only one task to finalize the contents. | |
542 | ||
543 | if Pool.Finalization_Started then | |
544 | return; | |
545 | end if; | |
546 | ||
547 | -- Lock the pool to prevent the creation of additional subpools while | |
548 | -- the available ones are finalized. The pool remains locked because | |
549 | -- either it is about to be deallocated or the associated access type | |
550 | -- is about to go out of scope. | |
551 | ||
552 | Pool.Finalization_Started := True; | |
553 | ||
14f0f659 AC |
554 | while not Is_Empty_List (Pool.Subpools'Unchecked_Access) loop |
555 | Curr_Ptr := Pool.Subpools.Next; | |
d3f70b35 | 556 | |
ca5af305 | 557 | -- Perform the following actions: |
d3f70b35 | 558 | |
ca5af305 | 559 | -- 1) Finalize all objects chained on the subpool's master |
50ef946c | 560 | -- 2) Remove the subpool from the owner's list of subpools |
ca5af305 AC |
561 | -- 3) Deallocate the doubly linked list node associated with the |
562 | -- subpool. | |
5707e389 | 563 | -- 4) Call Deallocate_Subpool |
d3f70b35 AC |
564 | |
565 | begin | |
5707e389 | 566 | Finalize_And_Deallocate (Curr_Ptr.Subpool); |
d3f70b35 AC |
567 | |
568 | exception | |
569 | when Fin_Occur : others => | |
570 | if not Raised then | |
571 | Raised := True; | |
572 | Save_Occurrence (Ex_Occur, Fin_Occur); | |
573 | end if; | |
574 | end; | |
d3f70b35 AC |
575 | end loop; |
576 | ||
577 | -- If the finalization of a particular master failed, reraise the | |
578 | -- exception now. | |
579 | ||
580 | if Raised then | |
581 | Reraise_Occurrence (Ex_Occur); | |
582 | end if; | |
ca5af305 | 583 | end Finalize_Pool; |
d3f70b35 | 584 | |
ca20a08e AC |
585 | ------------------------------ |
586 | -- Header_Size_With_Padding -- | |
587 | ------------------------------ | |
588 | ||
589 | function Header_Size_With_Padding | |
590 | (Alignment : System.Storage_Elements.Storage_Count) | |
8a06151a | 591 | return System.Storage_Elements.Storage_Count |
ca20a08e AC |
592 | is |
593 | Size : constant Storage_Count := Header_Size; | |
594 | ||
595 | begin | |
596 | if Size mod Alignment = 0 then | |
597 | return Size; | |
598 | ||
599 | -- Add enough padding to reach the nearest multiple of the alignment | |
600 | -- rounding up. | |
601 | ||
602 | else | |
603 | return ((Size + Alignment - 1) / Alignment) * Alignment; | |
604 | end if; | |
605 | end Header_Size_With_Padding; | |
606 | ||
ca5af305 AC |
607 | ---------------- |
608 | -- Initialize -- | |
609 | ---------------- | |
610 | ||
611 | overriding procedure Initialize (Controller : in out Pool_Controller) is | |
612 | begin | |
613 | Initialize_Pool (Controller.Enclosing_Pool.all); | |
614 | end Initialize; | |
615 | ||
616 | --------------------- | |
617 | -- Initialize_Pool -- | |
618 | --------------------- | |
619 | ||
620 | procedure Initialize_Pool (Pool : in out Root_Storage_Pool_With_Subpools) is | |
621 | begin | |
622 | -- The dummy head must point to itself in both directions | |
623 | ||
624 | Pool.Subpools.Next := Pool.Subpools'Unchecked_Access; | |
625 | Pool.Subpools.Prev := Pool.Subpools'Unchecked_Access; | |
626 | end Initialize_Pool; | |
627 | ||
d3f70b35 AC |
628 | --------------------- |
629 | -- Pool_Of_Subpool -- | |
630 | --------------------- | |
631 | ||
54c04d6c AC |
632 | function Pool_Of_Subpool |
633 | (Subpool : not null Subpool_Handle) | |
634 | return access Root_Storage_Pool_With_Subpools'Class | |
7b2aafc9 | 635 | is |
d3f70b35 AC |
636 | begin |
637 | return Subpool.Owner; | |
638 | end Pool_Of_Subpool; | |
639 | ||
14f0f659 AC |
640 | ---------------- |
641 | -- Print_Pool -- | |
642 | ---------------- | |
643 | ||
644 | procedure Print_Pool (Pool : Root_Storage_Pool_With_Subpools) is | |
645 | Head : constant SP_Node_Ptr := Pool.Subpools'Unrestricted_Access; | |
646 | Head_Seen : Boolean := False; | |
647 | SP_Ptr : SP_Node_Ptr; | |
648 | ||
649 | begin | |
650 | -- Output the contents of the pool | |
651 | ||
652 | -- Pool : 0x123456789 | |
653 | -- Subpools : 0x123456789 | |
654 | -- Fin_Start : TRUE <or> FALSE | |
655 | -- Controller: OK <or> NOK | |
656 | ||
657 | Put ("Pool : "); | |
658 | Put_Line (Address_Image (Pool'Address)); | |
659 | ||
660 | Put ("Subpools : "); | |
661 | Put_Line (Address_Image (Pool.Subpools'Address)); | |
662 | ||
663 | Put ("Fin_Start : "); | |
664 | Put_Line (Pool.Finalization_Started'Img); | |
665 | ||
666 | Put ("Controlled: "); | |
667 | if Pool.Controller.Enclosing_Pool = Pool'Unrestricted_Access then | |
668 | Put_Line ("OK"); | |
669 | else | |
670 | Put_Line ("NOK (ERROR)"); | |
671 | end if; | |
672 | ||
673 | SP_Ptr := Head; | |
674 | while SP_Ptr /= null loop -- Should never be null | |
675 | Put_Line ("V"); | |
676 | ||
677 | -- We see the head initially; we want to exit when we see the head a | |
678 | -- second time. | |
679 | ||
680 | if SP_Ptr = Head then | |
681 | exit when Head_Seen; | |
682 | ||
683 | Head_Seen := True; | |
684 | end if; | |
685 | ||
686 | -- The current element is null. This should never happend since the | |
687 | -- list is circular. | |
688 | ||
689 | if SP_Ptr.Prev = null then | |
690 | Put_Line ("null (ERROR)"); | |
691 | ||
692 | -- The current element points back to the correct element | |
693 | ||
694 | elsif SP_Ptr.Prev.Next = SP_Ptr then | |
695 | Put_Line ("^"); | |
696 | ||
697 | -- The current element points to an erroneous element | |
698 | ||
699 | else | |
700 | Put_Line ("? (ERROR)"); | |
701 | end if; | |
702 | ||
703 | -- Output the contents of the node | |
704 | ||
705 | Put ("|Header: "); | |
706 | Put (Address_Image (SP_Ptr.all'Address)); | |
707 | if SP_Ptr = Head then | |
708 | Put_Line (" (dummy head)"); | |
709 | else | |
710 | Put_Line (""); | |
711 | end if; | |
712 | ||
713 | Put ("| Prev: "); | |
714 | ||
715 | if SP_Ptr.Prev = null then | |
716 | Put_Line ("null"); | |
717 | else | |
718 | Put_Line (Address_Image (SP_Ptr.Prev.all'Address)); | |
719 | end if; | |
720 | ||
721 | Put ("| Next: "); | |
722 | ||
723 | if SP_Ptr.Next = null then | |
724 | Put_Line ("null"); | |
725 | else | |
726 | Put_Line (Address_Image (SP_Ptr.Next.all'Address)); | |
727 | end if; | |
728 | ||
729 | Put ("| Subp: "); | |
730 | ||
731 | if SP_Ptr.Subpool = null then | |
732 | Put_Line ("null"); | |
733 | else | |
734 | Put_Line (Address_Image (SP_Ptr.Subpool.all'Address)); | |
735 | end if; | |
736 | ||
737 | SP_Ptr := SP_Ptr.Next; | |
738 | end loop; | |
739 | end Print_Pool; | |
740 | ||
741 | ------------------- | |
742 | -- Print_Subpool -- | |
743 | ------------------- | |
744 | ||
745 | procedure Print_Subpool (Subpool : Subpool_Handle) is | |
746 | begin | |
747 | if Subpool = null then | |
748 | Put_Line ("null"); | |
749 | return; | |
750 | end if; | |
751 | ||
752 | -- Output the contents of a subpool | |
753 | ||
754 | -- Owner : 0x123456789 | |
755 | -- Master: 0x123456789 | |
756 | -- Node : 0x123456789 | |
757 | ||
758 | Put ("Owner : "); | |
759 | if Subpool.Owner = null then | |
760 | Put_Line ("null"); | |
761 | else | |
762 | Put_Line (Address_Image (Subpool.Owner'Address)); | |
763 | end if; | |
764 | ||
765 | Put ("Master: "); | |
766 | Put_Line (Address_Image (Subpool.Master'Address)); | |
767 | ||
768 | Put ("Node : "); | |
769 | if Subpool.Node = null then | |
770 | Put ("null"); | |
771 | ||
772 | if Subpool.Owner = null then | |
773 | Put_Line (" OK"); | |
774 | else | |
775 | Put_Line (" (ERROR)"); | |
776 | end if; | |
777 | else | |
778 | Put_Line (Address_Image (Subpool.Node'Address)); | |
779 | end if; | |
780 | ||
781 | Print_Master (Subpool.Master); | |
782 | end Print_Subpool; | |
783 | ||
d3f70b35 AC |
784 | ------------------------- |
785 | -- Set_Pool_Of_Subpool -- | |
786 | ------------------------- | |
787 | ||
788 | procedure Set_Pool_Of_Subpool | |
789 | (Subpool : not null Subpool_Handle; | |
7b2aafc9 | 790 | To : in out Root_Storage_Pool_With_Subpools'Class) |
d3f70b35 AC |
791 | is |
792 | N_Ptr : SP_Node_Ptr; | |
793 | ||
794 | begin | |
d3f70b35 AC |
795 | -- If the subpool is already owned, raise Program_Error. This is a |
796 | -- direct violation of the RM rules. | |
797 | ||
798 | if Subpool.Owner /= null then | |
799 | raise Program_Error with "subpool already belongs to a pool"; | |
800 | end if; | |
801 | ||
802 | -- Prevent the creation of a new subpool while the owner is being | |
803 | -- finalized. This is a serious error. | |
804 | ||
7b2aafc9 | 805 | if To.Finalization_Started then |
d3f70b35 AC |
806 | raise Program_Error |
807 | with "subpool creation after finalization started"; | |
808 | end if; | |
809 | ||
7b2aafc9 | 810 | Subpool.Owner := To'Unchecked_Access; |
d3f70b35 | 811 | |
ca5af305 AC |
812 | -- Create a subpool node and decorate it. Since this node is not |
813 | -- allocated on the owner's pool, it must be explicitly destroyed by | |
814 | -- Finalize_And_Detach. | |
d3f70b35 | 815 | |
ca5af305 | 816 | N_Ptr := new SP_Node; |
d3f70b35 | 817 | N_Ptr.Subpool := Subpool; |
ca5af305 | 818 | Subpool.Node := N_Ptr; |
d3f70b35 | 819 | |
7b2aafc9 | 820 | Attach (N_Ptr, To.Subpools'Unchecked_Access); |
14f0f659 AC |
821 | |
822 | -- Mark the subpool's master as being a heterogeneous collection of | |
823 | -- controlled objects. | |
824 | ||
825 | Set_Is_Heterogeneous (Subpool.Master); | |
d3f70b35 AC |
826 | end Set_Pool_Of_Subpool; |
827 | ||
828 | end System.Storage_Pools.Subpools; |