1 ------------------------------------------------------------------------------
3 -- GNAT RUN-TIME COMPONENTS --
5 -- S Y S T E M . F I N A L I Z A T I O N _ I M P L E M E N T A T I O N --
9 -- Copyright (C) 1992-2006, 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 2, 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. See the GNU General Public License --
17 -- for more details. You should have received a copy of the GNU General --
18 -- Public License distributed with GNAT; see file COPYING. If not, write --
19 -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, --
20 -- Boston, MA 02110-1301, USA. --
22 -- As a special exception, if other files instantiate generics from this --
23 -- unit, or you link this unit with other files to produce an executable, --
24 -- this unit does not by itself cause the resulting executable to be --
25 -- covered by the GNU General Public License. This exception does not --
26 -- however invalidate any other reasons why the executable file might be --
27 -- covered by the GNU Public License. --
29 -- GNAT was originally developed by the GNAT team at New York University. --
30 -- Extensive contributions were provided by Ada Core Technologies Inc. --
32 ------------------------------------------------------------------------------
37 with System.Soft_Links;
39 with Unchecked_Conversion;
40 with System.Restrictions;
42 package body System.Finalization_Implementation is
45 use System.Finalization_Root;
47 package SSL renames System.Soft_Links;
49 use type SSE.Storage_Offset;
51 -----------------------
52 -- Local Subprograms --
53 -----------------------
55 type RC_Ptr is access all Record_Controller;
58 new Unchecked_Conversion (Address, RC_Ptr);
60 procedure Raise_Exception_No_Defer
62 Message : String := "");
63 pragma Import (Ada, Raise_Exception_No_Defer,
64 "ada__exceptions__raise_exception_no_defer");
65 pragma No_Return (Raise_Exception_No_Defer);
66 -- Raise an exception without deferring abort. Note that we have to
67 -- use this rather kludgy Ada Import interface, since this subprogram
68 -- is not available in the visible spec of Ada.Exceptions.
70 procedure Raise_From_Finalize
73 E_Occ : Exception_Occurrence);
74 -- Deal with an exception raised during finalization of a list. L is a
75 -- pointer to the list of element not yet finalized. From_Abort is true
76 -- if the finalization actions come from an abort rather than a normal
77 -- exit. E_Occ represents the exception being raised.
79 function RC_Offset (T : Ada.Tags.Tag) return SSE.Storage_Offset;
80 pragma Import (Ada, RC_Offset, "ada__tags__get_rc_offset");
82 function Parent_Size (Obj : Address; T : Ada.Tags.Tag)
83 return SSE.Storage_Count;
84 pragma Import (Ada, Parent_Size, "ada__tags__parent_size");
86 function Get_Deep_Controller (Obj : System.Address) return RC_Ptr;
87 -- Given the address (obj) of a tagged object, return a
88 -- pointer to the record controller of this object.
94 procedure Adjust (Object : in out Record_Controller) is
96 First_Comp : Finalizable_Ptr;
97 My_Offset : constant SSE.Storage_Offset :=
98 Object.My_Address - Object'Address;
100 procedure Ptr_Adjust (Ptr : in out Finalizable_Ptr);
101 -- Subtract the offset to the pointer
103 procedure Reverse_Adjust (P : Finalizable_Ptr);
104 -- Ajust the components in the reverse order in which they are stored
105 -- on the finalization list. (Adjust and Finalization are not done in
112 procedure Ptr_Adjust (Ptr : in out Finalizable_Ptr) is
115 Ptr := To_Finalizable_Ptr (To_Addr (Ptr) - My_Offset);
123 procedure Reverse_Adjust (P : Finalizable_Ptr) is
127 Reverse_Adjust (P.Next);
129 Object.F := P; -- Successfully adjusted, so place in list.
133 -- Start of processing for Adjust
136 -- Adjust the components and their finalization pointers next. We must
137 -- protect against an exception in some call to Adjust, so we keep
138 -- pointing to the list of successfully adjusted components, which can
139 -- be finalized if an exception is raised.
141 First_Comp := Object.F;
142 Object.F := null; -- nothing adjusted yet.
143 Ptr_Adjust (First_Comp); -- set addresss of first component.
144 Reverse_Adjust (First_Comp);
146 -- Then Adjust the controller itself
148 Object.My_Address := Object'Address;
152 -- Finalize those components that were successfully adjusted, and
153 -- propagate exception. The object itself is not yet attached to
154 -- global finalization list, so we cannot rely on the outer call to
155 -- Clean to take care of these components.
161 --------------------------
162 -- Attach_To_Final_List --
163 --------------------------
165 procedure Attach_To_Final_List
166 (L : in out Finalizable_Ptr;
167 Obj : in out Finalizable;
168 Nb_Link : Short_Short_Integer)
171 -- Simple case: attachment to a one way list
175 L := Obj'Unchecked_Access;
177 -- Dynamically allocated objects: they are attached to a doubly linked
178 -- list, so that an element can be finalized at any moment by means of
179 -- an unchecked deallocation. Attachment is protected against
180 -- multi-threaded access.
182 elsif Nb_Link = 2 then
184 -- Raise Program_Error if we're trying to allocate an object in a
185 -- collection whose finalization has already started.
187 if L = Collection_Finalization_Started then
188 raise Program_Error with
189 "allocation after collection finalization started";
192 Locked_Processing : begin
195 Obj.Prev := L.Next.Prev;
196 L.Next.Prev := Obj'Unchecked_Access;
197 L.Next := Obj'Unchecked_Access;
204 end Locked_Processing;
206 -- Attachment of arrays to the final list (used only for objects
207 -- returned by function). Obj, in this case is the last element,
208 -- but all other elements are already threaded after it. We just
209 -- attach the rest of the final list at the end of the array list.
211 elsif Nb_Link = 3 then
213 P : Finalizable_Ptr := Obj'Unchecked_Access;
216 while P.Next /= null loop
221 L := Obj'Unchecked_Access;
224 -- Make the object completely unattached (case of a library-level,
225 -- Finalize_Storage_Only object).
227 elsif Nb_Link = 4 then
231 end Attach_To_Final_List;
233 ---------------------
234 -- Deep_Tag_Attach --
235 ----------------------
237 procedure Deep_Tag_Attach
238 (L : in out SFR.Finalizable_Ptr;
240 B : Short_Short_Integer)
242 V : constant SFR.Finalizable_Ptr := To_Finalizable_Ptr (A);
243 Controller : constant RC_Ptr := Get_Deep_Controller (A);
246 if Controller /= null then
247 Attach_To_Final_List (L, Controller.all, B);
252 if V.all in Finalizable then
253 Attach_To_Final_List (L, V.all, B);
257 -----------------------------
258 -- Detach_From_Final_List --
259 -----------------------------
261 -- We know that the detach object is neither at the beginning nor at the
262 -- end of the list, thank's to the dummy First and Last Elements but the
263 -- object may not be attached at all if it is Finalize_Storage_Only
265 procedure Detach_From_Final_List (Obj : in out Finalizable) is
268 -- When objects are not properly attached to a doubly linked list do
269 -- not try to detach them. The only case where it can happen is when
270 -- dealing with Finalize_Storage_Only objects which are not always
271 -- attached to the finalization list.
273 if Obj.Next /= null and then Obj.Prev /= null then
275 Obj.Next.Prev := Obj.Prev;
276 Obj.Prev.Next := Obj.Next;
284 end Detach_From_Final_List;
290 procedure Finalize (Object : in out Limited_Record_Controller) is
292 Finalize_List (Object.F);
295 --------------------------
296 -- Finalize_Global_List --
297 --------------------------
299 procedure Finalize_Global_List is
301 -- There are three case here:
303 -- a. the application uses tasks, in which case Finalize_Global_Tasks
306 -- b. the application doesn't use tasks but uses other tasking
307 -- constructs, such as ATCs and protected objects. In this case,
308 -- the binder will call Finalize_Global_List instead of
309 -- Finalize_Global_Tasks, letting abort undeferred, and leading
310 -- to assertion failures in the GNULL
312 -- c. the application doesn't use any tasking construct in which case
313 -- deferring abort isn't necessary.
315 -- Until another solution is found to deal with case b, we need to
316 -- call abort_defer here to pass the checks, but we do not need to
317 -- undefer abort, since Finalize_Global_List is the last procedure
318 -- called before exiting the partition.
321 Finalize_List (Global_Final_List);
322 end Finalize_Global_List;
328 procedure Finalize_List (L : Finalizable_Ptr) is
329 P : Finalizable_Ptr := L;
332 type Fake_Exception_Occurence is record
335 type Ptr is access all Fake_Exception_Occurence;
337 function To_Ptr is new
338 Unchecked_Conversion (Exception_Occurrence_Access, Ptr);
340 X : Exception_Id := Null_Id;
343 -- If abort is allowed, we get the current exception before starting
344 -- to finalize in order to check if we are in the abort case if an
345 -- exception is raised. When abort is not allowed, avoid accessing the
346 -- current exception since this can be a pretty costly operation in
347 -- programs using controlled types heavily.
349 if System.Restrictions.Abort_Allowed then
350 X := To_Ptr (SSL.Get_Current_Excep.all).Id;
360 when E_Occ : others =>
361 Raise_From_Finalize (
363 X = Standard'Abort_Signal'Identity,
371 procedure Finalize_One (Obj : in out Finalizable) is
373 Detach_From_Final_List (Obj);
376 when E_Occ : others => Raise_From_Finalize (null, False, E_Occ);
379 -------------------------
380 -- Get_Deep_Controller --
381 -------------------------
383 function Get_Deep_Controller (Obj : System.Address) return RC_Ptr is
384 The_Tag : Ada.Tags.Tag := To_Finalizable_Ptr (Obj)'Tag;
385 Offset : SSE.Storage_Offset := RC_Offset (The_Tag);
388 -- Fetch the controller from the Parent or above if necessary
389 -- when there are no controller at this level
391 while Offset = -2 loop
392 The_Tag := Ada.Tags.Parent_Tag (The_Tag);
393 Offset := RC_Offset (The_Tag);
396 -- No Controlled component case
401 -- The _controller Offset is known statically
403 elsif Offset > 0 then
404 return To_RC_Ptr (Obj + Offset);
406 -- At this stage, we know that the controller is part of the
407 -- ancestor corresponding to the tag "The_Tag" and that its parent
408 -- is variable sized. We assume that the _controller is the first
409 -- compoment right after the parent.
411 -- ??? note that it may not be true if there are new discriminants
416 -- define a faked record controller to avoid generating
417 -- unnecessary expanded code for controlled types
419 type Faked_Record_Controller is record
420 Tag, Prec, Next : Address;
423 -- Reconstruction of a type with characteristics
424 -- comparable to the original type
426 D : constant := SSE.Storage_Offset (Storage_Unit - 1);
428 type Parent_Type is new SSE.Storage_Array
429 (1 .. (Parent_Size (Obj, The_Tag) + D) /
430 SSE.Storage_Offset (Storage_Unit));
431 for Parent_Type'Alignment use Address'Alignment;
433 type Faked_Type_Of_Obj is record
434 Parent : Parent_Type;
435 Controller : Faked_Record_Controller;
438 type Obj_Ptr is access all Faked_Type_Of_Obj;
439 function To_Obj_Ptr is
440 new Unchecked_Conversion (Address, Obj_Ptr);
443 return To_RC_Ptr (To_Obj_Ptr (Obj).Controller'Address);
446 end Get_Deep_Controller;
452 procedure Initialize (Object : in out Limited_Record_Controller) is
453 pragma Warnings (Off, Object);
458 procedure Initialize (Object : in out Record_Controller) is
460 Object.My_Address := Object'Address;
463 ---------------------
464 -- Move_Final_List --
465 ---------------------
467 procedure Move_Final_List
468 (From : in out SFR.Finalizable_Ptr;
469 To : Finalizable_Ptr_Ptr)
472 -- This is currently called at the end of the return statement, and the
473 -- caller does NOT defer aborts. We need to defer aborts to prevent
474 -- mangling the finalization lists.
478 -- Put the return statement's finalization list onto the caller's one,
479 -- thus transferring responsibility for finalization of the return
480 -- object to the caller.
482 Attach_To_Final_List (To.all, From.all, Nb_Link => 3);
484 -- Empty the return statement's finalization list, so that when the
485 -- cleanup code executes, there will be nothing to finalize.
488 SSL.Abort_Undefer.all;
491 -------------------------
492 -- Raise_From_Finalize --
493 -------------------------
495 procedure Raise_From_Finalize
496 (L : Finalizable_Ptr;
497 From_Abort : Boolean;
498 E_Occ : Exception_Occurrence)
500 Msg : constant String := Exception_Message (E_Occ);
501 P : Finalizable_Ptr := L;
505 -- We already got an exception. We now finalize the remainder of
506 -- the list, ignoring all further exceptions.
520 -- If finalization from an Abort, then nothing to do
525 -- If no message, then add our own message saying what happened
528 Raise_Exception_No_Defer
529 (E => Program_Error'Identity,
530 Message => "exception " &
531 Exception_Name (E_Occ) &
532 " raised during finalization");
534 -- If there was a message, pass it on
537 Raise_Exception_No_Defer (Program_Error'Identity, Msg);
539 end Raise_From_Finalize;
541 -- Initialization of package, set Adafinal soft link
544 SSL.Finalize_Global_List := Finalize_Global_List'Access;
546 end System.Finalization_Implementation;