|
111
|
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 -- --
|
|
|
9 -- Copyright (C) 2011-2017, Free Software Foundation, Inc. --
|
|
|
10 -- --
|
|
|
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
|
|
|
32 with Ada.Exceptions; use Ada.Exceptions;
|
|
|
33 with Ada.Unchecked_Conversion;
|
|
|
34
|
|
|
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;
|
|
|
40
|
|
|
41 with System.Storage_Pools.Subpools.Finalization;
|
|
|
42 use System.Storage_Pools.Subpools.Finalization;
|
|
|
43
|
|
|
44 package body System.Storage_Pools.Subpools is
|
|
|
45
|
|
|
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.
|
|
|
50
|
|
|
51 function Address_To_FM_Node_Ptr is
|
|
|
52 new Ada.Unchecked_Conversion (Address, FM_Node_Ptr);
|
|
|
53
|
|
|
54 procedure Attach (N : not null SP_Node_Ptr; L : not null SP_Node_Ptr);
|
|
|
55 -- Attach a subpool node to a pool
|
|
|
56
|
|
|
57 -----------------------------------
|
|
|
58 -- Adjust_Controlled_Dereference --
|
|
|
59 -----------------------------------
|
|
|
60
|
|
|
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
|
|
|
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
|
|
|
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;
|
|
|
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)
|
|
|
116 is
|
|
|
117 Is_Subpool_Allocation : constant Boolean :=
|
|
|
118 Pool in Root_Storage_Pool_With_Subpools'Class;
|
|
|
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
|
|
|
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
|
|
|
130 begin
|
|
|
131 -- Step 1: Pool-related runtime checks
|
|
|
132
|
|
|
133 -- Allocation on a pool_with_subpools. In this scenario there is a
|
|
|
134 -- master for each subpool. The master of the access type is ignored.
|
|
|
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
|
|
|
146 -- Allocation with a Subpool_Handle
|
|
|
147
|
|
|
148 else
|
|
|
149 Subpool := Context_Subpool;
|
|
|
150 end if;
|
|
|
151
|
|
|
152 -- Ensure proper ownership and chaining of the subpool
|
|
|
153
|
|
|
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";
|
|
|
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
|
|
|
169 -- If the master is missing, then the expansion of the access type
|
|
|
170 -- failed to create one. This is a compiler bug.
|
|
|
171
|
|
|
172 pragma Assert
|
|
|
173 (Context_Master /= null, "missing master in pool allocation");
|
|
|
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
|
|
|
179 if Context_Subpool /= null then
|
|
|
180 raise Program_Error
|
|
|
181 with "subpool not required in pool allocation";
|
|
|
182 end if;
|
|
|
183
|
|
|
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
|
|
|
186 -- incorrect end-user code.
|
|
|
187
|
|
|
188 if On_Subpool then
|
|
|
189 raise Program_Error
|
|
|
190 with "pool of access type does not support subpools";
|
|
|
191 end if;
|
|
|
192
|
|
|
193 Master := Context_Master;
|
|
|
194 end if;
|
|
|
195
|
|
|
196 -- Step 2: Master, Finalize_Address-related runtime checks and size
|
|
|
197 -- calculations.
|
|
|
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
|
|
|
204 -- Synchronization:
|
|
|
205 -- Read - allocation, finalization
|
|
|
206 -- Write - finalization
|
|
|
207
|
|
|
208 Lock_Task.all;
|
|
|
209
|
|
|
210 -- Do not allow the allocation of controlled objects while the
|
|
|
211 -- associated master is being finalized.
|
|
|
212
|
|
|
213 if Finalization_Started (Master.all) then
|
|
|
214 raise Program_Error with "allocation after finalization started";
|
|
|
215 end if;
|
|
|
216
|
|
|
217 -- Check whether primitive Finalize_Address is available. If it is
|
|
|
218 -- not, then either the expansion of the designated type failed or
|
|
|
219 -- the expansion of the allocator failed. This is a compiler bug.
|
|
|
220
|
|
|
221 pragma Assert
|
|
|
222 (Fin_Address /= null, "primitive Finalize_Address not available");
|
|
|
223
|
|
|
224 -- The size must account for the hidden header preceding the object.
|
|
|
225 -- Account for possible padding space before the header due to a
|
|
|
226 -- larger alignment.
|
|
|
227
|
|
|
228 Header_And_Padding := Header_Size_With_Padding (Alignment);
|
|
|
229
|
|
|
230 N_Size := Storage_Size + Header_And_Padding;
|
|
|
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
|
|
|
258
|
|
|
259 -- Note that we already did "Lock_Task.all;" in Step 2 above
|
|
|
260
|
|
|
261 -- Map the allocated memory into a FM_Node record. This converts the
|
|
|
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
|
|
|
266 -- N_Addr N_Ptr
|
|
|
267 -- | |
|
|
|
268 -- V V
|
|
|
269 -- +-------+---------------+----------------------+
|
|
|
270 -- |Padding| Header | Object |
|
|
|
271 -- +-------+---------------+----------------------+
|
|
|
272 -- ^ ^ ^
|
|
|
273 -- | +- Header_Size -+
|
|
|
274 -- | |
|
|
|
275 -- +- Header_And_Padding --+
|
|
|
276
|
|
|
277 N_Ptr :=
|
|
|
278 Address_To_FM_Node_Ptr (N_Addr + Header_And_Padding - Header_Size);
|
|
|
279
|
|
|
280 -- Prepend the allocated object to the finalization master
|
|
|
281
|
|
|
282 -- Synchronization:
|
|
|
283 -- Write - allocation, deallocation, finalization
|
|
|
284
|
|
|
285 Attach_Unprotected (N_Ptr, Objects (Master.all));
|
|
|
286
|
|
|
287 -- Move the address from the hidden list header to the start of the
|
|
|
288 -- object. This operation effectively hides the list header.
|
|
|
289
|
|
|
290 Addr := N_Addr + Header_And_Padding;
|
|
|
291
|
|
|
292 -- Homogeneous masters service the following:
|
|
|
293
|
|
|
294 -- 1) Allocations on / Deallocations from regular pools
|
|
|
295 -- 2) Named access types
|
|
|
296 -- 3) Most cases of anonymous access types usage
|
|
|
297
|
|
|
298 -- Synchronization:
|
|
|
299 -- Read - allocation, finalization
|
|
|
300 -- Write - outside
|
|
|
301
|
|
|
302 if Master.Is_Homogeneous then
|
|
|
303
|
|
|
304 -- Synchronization:
|
|
|
305 -- Read - finalization
|
|
|
306 -- Write - allocation, outside
|
|
|
307
|
|
|
308 Set_Finalize_Address_Unprotected (Master.all, Fin_Address);
|
|
|
309
|
|
|
310 -- Heterogeneous masters service the following:
|
|
|
311
|
|
|
312 -- 1) Allocations on / Deallocations from subpools
|
|
|
313 -- 2) Certain cases of anonymous access types usage
|
|
|
314
|
|
|
315 else
|
|
|
316 -- Synchronization:
|
|
|
317 -- Read - finalization
|
|
|
318 -- Write - allocation, deallocation
|
|
|
319
|
|
|
320 Set_Heterogeneous_Finalize_Address_Unprotected (Addr, Fin_Address);
|
|
|
321 Finalize_Address_Table_In_Use := True;
|
|
|
322 end if;
|
|
|
323
|
|
|
324 Unlock_Task.all;
|
|
|
325
|
|
|
326 -- Non-controlled allocation
|
|
|
327
|
|
|
328 else
|
|
|
329 Addr := N_Addr;
|
|
|
330 end if;
|
|
|
331
|
|
|
332 exception
|
|
|
333 when others =>
|
|
|
334
|
|
|
335 -- Unlock the task in case the allocation step failed and reraise the
|
|
|
336 -- exception.
|
|
|
337
|
|
|
338 if Is_Controlled then
|
|
|
339 Unlock_Task.all;
|
|
|
340 end if;
|
|
|
341
|
|
|
342 raise;
|
|
|
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
|
|
|
351 -- Ensure that the node has not been attached already
|
|
|
352
|
|
|
353 pragma Assert (N.Prev = null and then N.Next = null);
|
|
|
354
|
|
|
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;
|
|
|
377 Is_Controlled : Boolean)
|
|
|
378 is
|
|
|
379 N_Addr : Address;
|
|
|
380 N_Ptr : FM_Node_Ptr;
|
|
|
381 N_Size : Storage_Count;
|
|
|
382
|
|
|
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
|
|
|
387 begin
|
|
|
388 -- Step 1: Detachment
|
|
|
389
|
|
|
390 if Is_Controlled then
|
|
|
391 Lock_Task.all;
|
|
|
392
|
|
|
393 begin
|
|
|
394 -- Destroy the relation pair object - Finalize_Address since it is
|
|
|
395 -- no longer needed.
|
|
|
396
|
|
|
397 if Finalize_Address_Table_In_Use then
|
|
|
398
|
|
|
399 -- Synchronization:
|
|
|
400 -- Read - finalization
|
|
|
401 -- Write - allocation, deallocation
|
|
|
402
|
|
|
403 Delete_Finalize_Address_Unprotected (Addr);
|
|
|
404 end if;
|
|
|
405
|
|
|
406 -- Account for possible padding space before the header due to a
|
|
|
407 -- larger alignment.
|
|
|
408
|
|
|
409 Header_And_Padding := Header_Size_With_Padding (Alignment);
|
|
|
410
|
|
|
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 --+
|
|
|
421
|
|
|
422 -- Convert the bits preceding the object into a list header
|
|
|
423
|
|
|
424 N_Ptr := Address_To_FM_Node_Ptr (Addr - Header_Size);
|
|
|
425
|
|
|
426 -- Detach the object from the related finalization master. This
|
|
|
427 -- action does not need to know the prior context used during
|
|
|
428 -- allocation.
|
|
|
429
|
|
|
430 -- Synchronization:
|
|
|
431 -- Write - allocation, deallocation, finalization
|
|
|
432
|
|
|
433 Detach_Unprotected (N_Ptr);
|
|
|
434
|
|
|
435 -- Move the address from the object to the beginning of the list
|
|
|
436 -- header.
|
|
|
437
|
|
|
438 N_Addr := Addr - Header_And_Padding;
|
|
|
439
|
|
|
440 -- The size of the deallocated object must include the size of the
|
|
|
441 -- hidden list header.
|
|
|
442
|
|
|
443 N_Size := Storage_Size + Header_And_Padding;
|
|
|
444
|
|
|
445 Unlock_Task.all;
|
|
|
446
|
|
|
447 exception
|
|
|
448 when others =>
|
|
|
449
|
|
|
450 -- Unlock the task in case the computations performed above
|
|
|
451 -- fail for some reason.
|
|
|
452
|
|
|
453 Unlock_Task.all;
|
|
|
454 raise;
|
|
|
455 end;
|
|
|
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
|
|
|
470 ------------------------------
|
|
|
471 -- Default_Subpool_For_Pool --
|
|
|
472 ------------------------------
|
|
|
473
|
|
|
474 function Default_Subpool_For_Pool
|
|
|
475 (Pool : in out Root_Storage_Pool_With_Subpools)
|
|
|
476 return not null Subpool_Handle
|
|
|
477 is
|
|
|
478 pragma Unreferenced (Pool);
|
|
|
479 begin
|
|
|
480 return raise Program_Error with
|
|
|
481 "default Default_Subpool_For_Pool called; must be overridden";
|
|
|
482 end Default_Subpool_For_Pool;
|
|
|
483
|
|
|
484 ------------
|
|
|
485 -- Detach --
|
|
|
486 ------------
|
|
|
487
|
|
|
488 procedure Detach (N : not null SP_Node_Ptr) is
|
|
|
489 begin
|
|
|
490 -- Ensure that the node is attached to some list
|
|
|
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;
|
|
|
498 N.Prev := null;
|
|
|
499 N.Next := null;
|
|
|
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
|
|
|
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
|
|
|
521 Curr_Ptr : SP_Node_Ptr;
|
|
|
522 Ex_Occur : Exception_Occurrence;
|
|
|
523 Raised : Boolean := False;
|
|
|
524
|
|
|
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
|
|
|
539 begin
|
|
|
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
|
|
|
554 while not Is_Empty_List (Pool.Subpools'Unchecked_Access) loop
|
|
|
555 Curr_Ptr := Pool.Subpools.Next;
|
|
|
556
|
|
|
557 -- Perform the following actions:
|
|
|
558
|
|
|
559 -- 1) Finalize all objects chained on the subpool's master
|
|
|
560 -- 2) Remove the subpool from the owner's list of subpools
|
|
|
561 -- 3) Deallocate the doubly linked list node associated with the
|
|
|
562 -- subpool.
|
|
|
563 -- 4) Call Deallocate_Subpool
|
|
|
564
|
|
|
565 begin
|
|
|
566 Finalize_And_Deallocate (Curr_Ptr.Subpool);
|
|
|
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;
|
|
|
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;
|
|
|
583 end Finalize_Pool;
|
|
|
584
|
|
|
585 ------------------------------
|
|
|
586 -- Header_Size_With_Padding --
|
|
|
587 ------------------------------
|
|
|
588
|
|
|
589 function Header_Size_With_Padding
|
|
|
590 (Alignment : System.Storage_Elements.Storage_Count)
|
|
|
591 return System.Storage_Elements.Storage_Count
|
|
|
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
|
|
|
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
|
|
|
628 ---------------------
|
|
|
629 -- Pool_Of_Subpool --
|
|
|
630 ---------------------
|
|
|
631
|
|
|
632 function Pool_Of_Subpool
|
|
|
633 (Subpool : not null Subpool_Handle)
|
|
|
634 return access Root_Storage_Pool_With_Subpools'Class
|
|
|
635 is
|
|
|
636 begin
|
|
|
637 return Subpool.Owner;
|
|
|
638 end Pool_Of_Subpool;
|
|
|
639
|
|
|
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
|
|
|
784 -------------------------
|
|
|
785 -- Set_Pool_Of_Subpool --
|
|
|
786 -------------------------
|
|
|
787
|
|
|
788 procedure Set_Pool_Of_Subpool
|
|
|
789 (Subpool : not null Subpool_Handle;
|
|
|
790 To : in out Root_Storage_Pool_With_Subpools'Class)
|
|
|
791 is
|
|
|
792 N_Ptr : SP_Node_Ptr;
|
|
|
793
|
|
|
794 begin
|
|
|
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
|
|
|
805 if To.Finalization_Started then
|
|
|
806 raise Program_Error
|
|
|
807 with "subpool creation after finalization started";
|
|
|
808 end if;
|
|
|
809
|
|
|
810 Subpool.Owner := To'Unchecked_Access;
|
|
|
811
|
|
|
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.
|
|
|
815
|
|
|
816 N_Ptr := new SP_Node;
|
|
|
817 N_Ptr.Subpool := Subpool;
|
|
|
818 Subpool.Node := N_Ptr;
|
|
|
819
|
|
|
820 Attach (N_Ptr, To.Subpools'Unchecked_Access);
|
|
|
821
|
|
|
822 -- Mark the subpool's master as being a heterogeneous collection of
|
|
|
823 -- controlled objects.
|
|
|
824
|
|
|
825 Set_Is_Heterogeneous (Subpool.Master);
|
|
|
826 end Set_Pool_Of_Subpool;
|
|
|
827
|
|
|
828 end System.Storage_Pools.Subpools;
|
