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-2005 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, 59 Temple Place - Suite 330, Boston, --
20 -- MA 02111-1307, 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.Storage_Elements;
38 with System.Soft_Links;
40 with Unchecked_Conversion;
41 with System.Restrictions;
43 package body System.Finalization_Implementation is
46 use System.Finalization_Root;
48 package SSL renames System.Soft_Links;
50 package SSE renames System.Storage_Elements;
51 use type SSE.Storage_Offset;
53 -----------------------
54 -- Local Subprograms --
55 -----------------------
57 type RC_Ptr is access all Record_Controller;
60 new Unchecked_Conversion (Address, RC_Ptr);
62 procedure Raise_Exception_No_Defer
64 Message : in String := "");
65 pragma Import (Ada, Raise_Exception_No_Defer,
66 "ada__exceptions__raise_exception_no_defer");
67 pragma No_Return (Raise_Exception_No_Defer);
68 -- Raise an exception without deferring abort. Note that we have to
69 -- use this rather kludgy Ada Import interface, since this subprogram
70 -- is not available in the visible spec of Ada.Exceptions.
72 procedure Raise_From_Finalize
75 E_Occ : Exception_Occurrence);
76 -- Deal with an exception raised during finalization of a list. L is a
77 -- pointer to the list of element not yet finalized. From_Abort is true
78 -- if the finalization actions come from an abort rather than a normal
79 -- exit. E_Occ represents the exception being raised.
81 function RC_Offset (T : Ada.Tags.Tag) return SSE.Storage_Offset;
82 pragma Import (Ada, RC_Offset, "ada__tags__get_rc_offset");
84 function Parent_Size (Obj : Address; T : Ada.Tags.Tag)
85 return SSE.Storage_Count;
86 pragma Import (Ada, Parent_Size, "ada__tags__parent_size");
88 function Parent_Tag (T : Ada.Tags.Tag) return Ada.Tags.Tag;
89 pragma Import (Ada, Parent_Tag, "ada__tags__parent_tag");
91 function Get_Deep_Controller (Obj : System.Address) return RC_Ptr;
92 -- Given the address (obj) of a tagged object, return a
93 -- pointer to the record controller of this object.
99 procedure Adjust (Object : in out Record_Controller) is
101 First_Comp : Finalizable_Ptr;
102 My_Offset : constant SSE.Storage_Offset :=
103 Object.My_Address - Object'Address;
105 procedure Ptr_Adjust (Ptr : in out Finalizable_Ptr);
106 -- Subtract the offset to the pointer
108 procedure Reverse_Adjust (P : Finalizable_Ptr);
109 -- Ajust the components in the reverse order in which they are stored
110 -- on the finalization list. (Adjust and Finalization are not done in
117 procedure Ptr_Adjust (Ptr : in out Finalizable_Ptr) is
120 Ptr := To_Finalizable_Ptr (To_Addr (Ptr) - My_Offset);
128 procedure Reverse_Adjust (P : Finalizable_Ptr) is
132 Reverse_Adjust (P.Next);
134 Object.F := P; -- Successfully adjusted, so place in list.
138 -- Start of processing for Adjust
141 -- Adjust the components and their finalization pointers next. We must
142 -- protect against an exception in some call to Adjust, so we keep
143 -- pointing to the list of successfully adjusted components, which can
144 -- be finalized if an exception is raised.
146 First_Comp := Object.F;
147 Object.F := null; -- nothing adjusted yet.
148 Ptr_Adjust (First_Comp); -- set addresss of first component.
149 Reverse_Adjust (First_Comp);
151 -- Then Adjust the controller itself
153 Object.My_Address := Object'Address;
157 -- Finalize those components that were successfully adjusted, and
158 -- propagate exception. The object itself is not yet attached to
159 -- global finalization list, so we cannot rely on the outer call to
160 -- Clean to take care of these components.
166 --------------------------
167 -- Attach_To_Final_List --
168 --------------------------
170 procedure Attach_To_Final_List
171 (L : in out Finalizable_Ptr;
172 Obj : in out Finalizable;
173 Nb_Link : Short_Short_Integer)
176 -- Simple case: attachement to a one way list
180 L := Obj'Unchecked_Access;
182 -- Dynamically allocated objects: they are attached to a doubly linked
183 -- list, so that an element can be finalized at any moment by means of
184 -- an unchecked deallocation. Attachement is protected against
185 -- multi-threaded access.
187 elsif Nb_Link = 2 then
189 Locked_Processing : begin
192 Obj.Prev := L.Next.Prev;
193 L.Next.Prev := Obj'Unchecked_Access;
194 L.Next := Obj'Unchecked_Access;
201 end Locked_Processing;
203 -- Attachement of arrays to the final list (used only for objects
204 -- returned by function). Obj, in this case is the last element,
205 -- but all other elements are already threaded after it. We just
206 -- attach the rest of the final list at the end of the array list.
208 elsif Nb_Link = 3 then
210 P : Finalizable_Ptr := Obj'Unchecked_Access;
213 while P.Next /= null loop
218 L := Obj'Unchecked_Access;
221 end Attach_To_Final_List;
223 ---------------------
224 -- Deep_Tag_Adjust --
225 ---------------------
227 procedure Deep_Tag_Adjust
228 (L : in out SFR.Finalizable_Ptr;
230 B : Short_Short_Integer)
232 V : constant SFR.Finalizable_Ptr := To_Finalizable_Ptr (A);
233 Controller : constant RC_Ptr := Get_Deep_Controller (A);
236 if Controller /= null then
237 Adjust (Controller.all);
238 Attach_To_Final_List (L, Controller.all, B);
243 if V.all in Finalizable then
245 Attach_To_Final_List (L, Finalizable (V.all), 1);
249 ---------------------
250 -- Deep_Tag_Attach --
251 ----------------------
253 procedure Deep_Tag_Attach
254 (L : in out SFR.Finalizable_Ptr;
256 B : Short_Short_Integer)
258 V : constant SFR.Finalizable_Ptr := To_Finalizable_Ptr (A);
259 Controller : constant RC_Ptr := Get_Deep_Controller (A);
262 if Controller /= null then
263 Attach_To_Final_List (L, Controller.all, B);
268 if V.all in Finalizable then
269 Attach_To_Final_List (L, V.all, B);
273 -----------------------
274 -- Deep_Tag_Finalize --
275 -----------------------
277 procedure Deep_Tag_Finalize
278 (L : in out SFR.Finalizable_Ptr;
282 pragma Warnings (Off, L);
284 V : constant SFR.Finalizable_Ptr := To_Finalizable_Ptr (A);
285 Controller : constant RC_Ptr := Get_Deep_Controller (A);
288 if Controller /= null then
290 Finalize_One (Controller.all);
292 Finalize (Controller.all);
298 if V.all in Finalizable then
300 Finalize_One (V.all);
305 end Deep_Tag_Finalize;
307 -------------------------
308 -- Deep_Tag_Initialize --
309 -------------------------
311 procedure Deep_Tag_Initialize
312 (L : in out SFR.Finalizable_Ptr;
314 B : Short_Short_Integer)
316 V : constant SFR.Finalizable_Ptr := To_Finalizable_Ptr (A);
317 Controller : constant RC_Ptr := Get_Deep_Controller (A);
320 -- This procedure should not be called if the object has no
321 -- controlled components
323 if Controller = null then
326 -- Has controlled components
329 Initialize (Controller.all);
330 Attach_To_Final_List (L, Controller.all, B);
335 if V.all in Finalizable then
337 Attach_To_Final_List (Controller.F, Finalizable (Controller.all), 1);
339 end Deep_Tag_Initialize;
341 -----------------------------
342 -- Detach_From_Final_List --
343 -----------------------------
345 -- We know that the detach object is neither at the beginning nor at the
346 -- end of the list, thank's to the dummy First and Last Elements but the
347 -- object may not be attached at all if it is Finalize_Storage_Only
349 procedure Detach_From_Final_List (Obj : in out Finalizable) is
352 -- When objects are not properly attached to a doubly linked list do
353 -- not try to detach them. The only case where it can happen is when
354 -- dealing with Finalize_Storage_Only objects which are not always
355 -- attached to the finalization list.
357 if Obj.Next /= null and then Obj.Prev /= null then
359 Obj.Next.Prev := Obj.Prev;
360 Obj.Prev.Next := Obj.Next;
368 end Detach_From_Final_List;
374 procedure Finalize (Object : in out Limited_Record_Controller) is
376 Finalize_List (Object.F);
379 --------------------------
380 -- Finalize_Global_List --
381 --------------------------
383 procedure Finalize_Global_List is
385 -- There are three case here:
386 -- a. the application uses tasks, in which case Finalize_Global_Tasks
387 -- will defer abortion
388 -- b. the application doesn't use tasks but uses other tasking
389 -- constructs, such as ATCs and protected objects. In this case,
390 -- the binder will call Finalize_Global_List instead of
391 -- Finalize_Global_Tasks, letting abort undeferred, and leading
392 -- to assertion failures in the GNULL
393 -- c. the application doesn't use any tasking construct in which case
394 -- deferring abort isn't necessary.
396 -- Until another solution is found to deal with case b, we need to
397 -- call abort_defer here to pass the checks, but we do not need to
398 -- undefer abortion, since Finalize_Global_List is the last procedure
399 -- called before exiting the partition.
402 Finalize_List (Global_Final_List);
403 end Finalize_Global_List;
409 procedure Finalize_List (L : Finalizable_Ptr) is
410 P : Finalizable_Ptr := L;
413 type Fake_Exception_Occurence is record
416 type Ptr is access all Fake_Exception_Occurence;
418 function To_Ptr is new
419 Unchecked_Conversion (Exception_Occurrence_Access, Ptr);
421 X : Exception_Id := Null_Id;
424 -- If abort is allowed, we get the current exception before starting
425 -- to finalize in order to check if we are in the abort case if an
426 -- exception is raised. When abort is not allowed, avoid accessing the
427 -- current exception since this can be a pretty costly operation in
428 -- programs using controlled types heavily.
430 if System.Restrictions.Abort_Allowed then
431 X := To_Ptr (System.Soft_Links.Get_Current_Excep.all).Id;
441 when E_Occ : others =>
442 Raise_From_Finalize (
444 X = Standard'Abort_Signal'Identity,
452 procedure Finalize_One (Obj : in out Finalizable) is
454 Detach_From_Final_List (Obj);
457 when E_Occ : others => Raise_From_Finalize (null, False, E_Occ);
460 -------------------------
461 -- Get_Deep_Controller --
462 -------------------------
464 function Get_Deep_Controller (Obj : System.Address) return RC_Ptr is
465 The_Tag : Ada.Tags.Tag := To_Finalizable_Ptr (Obj)'Tag;
466 Offset : SSE.Storage_Offset := RC_Offset (The_Tag);
469 -- Fetch the controller from the Parent or above if necessary
470 -- when there are no controller at this level
472 while Offset = -2 loop
473 The_Tag := Parent_Tag (The_Tag);
474 Offset := RC_Offset (The_Tag);
477 -- No Controlled component case
482 -- The _controller Offset is known statically
484 elsif Offset > 0 then
485 return To_RC_Ptr (Obj + Offset);
487 -- At this stage, we know that the controller is part of the
488 -- ancestor corresponding to the tag "The_Tag" and that its parent
489 -- is variable sized. We assume that the _controller is the first
490 -- compoment right after the parent.
492 -- ??? note that it may not be true if there are new discriminants
497 -- define a faked record controller to avoid generating
498 -- unnecessary expanded code for controlled types
500 type Faked_Record_Controller is record
501 Tag, Prec, Next : Address;
504 -- Reconstruction of a type with characteristics
505 -- comparable to the original type
507 D : constant := SSE.Storage_Offset (Storage_Unit - 1);
509 type Parent_Type is new SSE.Storage_Array
510 (1 .. (Parent_Size (Obj, The_Tag) + D) /
511 SSE.Storage_Offset (Storage_Unit));
512 for Parent_Type'Alignment use Address'Alignment;
514 type Faked_Type_Of_Obj is record
515 Parent : Parent_Type;
516 Controller : Faked_Record_Controller;
519 type Obj_Ptr is access all Faked_Type_Of_Obj;
520 function To_Obj_Ptr is
521 new Unchecked_Conversion (Address, Obj_Ptr);
524 return To_RC_Ptr (To_Obj_Ptr (Obj).Controller'Address);
527 end Get_Deep_Controller;
533 procedure Initialize (Object : in out Limited_Record_Controller) is
534 pragma Warnings (Off, Object);
539 procedure Initialize (Object : in out Record_Controller) is
541 Object.My_Address := Object'Address;
544 -------------------------
545 -- Raise_From_Finalize --
546 -------------------------
548 procedure Raise_From_Finalize
549 (L : Finalizable_Ptr;
550 From_Abort : Boolean;
551 E_Occ : Exception_Occurrence)
553 Msg : constant String := Exception_Message (E_Occ);
554 P : Finalizable_Ptr := L;
558 -- We already got an exception. We now finalize the remainder of
559 -- the list, ignoring all further exceptions.
573 -- If finalization from an Abort, then nothing to do
578 -- If no message, then add our own message saying what happened
581 Raise_Exception_No_Defer
582 (E => Program_Error'Identity,
583 Message => "exception " &
584 Exception_Name (E_Occ) &
585 " raised during finalization");
587 -- If there was a message, pass it on
590 Raise_Exception_No_Defer (Program_Error'Identity, Msg);
592 end Raise_From_Finalize;
594 -- Initialization of package, set Adafinal soft link
597 SSL.Adafinal := Finalize_Global_List'Access;
599 end System.Finalization_Implementation;