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 --
11 -- Copyright (C) 1992-2001 Free Software Foundation, Inc. --
13 -- GNAT is free software; you can redistribute it and/or modify it under --
14 -- terms of the GNU General Public License as published by the Free Soft- --
15 -- ware Foundation; either version 2, or (at your option) any later ver- --
16 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
17 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
18 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
19 -- for more details. You should have received a copy of the GNU General --
20 -- Public License distributed with GNAT; see file COPYING. If not, write --
21 -- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
22 -- MA 02111-1307, USA. --
24 -- As a special exception, if other files instantiate generics from this --
25 -- unit, or you link this unit with other files to produce an executable, --
26 -- this unit does not by itself cause the resulting executable to be --
27 -- covered by the GNU General Public License. This exception does not --
28 -- however invalidate any other reasons why the executable file might be --
29 -- covered by the GNU Public License. --
31 -- GNAT was originally developed by the GNAT team at New York University. --
32 -- Extensive contributions were provided by Ada Core Technologies Inc. --
34 ------------------------------------------------------------------------------
38 with Ada
.Unchecked_Conversion
;
39 with System
.Storage_Elements
;
40 with System
.Soft_Links
;
42 package body System
.Finalization_Implementation
is
45 use System
.Finalization_Root
;
47 package SSL
renames System
.Soft_Links
;
49 package SSE
renames System
.Storage_Elements
;
50 use type SSE
.Storage_Offset
;
52 -----------------------
53 -- Local Subprograms --
54 -----------------------
56 function To_Finalizable_Ptr
is
57 new Ada
.Unchecked_Conversion
(Address
, Finalizable_Ptr
);
60 new Ada
.Unchecked_Conversion
(Finalizable_Ptr
, Address
);
62 type RC_Ptr
is access all Record_Controller
;
65 new Ada
.Unchecked_Conversion
(Address
, RC_Ptr
);
67 procedure Raise_Exception_No_Defer
69 Message
: in String := "");
70 pragma Import
(Ada
, Raise_Exception_No_Defer
,
71 "ada__exceptions__raise_exception_no_defer");
72 pragma No_Return
(Raise_Exception_No_Defer
);
73 -- Raise an exception without deferring abort. Note that we have to
74 -- use this rather kludgy Ada Import interface, since this subprogram
75 -- is not available in the visible spec of Ada.Exceptions.
77 procedure Raise_From_Finalize
80 E_Occ
: Exception_Occurrence
);
81 -- Deal with an exception raised during finalization of a list. L is a
82 -- pointer to the list of element not yet finalized. From_Abort is true
83 -- if the finalization actions come from an abort rather than a normal
84 -- exit. E_Occ represents the exception being raised.
86 function RC_Offset
(T
: Ada
.Tags
.Tag
) return SSE
.Storage_Offset
;
87 pragma Import
(Ada
, RC_Offset
, "ada__tags__get_rc_offset");
89 function Parent_Size
(Obj
: Address
) return SSE
.Storage_Count
;
90 pragma Import
(Ada
, Parent_Size
, "ada__tags__parent_size");
92 function Get_RC_Dynamically
(Obj
: Address
) return Address
;
93 -- Given an the address of an object (obj) of a tagged extension with
94 -- controlled component, computes the address of the record controller
95 -- located just after the _parent field
101 procedure Adjust
(Object
: in out Record_Controller
) is
103 First_Comp
: Finalizable_Ptr
;
104 My_Offset
: constant SSE
.Storage_Offset
:=
105 Object
.My_Address
- Object
'Address;
107 procedure Ptr_Adjust
(Ptr
: in out Finalizable_Ptr
);
108 -- Subtract the offset to the pointer
110 procedure Reverse_Adjust
(P
: Finalizable_Ptr
);
111 -- Adjust the components in the reverse order in which they are stored
112 -- on the finalization list. (Adjust and Finalization are not done in
115 procedure Ptr_Adjust
(Ptr
: in out Finalizable_Ptr
) is
118 Ptr
:= To_Finalizable_Ptr
(To_Addr
(Ptr
) - My_Offset
);
122 procedure Reverse_Adjust
(P
: Finalizable_Ptr
) is
126 Reverse_Adjust
(P
.Next
);
128 Object
.F
:= P
; -- Successfully adjusted, so place in list.
132 -- Start of processing for Adjust
135 -- Adjust the components and their finalization pointers next.
136 -- We must protect against an exception in some call to Adjust, so
137 -- we keep pointing to the list of successfully adjusted components,
138 -- which can be finalized if an exception is raised.
140 First_Comp
:= Object
.F
;
141 Object
.F
:= null; -- nothing adjusted yet.
142 Ptr_Adjust
(First_Comp
); -- set addresss of first component.
143 Reverse_Adjust
(First_Comp
);
145 -- Then Adjust the controller itself
147 Object
.My_Address
:= Object
'Address;
151 -- Finalize those components that were successfully adjusted, and
152 -- propagate exception. The object itself is not yet attached to
153 -- global finalization list, so we cannot rely on the outer call
154 -- to Clean to take care of these components.
160 --------------------------
161 -- Attach_To_Final_List --
162 --------------------------
164 procedure Attach_To_Final_List
165 (L
: in out Finalizable_Ptr
;
166 Obj
: in out Finalizable
;
167 Nb_Link
: Short_Short_Integer)
170 -- Simple case: attachement to a one way list
174 L
:= Obj
'Unchecked_Access;
176 -- Dynamically allocated objects: they are attached to a doubly
177 -- linked list, so that an element can be finalized at any moment
178 -- by means of an unchecked deallocation. Attachement is
179 -- protected against multi-threaded access.
181 elsif Nb_Link
= 2 then
183 Locked_Processing
: begin
186 Obj
.Prev
:= L
.Next
.Prev
;
187 L
.Next
.Prev
:= Obj
'Unchecked_Access;
188 L
.Next
:= Obj
'Unchecked_Access;
195 end Locked_Processing
;
197 -- Attachement of arrays to the final list (used only for objects
198 -- returned by function). Obj, in this case is the last element,
199 -- but all other elements are already threaded after it. We just
200 -- attach the rest of the final list at the end of the array list.
202 elsif Nb_Link
= 3 then
204 P
: Finalizable_Ptr
:= Obj
'Unchecked_Access;
207 while P
.Next
/= null loop
212 L
:= Obj
'Unchecked_Access;
216 end Attach_To_Final_List
;
218 ---------------------
219 -- Deep_Tag_Adjust --
220 ---------------------
222 procedure Deep_Tag_Adjust
223 (L
: in out SFR
.Finalizable_Ptr
;
225 B
: Short_Short_Integer)
227 V
: constant SFR
.Finalizable_Ptr
:= To_Finalizable_Ptr
(A
);
228 Offset
: constant SSE
.Storage_Offset
:= RC_Offset
(V
'Tag);
233 -- Has controlled components
237 Controller
:= To_RC_Ptr
(A
+ Offset
);
239 Controller
:= To_RC_Ptr
(Get_RC_Dynamically
(A
));
242 Adjust
(Controller
.all);
243 Attach_To_Final_List
(L
, Controller
.all, B
);
247 elsif V
.all in Finalizable
then
249 Attach_To_Final_List
(L
, Finalizable
(V
.all), 1);
253 ---------------------
254 -- Deep_Tag_Attach --
255 ----------------------
257 procedure Deep_Tag_Attach
258 (L
: in out SFR
.Finalizable_Ptr
;
260 B
: Short_Short_Integer)
262 V
: constant SFR
.Finalizable_Ptr
:= To_Finalizable_Ptr
(A
);
263 Offset
: constant SSE
.Storage_Offset
:= RC_Offset
(V
'Tag);
270 Controller
:= To_RC_Ptr
(A
+ Offset
);
272 Controller
:= To_RC_Ptr
(Get_RC_Dynamically
(A
));
275 Attach_To_Final_List
(L
, Controller
.all, B
);
279 elsif V
.all in Finalizable
then
280 Attach_To_Final_List
(L
, V
.all, B
);
284 -----------------------
285 -- Deep_Tag_Finalize --
286 -----------------------
288 procedure Deep_Tag_Finalize
289 (L
: in out SFR
.Finalizable_Ptr
;
293 V
: constant SFR
.Finalizable_Ptr
:= To_Finalizable_Ptr
(A
);
294 Offset
: constant SSE
.Storage_Offset
:= RC_Offset
(V
'Tag);
299 -- Has controlled components
303 Controller
:= To_RC_Ptr
(A
+ Offset
);
305 Controller
:= To_RC_Ptr
(Get_RC_Dynamically
(A
));
309 Finalize_One
(Controller
.all);
311 Finalize
(Controller
.all);
316 elsif V
.all in Finalizable
then
318 Finalize_One
(V
.all);
323 end Deep_Tag_Finalize
;
325 -------------------------
326 -- Deep_Tag_Initialize --
327 -------------------------
329 procedure Deep_Tag_Initialize
330 (L
: in out SFR
.Finalizable_Ptr
;
332 B
: Short_Short_Integer)
334 V
: constant SFR
.Finalizable_Ptr
:= To_Finalizable_Ptr
(A
);
335 Offset
: constant SSE
.Storage_Offset
:= RC_Offset
(V
'Tag);
340 -- This procedure should not be called if the object has no
341 -- controlled components
347 -- Has controlled components
351 Controller
:= To_RC_Ptr
(A
+ Offset
);
353 Controller
:= To_RC_Ptr
(Get_RC_Dynamically
(A
));
357 Initialize
(Controller
.all);
358 Attach_To_Final_List
(L
, Controller
.all, B
);
362 if V
.all in Finalizable
then
364 Attach_To_Final_List
(Controller
.F
, Finalizable
(Controller
.all), 1);
366 end Deep_Tag_Initialize
;
368 -----------------------------
369 -- Detach_From_Final_List --
370 -----------------------------
372 -- We know that the detach object is neither at the beginning nor at the
373 -- end of the list, thank's to the dummy First and Last Elements but the
374 -- object may not be attached at all if it is Finalize_Storage_Only
376 procedure Detach_From_Final_List
(Obj
: in out Finalizable
) is
379 -- When objects are not properly attached to a doubly linked
380 -- list do not try to detach them. The only case where it can
381 -- happen is when dealing with Finalize_Storage_Only objects
382 -- which are not always attached.
384 if Obj
.Next
/= null and then Obj
.Prev
/= null then
386 Obj
.Next
.Prev
:= Obj
.Prev
;
387 Obj
.Prev
.Next
:= Obj
.Next
;
395 end Detach_From_Final_List
;
401 procedure Finalize
(Object
: in out Limited_Record_Controller
) is
403 Finalize_List
(Object
.F
);
406 --------------------------
407 -- Finalize_Global_List --
408 --------------------------
410 procedure Finalize_Global_List
is
412 -- There are three case here:
413 -- a. the application uses tasks, in which case Finalize_Global_Tasks
414 -- will defer abortion
415 -- b. the application doesn't use tasks but uses other tasking
416 -- constructs, such as ATCs and protected objects. In this case,
417 -- the binder will call Finalize_Global_List instead of
418 -- Finalize_Global_Tasks, letting abort undeferred, and leading
419 -- to assertion failures in the GNULL
420 -- c. the application doesn't use any tasking construct in which case
421 -- deferring abort isn't necessary.
423 -- Until another solution is found to deal with case b, we need to
424 -- call abort_defer here to pass the checks, but we do not need to
425 -- undefer abortion, since Finalize_Global_List is the last procedure
426 -- called before exiting the partition.
429 Finalize_List
(Global_Final_List
);
430 end Finalize_Global_List
;
436 procedure Finalize_List
(L
: Finalizable_Ptr
) is
437 P
: Finalizable_Ptr
:= L
;
440 type Fake_Exception_Occurrence
is record
443 type Ptr
is access all Fake_Exception_Occurrence
;
445 -- Let's get the current exception before starting to finalize in
446 -- order to check if we are in the abort case if an exception is
449 function To_Ptr
is new
450 Ada
.Unchecked_Conversion
(Exception_Occurrence_Access
, Ptr
);
452 To_Ptr
(System
.Soft_Links
.Get_Current_Excep
.all).Id
;
462 when E_Occ
: others =>
463 Raise_From_Finalize
(
465 X
= Standard
'Abort_Signal'Identity,
473 procedure Finalize_One (Obj : in out Finalizable) is
475 Detach_From_Final_List (Obj);
479 when E_Occ : others => Raise_From_Finalize (null, False, E_Occ);
482 ------------------------
483 -- Get_RC_Dynamically --
484 ------------------------
486 function Get_RC_Dynamically (Obj : Address) return Address is
488 -- define a faked record controller to avoid generating
489 -- unnecessary expanded code for controlled types
491 type Faked_Record_Controller is record
492 Tag, Prec, Next : Address;
495 -- Reconstruction of a type with characteristics
496 -- comparable to the original type
498 D : constant := Storage_Unit - 1;
500 type Faked_Type_Of_Obj is record
501 Parent : SSE.Storage_Array
502 (1 .. (Parent_Size (Obj) + D) / Storage_Unit);
503 Controller : Faked_Record_Controller;
506 type Obj_Ptr is access all Faked_Type_Of_Obj;
507 function To_Obj_Ptr is new Ada.Unchecked_Conversion (Address, Obj_Ptr);
510 return To_Obj_Ptr (Obj).Controller'Address;
511 end Get_RC_Dynamically;
517 procedure Initialize (Object : in out Limited_Record_Controller) is
522 procedure Initialize (Object : in out Record_Controller) is
524 Object.My_Address := Object'Address;
527 -------------------------
528 -- Raise_From_Finalize --
529 -------------------------
531 procedure Raise_From_Finalize
532 (L : Finalizable_Ptr;
533 From_Abort : Boolean;
534 E_Occ : Exception_Occurrence)
536 Msg : constant String := Exception_Message (E_Occ);
537 P : Finalizable_Ptr := L;
541 -- We already got an exception. We now finalize the remainder of
542 -- the list, ignoring all further exceptions.
556 -- If finalization from an Abort, then nothing to do
561 -- If no message, then add our own message saying what happened
564 Raise_Exception_No_Defer
565 (E => Program_Error'Identity,
566 Message => "exception " &
567 Exception_Name (E_Occ) &
568 " raised during finalization");
570 -- If there was a message, pass it on
573 Raise_Exception_No_Defer (Program_Error'Identity, Msg);
575 end Raise_From_Finalize;
577 -- Initialization of package, set Adafinal soft link
580 SSL.Adafinal := Finalize_Global_List'Access;
582 end System.Finalization_Implementation;