1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
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 --
9 -- Copyright (C) 2011, Free Software Foundation, Inc. --
11 -- GNAT is free software; you can redistribute it and/or modify it under --
12 -- terms of the GNU General Public License as published by the Free Soft- --
13 -- ware Foundation; either version 3, or (at your option) any later ver- --
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. --
18 -- As a special exception under Section 7 of GPL version 3, you are granted --
19 -- additional permissions described in the GCC Runtime Library Exception, --
20 -- version 3.1, as published by the Free Software Foundation. --
22 -- You should have received a copy of the GNU General Public License and --
23 -- a copy of the GCC Runtime Library Exception along with this program; --
24 -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
25 -- <http://www.gnu.org/licenses/>. --
27 -- GNAT was originally developed by the GNAT team at New York University. --
28 -- Extensive contributions were provided by Ada Core Technologies Inc. --
30 ------------------------------------------------------------------------------
32 with Ada.Exceptions; use Ada.Exceptions;
34 with System.Address_Image;
35 with System.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;
40 package body System.Finalization_Masters is
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.
47 type Header_Num is range 0 .. 127;
49 function Hash (Key : System.Address) return Header_Num;
51 -- Address --> Finalize_Address_Ptr
53 package Finalize_Address_Table is new Simple_HTable
54 (Header_Num => Header_Num,
55 Element => Finalize_Address_Ptr,
57 Key => System.Address,
61 ---------------------------
62 -- Add_Offset_To_Address --
63 ---------------------------
65 function Add_Offset_To_Address
66 (Addr : System.Address;
67 Offset : System.Storage_Elements.Storage_Offset) return System.Address
70 return System.Storage_Elements."+" (Addr, Offset);
71 end Add_Offset_To_Address;
77 procedure Attach (N : not null FM_Node_Ptr; L : not null FM_Node_Ptr) is
80 Attach_Unprotected (N, L);
83 -- Note: No need to unlock in case of an exception because the above
84 -- code can never raise one.
87 ------------------------
88 -- Attach_Unprotected --
89 ------------------------
91 procedure Attach_Unprotected
92 (N : not null FM_Node_Ptr;
93 L : not null FM_Node_Ptr)
100 end Attach_Unprotected;
107 (Master : Finalization_Master) return Any_Storage_Pool_Ptr
110 return Master.Base_Pool;
113 -----------------------------------------
114 -- Delete_Finalize_Address_Unprotected --
115 -----------------------------------------
117 procedure Delete_Finalize_Address_Unprotected (Obj : System.Address) is
119 Finalize_Address_Table.Remove (Obj);
120 end Delete_Finalize_Address_Unprotected;
126 procedure Detach (N : not null FM_Node_Ptr) is
129 Detach_Unprotected (N);
132 -- Note: No need to unlock in case of an exception because the above
133 -- code can never raise one.
136 ------------------------
137 -- Detach_Unprotected --
138 ------------------------
140 procedure Detach_Unprotected (N : not null FM_Node_Ptr) is
142 if N.Prev /= null and then N.Next /= null then
143 N.Prev.Next := N.Next;
144 N.Next.Prev := N.Prev;
148 end Detach_Unprotected;
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;
159 Raised : Boolean := False;
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
168 function Is_Empty_List (L : not null FM_Node_Ptr) return Boolean is
170 return L.Next = L and then L.Prev = L;
173 -- Start of processing for Finalize
179 -- Read - allocation, finalization
180 -- Write - finalization
182 if Master.Finalization_Started then
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.
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
199 -- Read - allocation, finalization
200 -- Write - finalization
202 Master.Finalization_Started := True;
204 while not Is_Empty_List (Master.Objects'Unchecked_Access) loop
205 Curr_Ptr := Master.Objects.Next;
208 -- Write - allocation, deallocation, finalization
210 Detach_Unprotected (Curr_Ptr);
212 -- Skip the list header in order to offer proper object layout for
215 Obj_Addr := Curr_Ptr.all'Address + Header_Offset;
217 -- Retrieve TSS primitive Finalize_Address depending on the master's
218 -- mode of operation.
221 -- Read - allocation, finalization
224 if Master.Is_Homogeneous then
227 -- Read - finalization
228 -- Write - allocation, outside
230 Cleanup := Master.Finalize_Address;
234 -- Read - finalization
235 -- Write - allocation, deallocation
237 Cleanup := Finalize_Address_Unprotected (Obj_Addr);
243 when Fin_Occur : others =>
246 Save_Occurrence (Ex_Occur, Fin_Occur);
250 -- When the master is a heterogeneous collection, destroy the object
251 -- - Finalize_Address pair since it is no longer needed.
254 -- Read - finalization
257 if not Master.Is_Homogeneous then
260 -- Read - finalization
261 -- Write - allocation, deallocation, finalization
263 Delete_Finalize_Address_Unprotected (Obj_Addr);
269 -- If the finalization of a particular object failed or Finalize_Address
270 -- was not set, reraise the exception now.
273 Reraise_Occurrence (Ex_Occur);
277 ----------------------
278 -- Finalize_Address --
279 ----------------------
281 function Finalize_Address
282 (Master : Finalization_Master) return Finalize_Address_Ptr
285 return Master.Finalize_Address;
286 end Finalize_Address;
288 ----------------------------------
289 -- Finalize_Address_Unprotected --
290 ----------------------------------
292 function Finalize_Address_Unprotected
293 (Obj : System.Address) return Finalize_Address_Ptr
296 return Finalize_Address_Table.Get (Obj);
297 end Finalize_Address_Unprotected;
299 --------------------------
300 -- Finalization_Started --
301 --------------------------
303 function Finalization_Started
304 (Master : Finalization_Master) return Boolean
307 return Master.Finalization_Started;
308 end Finalization_Started;
314 function Hash (Key : System.Address) return Header_Num is
318 (To_Integer (Key) mod Integer_Address (Header_Num'Range_Length));
325 function Header_Size return System.Storage_Elements.Storage_Count is
327 return FM_Node'Size / Storage_Unit;
334 function Header_Offset return System.Storage_Elements.Storage_Offset is
336 return FM_Node'Size / Storage_Unit;
343 overriding procedure Initialize (Master : in out Finalization_Master) is
345 -- The dummy head must point to itself in both directions
347 Master.Objects.Next := Master.Objects'Unchecked_Access;
348 Master.Objects.Prev := Master.Objects'Unchecked_Access;
355 function Is_Homogeneous (Master : Finalization_Master) return Boolean is
357 return Master.Is_Homogeneous;
364 function Objects (Master : Finalization_Master) return FM_Node_Ptr is
366 return Master.Objects'Unrestricted_Access;
373 procedure Print_Master (Master : Finalization_Master) is
374 Head : constant FM_Node_Ptr := Master.Objects'Unrestricted_Access;
375 Head_Seen : Boolean := False;
379 -- Output the basic contents of a master
381 -- Master : 0x123456789
382 -- Is_Hmgen : TURE <or> FALSE
383 -- Base_Pool: null <or> 0x123456789
384 -- Fin_Addr : null <or> 0x123456789
385 -- Fin_Start: TRUE <or> FALSE
388 Put_Line (Address_Image (Master'Address));
391 Put_Line (Master.Is_Homogeneous'Img);
394 if Master.Base_Pool = null then
397 Put_Line (Address_Image (Master.Base_Pool'Address));
401 if Master.Finalize_Address = null then
404 Put_Line (Address_Image (Master.Finalize_Address'Address));
408 Put_Line (Master.Finalization_Started'Img);
410 -- Output all chained elements. The format is the following:
412 -- ^ <or> ? <or> null
413 -- |Header: 0x123456789 (dummy head)
414 -- | Prev: 0x123456789
415 -- | Next: 0x123456789
418 -- ^ - the current element points back to the correct element
419 -- ? - the current element points back to an erroneous element
420 -- n - the current element points back to null
422 -- Header - the address of the list header
423 -- Prev - the address of the list header which the current element
425 -- Next - the address of the list header which the current element
427 -- (dummy head) - present if dummy head
430 while N_Ptr /= null loop -- Should never be null
433 -- We see the head initially; we want to exit when we see the head a
442 -- The current element is null. This should never happen since the
445 if N_Ptr.Prev = null then
446 Put_Line ("null (ERROR)");
448 -- The current element points back to the correct element
450 elsif N_Ptr.Prev.Next = N_Ptr then
453 -- The current element points to an erroneous element
456 Put_Line ("? (ERROR)");
459 -- Output the header and fields
462 Put (Address_Image (N_Ptr.all'Address));
464 -- Detect the dummy head
467 Put_Line (" (dummy head)");
474 if N_Ptr.Prev = null then
477 Put_Line (Address_Image (N_Ptr.Prev.all'Address));
482 if N_Ptr.Next = null then
485 Put_Line (Address_Image (N_Ptr.Next.all'Address));
496 procedure Set_Base_Pool
497 (Master : in out Finalization_Master;
498 Pool_Ptr : Any_Storage_Pool_Ptr)
501 Master.Base_Pool := Pool_Ptr;
504 --------------------------
505 -- Set_Finalize_Address --
506 --------------------------
508 procedure Set_Finalize_Address
509 (Master : in out Finalization_Master;
510 Fin_Addr_Ptr : Finalize_Address_Ptr)
514 -- Read - finalization
515 -- Write - allocation, outside
518 Set_Finalize_Address_Unprotected (Master, Fin_Addr_Ptr);
520 end Set_Finalize_Address;
522 --------------------------------------
523 -- Set_Finalize_Address_Unprotected --
524 --------------------------------------
526 procedure Set_Finalize_Address_Unprotected
527 (Master : in out Finalization_Master;
528 Fin_Addr_Ptr : Finalize_Address_Ptr)
531 if Master.Finalize_Address = null then
532 Master.Finalize_Address := Fin_Addr_Ptr;
534 end Set_Finalize_Address_Unprotected;
536 ----------------------------------------------------
537 -- Set_Heterogeneous_Finalize_Address_Unprotected --
538 ----------------------------------------------------
540 procedure Set_Heterogeneous_Finalize_Address_Unprotected
541 (Obj : System.Address;
542 Fin_Addr_Ptr : Finalize_Address_Ptr)
545 Finalize_Address_Table.Set (Obj, Fin_Addr_Ptr);
546 end Set_Heterogeneous_Finalize_Address_Unprotected;
548 --------------------------
549 -- Set_Is_Heterogeneous --
550 --------------------------
552 procedure Set_Is_Heterogeneous (Master : in out Finalization_Master) is
555 -- Read - finalization
559 Master.Is_Homogeneous := False;
561 end Set_Is_Heterogeneous;
563 end System.Finalization_Masters;