-- --
-- B o d y --
-- --
--- --
--- Copyright (C) 1992-2001 Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2007, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
-- for more details. You should have received a copy of the GNU General --
-- Public License distributed with GNAT; see file COPYING. If not, write --
--- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
--- MA 02111-1307, USA. --
+-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, --
+-- Boston, MA 02110-1301, USA. --
-- --
-- As a special exception, if other files instantiate generics from this --
-- unit, or you link this unit with other files to produce an executable, --
-- covered by the GNU Public License. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
--- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
with Ada.Exceptions;
with Ada.Tags;
-with Ada.Unchecked_Conversion;
-with System.Storage_Elements;
+
with System.Soft_Links;
+with System.Restrictions;
+
package body System.Finalization_Implementation is
use Ada.Exceptions;
package SSL renames System.Soft_Links;
- package SSE renames System.Storage_Elements;
use type SSE.Storage_Offset;
-----------------------
-- Local Subprograms --
-----------------------
- function To_Finalizable_Ptr is
- new Ada.Unchecked_Conversion (Address, Finalizable_Ptr);
-
- function To_Addr is
- new Ada.Unchecked_Conversion (Finalizable_Ptr, Address);
-
type RC_Ptr is access all Record_Controller;
function To_RC_Ptr is
new Ada.Unchecked_Conversion (Address, RC_Ptr);
- procedure Raise_Exception_No_Defer
- (E : in Exception_Id;
- Message : in String := "");
- pragma Import (Ada, Raise_Exception_No_Defer,
- "ada__exceptions__raise_exception_no_defer");
- pragma No_Return (Raise_Exception_No_Defer);
- -- Raise an exception without deferring abort. Note that we have to
- -- use this rather kludgy Ada Import interface, since this subprogram
- -- is not available in the visible spec of Ada.Exceptions.
+ procedure Raise_From_Controlled_Operation (X : Exception_Occurrence);
+ pragma Import
+ (Ada, Raise_From_Controlled_Operation,
+ "ada__exceptions__raise_from_controlled_operation");
+ pragma No_Return (Raise_From_Controlled_Operation);
+ -- Raise Program_Error from an exception that occurred during an Adjust or
+ -- Finalize operation. We use this rather kludgy Ada Import interface
+ -- because this procedure is not available in the visible part of the
+ -- Ada.Exceptions spec.
procedure Raise_From_Finalize
(L : Finalizable_Ptr;
function RC_Offset (T : Ada.Tags.Tag) return SSE.Storage_Offset;
pragma Import (Ada, RC_Offset, "ada__tags__get_rc_offset");
- function Parent_Size (Obj : Address) return SSE.Storage_Count;
+ function Parent_Size (Obj : Address; T : Ada.Tags.Tag)
+ return SSE.Storage_Count;
pragma Import (Ada, Parent_Size, "ada__tags__parent_size");
- function Get_RC_Dynamically (Obj : Address) return Address;
- -- Given an the address of an object (obj) of a tagged extension with
- -- controlled component, computes the address of the record controller
- -- located just after the _parent field
+ function Get_Deep_Controller (Obj : System.Address) return RC_Ptr;
+ -- Given the address (obj) of a tagged object, return a
+ -- pointer to the record controller of this object.
- -------------
- -- Adjust --
- -------------
+ ------------
+ -- Adjust --
+ ------------
procedure Adjust (Object : in out Record_Controller) is
-- Subtract the offset to the pointer
procedure Reverse_Adjust (P : Finalizable_Ptr);
- -- Adjust the components in the reverse order in which they are stored
+ -- Ajust the components in the reverse order in which they are stored
-- on the finalization list. (Adjust and Finalization are not done in
-- the same order)
+ ----------------
+ -- Ptr_Adjust --
+ ----------------
+
procedure Ptr_Adjust (Ptr : in out Finalizable_Ptr) is
begin
if Ptr /= null then
end if;
end Ptr_Adjust;
+ --------------------
+ -- Reverse_Adjust --
+ --------------------
+
procedure Reverse_Adjust (P : Finalizable_Ptr) is
begin
if P /= null then
-- Start of processing for Adjust
begin
- -- Adjust the components and their finalization pointers next.
- -- We must protect against an exception in some call to Adjust, so
- -- we keep pointing to the list of successfully adjusted components,
- -- which can be finalized if an exception is raised.
+ -- Adjust the components and their finalization pointers next. We must
+ -- protect against an exception in some call to Adjust, so we keep
+ -- pointing to the list of successfully adjusted components, which can
+ -- be finalized if an exception is raised.
First_Comp := Object.F;
Object.F := null; -- nothing adjusted yet.
when others =>
-- Finalize those components that were successfully adjusted, and
-- propagate exception. The object itself is not yet attached to
- -- global finalization list, so we cannot rely on the outer call
- -- to Clean to take care of these components.
+ -- global finalization list, so we cannot rely on the outer call to
+ -- Clean to take care of these components.
Finalize (Object);
raise;
Nb_Link : Short_Short_Integer)
is
begin
- -- Simple case: attachement to a one way list
+ -- Simple case: attachment to a one way list
if Nb_Link = 1 then
Obj.Next := L;
L := Obj'Unchecked_Access;
- -- Dynamically allocated objects: they are attached to a doubly
- -- linked list, so that an element can be finalized at any moment
- -- by means of an unchecked deallocation. Attachement is
- -- protected against multi-threaded access.
+ -- Dynamically allocated objects: they are attached to a doubly linked
+ -- list, so that an element can be finalized at any moment by means of
+ -- an unchecked deallocation. Attachment is protected against
+ -- multi-threaded access.
elsif Nb_Link = 2 then
+ -- Raise Program_Error if we're trying to allocate an object in a
+ -- collection whose finalization has already started.
+
+ if L = Collection_Finalization_Started then
+ raise Program_Error with
+ "allocation after collection finalization started";
+ end if;
+
Locked_Processing : begin
SSL.Lock_Task.all;
Obj.Next := L.Next;
raise;
end Locked_Processing;
- -- Attachement of arrays to the final list (used only for objects
+ -- Attachment of arrays to the final list (used only for objects
-- returned by function). Obj, in this case is the last element,
-- but all other elements are already threaded after it. We just
-- attach the rest of the final list at the end of the array list.
P.Next := L;
L := Obj'Unchecked_Access;
end;
- end if;
-
- end Attach_To_Final_List;
- ---------------------
- -- Deep_Tag_Adjust --
- ---------------------
+ -- Make the object completely unattached (case of a library-level,
+ -- Finalize_Storage_Only object).
- procedure Deep_Tag_Adjust
- (L : in out SFR.Finalizable_Ptr;
- A : System.Address;
- B : Short_Short_Integer)
- is
- V : constant SFR.Finalizable_Ptr := To_Finalizable_Ptr (A);
- Offset : constant SSE.Storage_Offset := RC_Offset (V'Tag);
-
- Controller : RC_Ptr;
-
- begin
- -- Has controlled components
-
- if Offset /= 0 then
- if Offset > 0 then
- Controller := To_RC_Ptr (A + Offset);
- else
- Controller := To_RC_Ptr (Get_RC_Dynamically (A));
- end if;
-
- Adjust (Controller.all);
- Attach_To_Final_List (L, Controller.all, B);
-
- -- Is controlled
-
- elsif V.all in Finalizable then
- Adjust (V.all);
- Attach_To_Final_List (L, Finalizable (V.all), 1);
+ elsif Nb_Link = 4 then
+ Obj.Prev := null;
+ Obj.Next := null;
end if;
- end Deep_Tag_Adjust;
+ end Attach_To_Final_List;
---------------------
-- Deep_Tag_Attach --
A : System.Address;
B : Short_Short_Integer)
is
- V : constant SFR.Finalizable_Ptr := To_Finalizable_Ptr (A);
- Offset : constant SSE.Storage_Offset := RC_Offset (V'Tag);
-
- Controller : RC_Ptr;
+ V : constant SFR.Finalizable_Ptr := To_Finalizable_Ptr (A);
+ Controller : constant RC_Ptr := Get_Deep_Controller (A);
begin
- if Offset /= 0 then
- if Offset > 0 then
- Controller := To_RC_Ptr (A + Offset);
- else
- Controller := To_RC_Ptr (Get_RC_Dynamically (A));
- end if;
-
+ if Controller /= null then
Attach_To_Final_List (L, Controller.all, B);
-
- -- Is controlled
-
- elsif V.all in Finalizable then
- Attach_To_Final_List (L, V.all, B);
end if;
- end Deep_Tag_Attach;
-
- -----------------------
- -- Deep_Tag_Finalize --
- -----------------------
-
- procedure Deep_Tag_Finalize
- (L : in out SFR.Finalizable_Ptr;
- A : System.Address;
- B : Boolean)
- is
- pragma Warnings (Off, L);
-
- V : constant SFR.Finalizable_Ptr := To_Finalizable_Ptr (A);
- Offset : constant SSE.Storage_Offset := RC_Offset (V'Tag);
-
- Controller : RC_Ptr;
-
- begin
- -- Has controlled components
-
- if Offset /= 0 then
- if Offset > 0 then
- Controller := To_RC_Ptr (A + Offset);
- else
- Controller := To_RC_Ptr (Get_RC_Dynamically (A));
- end if;
-
- if B then
- Finalize_One (Controller.all);
- else
- Finalize (Controller.all);
- end if;
-
- -- Is controlled
-
- elsif V.all in Finalizable then
- if B then
- Finalize_One (V.all);
- else
- Finalize (V.all);
- end if;
- end if;
- end Deep_Tag_Finalize;
-
- -------------------------
- -- Deep_Tag_Initialize --
- -------------------------
-
- procedure Deep_Tag_Initialize
- (L : in out SFR.Finalizable_Ptr;
- A : System.Address;
- B : Short_Short_Integer)
- is
- V : constant SFR.Finalizable_Ptr := To_Finalizable_Ptr (A);
- Offset : constant SSE.Storage_Offset := RC_Offset (V'Tag);
-
- Controller : RC_Ptr;
-
- begin
- -- This procedure should not be called if the object has no
- -- controlled components
-
- if Offset = 0 then
-
- raise Program_Error;
-
- -- Has controlled components
-
- else
- if Offset > 0 then
- Controller := To_RC_Ptr (A + Offset);
- else
- Controller := To_RC_Ptr (Get_RC_Dynamically (A));
- end if;
- end if;
-
- Initialize (Controller.all);
- Attach_To_Final_List (L, Controller.all, B);
-- Is controlled
if V.all in Finalizable then
- Initialize (V.all);
- Attach_To_Final_List (Controller.F, Finalizable (Controller.all), 1);
+ Attach_To_Final_List (L, V.all, B);
end if;
- end Deep_Tag_Initialize;
+ end Deep_Tag_Attach;
-----------------------------
-- Detach_From_Final_List --
-----------------------------
-- We know that the detach object is neither at the beginning nor at the
- -- end of the list, thank's to the dummy First and Last Elements but the
+ -- end of the list, thanks to the dummy First and Last Elements, but the
-- object may not be attached at all if it is Finalize_Storage_Only
procedure Detach_From_Final_List (Obj : in out Finalizable) is
begin
- -- When objects are not properly attached to a doubly linked
- -- list do not try to detach them. The only case where it can
- -- happen is when dealing with Finalize_Storage_Only objects
- -- which are not always attached.
+ -- When objects are not properly attached to a doubly linked list do
+ -- not try to detach them. The only case where it can happen is when
+ -- dealing with Finalize_Storage_Only objects which are not always
+ -- attached to the finalization list.
if Obj.Next /= null and then Obj.Prev /= null then
SSL.Lock_Task.all;
Obj.Next.Prev := Obj.Prev;
Obj.Prev.Next := Obj.Next;
+
+ -- Reset the pointers so that a new finalization of the same object
+ -- has no effect on the finalization list.
+
+ Obj.Next := null;
+ Obj.Prev := null;
+
SSL.Unlock_Task.all;
end if;
procedure Finalize_Global_List is
begin
-- There are three case here:
+
-- a. the application uses tasks, in which case Finalize_Global_Tasks
- -- will defer abortion
+ -- will defer abort.
+
-- b. the application doesn't use tasks but uses other tasking
-- constructs, such as ATCs and protected objects. In this case,
-- the binder will call Finalize_Global_List instead of
-- Finalize_Global_Tasks, letting abort undeferred, and leading
-- to assertion failures in the GNULL
+
-- c. the application doesn't use any tasking construct in which case
-- deferring abort isn't necessary.
- --
+
-- Until another solution is found to deal with case b, we need to
-- call abort_defer here to pass the checks, but we do not need to
- -- undefer abortion, since Finalize_Global_List is the last procedure
+ -- undefer abort, since Finalize_Global_List is the last procedure
-- called before exiting the partition.
SSL.Abort_Defer.all;
P : Finalizable_Ptr := L;
Q : Finalizable_Ptr;
- type Fake_Exception_Occurrence is record
+ type Fake_Exception_Occurence is record
Id : Exception_Id;
end record;
- type Ptr is access all Fake_Exception_Occurrence;
-
- -- Let's get the current exception before starting to finalize in
- -- order to check if we are in the abort case if an exception is
- -- raised.
+ type Ptr is access all Fake_Exception_Occurence;
function To_Ptr is new
- Ada.Unchecked_Conversion (Exception_Occurrence_Access, Ptr);
- X : Exception_Id :=
- To_Ptr (System.Soft_Links.Get_Current_Excep.all).Id;
+ Ada.Unchecked_Conversion (Exception_Occurrence_Access, Ptr);
+
+ X : Exception_Id := Null_Id;
begin
+ -- If abort is allowed, we get the current exception before starting
+ -- to finalize in order to check if we are in the abort case if an
+ -- exception is raised. When abort is not allowed, avoid accessing the
+ -- current exception since this can be a pretty costly operation in
+ -- programs using controlled types heavily.
+
+ if System.Restrictions.Abort_Allowed then
+ X := To_Ptr (SSL.Get_Current_Excep.all).Id;
+ end if;
+
while P /= null loop
Q := P.Next;
Finalize (P.all);
begin
Detach_From_Final_List (Obj);
Finalize (Obj);
-
exception
when E_Occ : others => Raise_From_Finalize (null, False, E_Occ);
end Finalize_One;
- ------------------------
- -- Get_RC_Dynamically --
- ------------------------
+ -------------------------
+ -- Get_Deep_Controller --
+ -------------------------
+
+ function Get_Deep_Controller (Obj : System.Address) return RC_Ptr is
+ The_Tag : Ada.Tags.Tag := To_Finalizable_Ptr (Obj)'Tag;
+ Offset : SSE.Storage_Offset := RC_Offset (The_Tag);
- function Get_RC_Dynamically (Obj : Address) return Address is
+ begin
+ -- Fetch the controller from the Parent or above if necessary
+ -- when there are no controller at this level
- -- define a faked record controller to avoid generating
- -- unnecessary expanded code for controlled types
+ while Offset = -2 loop
+ The_Tag := Ada.Tags.Parent_Tag (The_Tag);
+ Offset := RC_Offset (The_Tag);
+ end loop;
- type Faked_Record_Controller is record
- Tag, Prec, Next : Address;
- end record;
+ -- No Controlled component case
- -- Reconstruction of a type with characteristics
- -- comparable to the original type
+ if Offset = 0 then
+ return null;
- D : constant := Storage_Unit - 1;
+ -- The _controller Offset is known statically
- type Faked_Type_Of_Obj is record
- Parent : SSE.Storage_Array
- (1 .. (Parent_Size (Obj) + D) / Storage_Unit);
- Controller : Faked_Record_Controller;
- end record;
+ elsif Offset > 0 then
+ return To_RC_Ptr (Obj + Offset);
- type Obj_Ptr is access all Faked_Type_Of_Obj;
- function To_Obj_Ptr is new Ada.Unchecked_Conversion (Address, Obj_Ptr);
+ -- At this stage, we know that the controller is part of the
+ -- ancestor corresponding to the tag "The_Tag" and that its parent
+ -- is variable sized. We assume that the _controller is the first
+ -- compoment right after the parent.
- begin
- return To_Obj_Ptr (Obj).Controller'Address;
- end Get_RC_Dynamically;
+ -- ??? note that it may not be true if there are new discriminants
+
+ else -- Offset = -1
+
+ declare
+ -- define a faked record controller to avoid generating
+ -- unnecessary expanded code for controlled types
+
+ type Faked_Record_Controller is record
+ Tag, Prec, Next : Address;
+ end record;
+
+ -- Reconstruction of a type with characteristics
+ -- comparable to the original type
+
+ D : constant := SSE.Storage_Offset (Storage_Unit - 1);
+
+ type Parent_Type is new SSE.Storage_Array
+ (1 .. (Parent_Size (Obj, The_Tag) + D) /
+ SSE.Storage_Offset (Storage_Unit));
+ for Parent_Type'Alignment use Address'Alignment;
+
+ type Faked_Type_Of_Obj is record
+ Parent : Parent_Type;
+ Controller : Faked_Record_Controller;
+ end record;
+
+ type Obj_Ptr is access all Faked_Type_Of_Obj;
+ function To_Obj_Ptr is
+ new Ada.Unchecked_Conversion (Address, Obj_Ptr);
+
+ begin
+ return To_RC_Ptr (To_Obj_Ptr (Obj).Controller'Address);
+ end;
+ end if;
+ end Get_Deep_Controller;
----------------
-- Initialize --
procedure Initialize (Object : in out Limited_Record_Controller) is
pragma Warnings (Off, Object);
-
begin
null;
end Initialize;
Object.My_Address := Object'Address;
end Initialize;
+ ---------------------
+ -- Move_Final_List --
+ ---------------------
+
+ procedure Move_Final_List
+ (From : in out SFR.Finalizable_Ptr;
+ To : Finalizable_Ptr_Ptr)
+ is
+ begin
+ -- This is currently called at the end of the return statement, and the
+ -- caller does NOT defer aborts. We need to defer aborts to prevent
+ -- mangling the finalization lists.
+
+ SSL.Abort_Defer.all;
+
+ -- Put the return statement's finalization list onto the caller's one,
+ -- thus transferring responsibility for finalization of the return
+ -- object to the caller.
+
+ Attach_To_Final_List (To.all, From.all, Nb_Link => 3);
+
+ -- Empty the return statement's finalization list, so that when the
+ -- cleanup code executes, there will be nothing to finalize.
+ From := null;
+
+ SSL.Abort_Undefer.all;
+ end Move_Final_List;
+
-------------------------
-- Raise_From_Finalize --
-------------------------
From_Abort : Boolean;
E_Occ : Exception_Occurrence)
is
- Msg : constant String := Exception_Message (E_Occ);
P : Finalizable_Ptr := L;
Q : Finalizable_Ptr;
P := Q;
end loop;
- -- If finalization from an Abort, then nothing to do
-
if From_Abort then
- null;
+ -- If finalization from an Abort, then nothing to do
- -- If no message, then add our own message saying what happened
-
- elsif Msg = "" then
- Raise_Exception_No_Defer
- (E => Program_Error'Identity,
- Message => "exception " &
- Exception_Name (E_Occ) &
- " raised during finalization");
-
- -- If there was a message, pass it on
+ null;
else
- Raise_Exception_No_Defer (Program_Error'Identity, Msg);
+ -- Else raise Program_Error with an appropriate message
+
+ Raise_From_Controlled_Operation (E_Occ);
end if;
end Raise_From_Finalize;
-- Initialization of package, set Adafinal soft link
begin
- SSL.Adafinal := Finalize_Global_List'Access;
+ SSL.Finalize_Global_List := Finalize_Global_List'Access;
end System.Finalization_Implementation;
OSDN Git Service
