File : s-finmas.adb
1 ------------------------------------------------------------------------------
2 -- --
3 -- GNAT COMPILER COMPONENTS --
4 -- --
5 -- S Y S T E M . F I N A L I Z A T I O N _ M A S T E R S --
6 -- --
7 -- B o d y --
8 -- --
9 -- Copyright (C) 2015, 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 -- --
19 -- --
20 -- --
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
34 with System.Address_Image;
35 with System.HTable; use System.HTable;
36 with System.IO; use System.IO;
37 with System.Soft_Links; use System.Soft_Links;
38 with System.Storage_Elements; use System.Storage_Elements;
39
40 package body System.Finalization_Masters is
41
42 -- Finalize_Address hash table types. In general, masters are homogeneous
43 -- collections of controlled objects. Rare cases such as allocations on a
44 -- subpool require heterogeneous masters. The following table provides a
45 -- relation between object address and its Finalize_Address routine.
46
47 type Header_Num is range 0 .. 127;
48
49 function Hash (Key : System.Address) return Header_Num;
50
51 -- Address --> Finalize_Address_Ptr
52
53 package Finalize_Address_Table is new Simple_HTable
54 (Header_Num => Header_Num,
55 Element => Finalize_Address_Ptr,
56 No_Element => null,
57 Key => System.Address,
58 Hash => Hash,
59 Equal => "=");
60
61 ---------------------------
62 -- Add_Offset_To_Address --
63 ---------------------------
64
65 function Add_Offset_To_Address
66 (Addr : System.Address;
67 Offset : System.Storage_Elements.Storage_Offset) return System.Address
68 is
69 begin
70 return System.Storage_Elements."+" (Addr, Offset);
71 end Add_Offset_To_Address;
72
73 ------------
74 -- Attach --
75 ------------
76
77 procedure Attach (N : not null FM_Node_Ptr; L : not null FM_Node_Ptr) is
78 begin
79 Lock_Task.all;
80 Attach_Unprotected (N, L);
81 Unlock_Task.all;
82
83 -- Note: No need to unlock in case of an exception because the above
84 -- code can never raise one.
85 end Attach;
86
87 ------------------------
88 -- Attach_Unprotected --
89 ------------------------
90
91 procedure Attach_Unprotected
92 (N : not null FM_Node_Ptr;
93 L : not null FM_Node_Ptr)
94 is
95 begin
96 L.Next.Prev := N;
97 N.Next := L.Next;
98 L.Next := N;
99 N.Prev := L;
100 end Attach_Unprotected;
101
102 ---------------
103 -- Base_Pool --
104 ---------------
105
106 function Base_Pool
107 (Master : Finalization_Master) return Any_Storage_Pool_Ptr
108 is
109 begin
110 return Master.Base_Pool;
111 end Base_Pool;
112
113 -----------------------------------------
114 -- Delete_Finalize_Address_Unprotected --
115 -----------------------------------------
116
117 procedure Delete_Finalize_Address_Unprotected (Obj : System.Address) is
118 begin
119 Finalize_Address_Table.Remove (Obj);
120 end Delete_Finalize_Address_Unprotected;
121
122 ------------
123 -- Detach --
124 ------------
125
126 procedure Detach (N : not null FM_Node_Ptr) is
127 begin
128 Lock_Task.all;
129 Detach_Unprotected (N);
130 Unlock_Task.all;
131
132 -- Note: No need to unlock in case of an exception because the above
133 -- code can never raise one.
134 end Detach;
135
136 ------------------------
137 -- Detach_Unprotected --
138 ------------------------
139
140 procedure Detach_Unprotected (N : not null FM_Node_Ptr) is
141 begin
142 if N.Prev /= null and then N.Next /= null then
143 N.Prev.Next := N.Next;
144 N.Next.Prev := N.Prev;
145 N.Prev := null;
146 N.Next := null;
147 end if;
148 end Detach_Unprotected;
149
150 --------------
151 -- Finalize --
152 --------------
153
154 overriding procedure Finalize (Master : in out Finalization_Master) is
155 Cleanup : Finalize_Address_Ptr;
156 Curr_Ptr : FM_Node_Ptr;
157 Ex_Occur : Exception_Occurrence;
158 Obj_Addr : Address;
159 Raised : Boolean := False;
160
161 function Is_Empty_List (L : not null FM_Node_Ptr) return Boolean;
162 -- Determine whether a list contains only one element, the dummy head
163
164 -------------------
165 -- Is_Empty_List --
166 -------------------
167
168 function Is_Empty_List (L : not null FM_Node_Ptr) return Boolean is
169 begin
170 return L.Next = L and then L.Prev = L;
171 end Is_Empty_List;
172
173 -- Start of processing for Finalize
174
175 begin
176 Lock_Task.all;
177
178 -- Synchronization:
179 -- Read - allocation, finalization
180 -- Write - finalization
181
182 if Master.Finalization_Started then
183 Unlock_Task.all;
184
185 -- Double finalization may occur during the handling of stand alone
186 -- libraries or the finalization of a pool with subpools. Due to the
187 -- potential aliasing of masters in these two cases, do not process
188 -- the same master twice.
189
190 return;
191 end if;
192
193 -- Lock the master to prevent any allocations while the objects are
194 -- being finalized. The master remains locked because either the master
195 -- is explicitly deallocated or the associated access type is about to
196 -- go out of scope.
197
198 -- Synchronization:
199 -- Read - allocation, finalization
200 -- Write - finalization
201
202 Master.Finalization_Started := True;
203
204 while not Is_Empty_List (Master.Objects'Unchecked_Access) loop
205 Curr_Ptr := Master.Objects.Next;
206
207 -- Synchronization:
208 -- Write - allocation, deallocation, finalization
209
210 Detach_Unprotected (Curr_Ptr);
211
212 -- Skip the list header in order to offer proper object layout for
213 -- finalization.
214
215 Obj_Addr := Curr_Ptr.all'Address + Header_Size;
216
217 -- Retrieve TSS primitive Finalize_Address depending on the master's
218 -- mode of operation.
219
220 -- Synchronization:
221 -- Read - allocation, finalization
222 -- Write - outside
223
224 if Master.Is_Homogeneous then
225
226 -- Synchronization:
227 -- Read - finalization
228 -- Write - allocation, outside
229
230 Cleanup := Master.Finalize_Address;
231
232 else
233 -- Synchronization:
234 -- Read - finalization
235 -- Write - allocation, deallocation
236
237 Cleanup := Finalize_Address_Unprotected (Obj_Addr);
238 end if;
239
240 begin
241 Cleanup (Obj_Addr);
242 exception
243 when Fin_Occur : others =>
244 if not Raised then
245 Raised := True;
246 Save_Occurrence (Ex_Occur, Fin_Occur);
247 end if;
248 end;
249
250 -- When the master is a heterogeneous collection, destroy the object
251 -- - Finalize_Address pair since it is no longer needed.
252
253 -- Synchronization:
254 -- Read - finalization
255 -- Write - outside
256
257 if not Master.Is_Homogeneous then
258
259 -- Synchronization:
260 -- Read - finalization
261 -- Write - allocation, deallocation, finalization
262
263 Delete_Finalize_Address_Unprotected (Obj_Addr);
264 end if;
265 end loop;
266
267 Unlock_Task.all;
268
269 -- If the finalization of a particular object failed or Finalize_Address
270 -- was not set, reraise the exception now.
271
272 if Raised then
273 Reraise_Occurrence (Ex_Occur);
274 end if;
275 end Finalize;
276
277 ----------------------
278 -- Finalize_Address --
279 ----------------------
280
281 function Finalize_Address
282 (Master : Finalization_Master) return Finalize_Address_Ptr
283 is
284 begin
285 return Master.Finalize_Address;
286 end Finalize_Address;
287
288 ----------------------------------
289 -- Finalize_Address_Unprotected --
290 ----------------------------------
291
292 function Finalize_Address_Unprotected
293 (Obj : System.Address) return Finalize_Address_Ptr
294 is
295 begin
296 return Finalize_Address_Table.Get (Obj);
297 end Finalize_Address_Unprotected;
298
299 --------------------------
300 -- Finalization_Started --
301 --------------------------
302
303 function Finalization_Started
304 (Master : Finalization_Master) return Boolean
305 is
306 begin
307 return Master.Finalization_Started;
308 end Finalization_Started;
309
310 ----------
311 -- Hash --
312 ----------
313
314 function Hash (Key : System.Address) return Header_Num is
315 begin
316 return
317 Header_Num
318 (To_Integer (Key) mod Integer_Address (Header_Num'Range_Length));
319 end Hash;
320
321 -----------------
322 -- Header_Size --
323 -----------------
324
325 function Header_Size return System.Storage_Elements.Storage_Count is
326 begin
327 return FM_Node'Size / Storage_Unit;
328 end Header_Size;
329
330 ----------------
331 -- Initialize --
332 ----------------
333
334 overriding procedure Initialize (Master : in out Finalization_Master) is
335 begin
336 -- The dummy head must point to itself in both directions
337
338 Master.Objects.Next := Master.Objects'Unchecked_Access;
339 Master.Objects.Prev := Master.Objects'Unchecked_Access;
340 end Initialize;
341
342 --------------------
343 -- Is_Homogeneous --
344 --------------------
345
346 function Is_Homogeneous (Master : Finalization_Master) return Boolean is
347 begin
348 return Master.Is_Homogeneous;
349 end Is_Homogeneous;
350
351 -------------
352 -- Objects --
353 -------------
354
355 function Objects (Master : Finalization_Master) return FM_Node_Ptr is
356 begin
357 return Master.Objects'Unrestricted_Access;
358 end Objects;
359
360 ------------------
361 -- Print_Master --
362 ------------------
363
364 procedure Print_Master (Master : Finalization_Master) is
365 Head : constant FM_Node_Ptr := Master.Objects'Unrestricted_Access;
366 Head_Seen : Boolean := False;
367 N_Ptr : FM_Node_Ptr;
368
369 begin
370 -- Output the basic contents of a master
371
372 -- Master : 0x123456789
373 -- Is_Hmgen : TURE <or> FALSE
374 -- Base_Pool: null <or> 0x123456789
375 -- Fin_Addr : null <or> 0x123456789
376 -- Fin_Start: TRUE <or> FALSE
377
378 Put ("Master : ");
379 Put_Line (Address_Image (Master'Address));
380
381 Put ("Is_Hmgen : ");
382 Put_Line (Master.Is_Homogeneous'Img);
383
384 Put ("Base_Pool: ");
385 if Master.Base_Pool = null then
386 Put_Line ("null");
387 else
388 Put_Line (Address_Image (Master.Base_Pool'Address));
389 end if;
390
391 Put ("Fin_Addr : ");
392 if Master.Finalize_Address = null then
393 Put_Line ("null");
394 else
395 Put_Line (Address_Image (Master.Finalize_Address'Address));
396 end if;
397
398 Put ("Fin_Start: ");
399 Put_Line (Master.Finalization_Started'Img);
400
401 -- Output all chained elements. The format is the following:
402
403 -- ^ <or> ? <or> null
404 -- |Header: 0x123456789 (dummy head)
405 -- | Prev: 0x123456789
406 -- | Next: 0x123456789
407 -- V
408
409 -- ^ - the current element points back to the correct element
410 -- ? - the current element points back to an erroneous element
411 -- n - the current element points back to null
412
413 -- Header - the address of the list header
414 -- Prev - the address of the list header which the current element
415 -- points back to
416 -- Next - the address of the list header which the current element
417 -- points to
418 -- (dummy head) - present if dummy head
419
420 N_Ptr := Head;
421 while N_Ptr /= null loop -- Should never be null
422 Put_Line ("V");
423
424 -- We see the head initially; we want to exit when we see the head a
425 -- second time.
426
427 if N_Ptr = Head then
428 exit when Head_Seen;
429
430 Head_Seen := True;
431 end if;
432
433 -- The current element is null. This should never happen since the
434 -- list is circular.
435
436 if N_Ptr.Prev = null then
437 Put_Line ("null (ERROR)");
438
439 -- The current element points back to the correct element
440
441 elsif N_Ptr.Prev.Next = N_Ptr then
442 Put_Line ("^");
443
444 -- The current element points to an erroneous element
445
446 else
447 Put_Line ("? (ERROR)");
448 end if;
449
450 -- Output the header and fields
451
452 Put ("|Header: ");
453 Put (Address_Image (N_Ptr.all'Address));
454
455 -- Detect the dummy head
456
457 if N_Ptr = Head then
458 Put_Line (" (dummy head)");
459 else
460 Put_Line ("");
461 end if;
462
463 Put ("| Prev: ");
464
465 if N_Ptr.Prev = null then
466 Put_Line ("null");
467 else
468 Put_Line (Address_Image (N_Ptr.Prev.all'Address));
469 end if;
470
471 Put ("| Next: ");
472
473 if N_Ptr.Next = null then
474 Put_Line ("null");
475 else
476 Put_Line (Address_Image (N_Ptr.Next.all'Address));
477 end if;
478
479 N_Ptr := N_Ptr.Next;
480 end loop;
481 end Print_Master;
482
483 -------------------
484 -- Set_Base_Pool --
485 -------------------
486
487 procedure Set_Base_Pool
488 (Master : in out Finalization_Master;
489 Pool_Ptr : Any_Storage_Pool_Ptr)
490 is
491 begin
492 Master.Base_Pool := Pool_Ptr;
493 end Set_Base_Pool;
494
495 --------------------------
496 -- Set_Finalize_Address --
497 --------------------------
498
499 procedure Set_Finalize_Address
500 (Master : in out Finalization_Master;
501 Fin_Addr_Ptr : Finalize_Address_Ptr)
502 is
503 begin
504 -- Synchronization:
505 -- Read - finalization
506 -- Write - allocation, outside
507
508 Lock_Task.all;
509 Set_Finalize_Address_Unprotected (Master, Fin_Addr_Ptr);
510 Unlock_Task.all;
511 end Set_Finalize_Address;
512
513 --------------------------------------
514 -- Set_Finalize_Address_Unprotected --
515 --------------------------------------
516
517 procedure Set_Finalize_Address_Unprotected
518 (Master : in out Finalization_Master;
519 Fin_Addr_Ptr : Finalize_Address_Ptr)
520 is
521 begin
522 if Master.Finalize_Address = null then
523 Master.Finalize_Address := Fin_Addr_Ptr;
524 end if;
525 end Set_Finalize_Address_Unprotected;
526
527 ----------------------------------------------------
528 -- Set_Heterogeneous_Finalize_Address_Unprotected --
529 ----------------------------------------------------
530
531 procedure Set_Heterogeneous_Finalize_Address_Unprotected
532 (Obj : System.Address;
533 Fin_Addr_Ptr : Finalize_Address_Ptr)
534 is
535 begin
536 Finalize_Address_Table.Set (Obj, Fin_Addr_Ptr);
537 end Set_Heterogeneous_Finalize_Address_Unprotected;
538
539 --------------------------
540 -- Set_Is_Heterogeneous --
541 --------------------------
542
543 procedure Set_Is_Heterogeneous (Master : in out Finalization_Master) is
544 begin
545 -- Synchronization:
546 -- Read - finalization
547 -- Write - outside
548
549 Lock_Task.all;
550 Master.Is_Homogeneous := False;
551 Unlock_Task.all;
552 end Set_Is_Heterogeneous;
553
554 end System.Finalization_Masters;