|
111
|
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 -- --
|
|
131
|
9 -- Copyright (C) 2015-2018, Free Software Foundation, Inc. --
|
|
111
|
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
|
|
|
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;
|
