diff options
Diffstat (limited to 'gcc/ada/s-finimp.adb')
| -rw-r--r-- | gcc/ada/s-finimp.adb | 540 |
1 files changed, 540 insertions, 0 deletions
diff --git a/gcc/ada/s-finimp.adb b/gcc/ada/s-finimp.adb new file mode 100644 index 000000000..050f79995 --- /dev/null +++ b/gcc/ada/s-finimp.adb @@ -0,0 +1,540 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- 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 -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2009, 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- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- <http://www.gnu.org/licenses/>. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Exceptions; +with Ada.Tags; + +with System.Soft_Links; + +with System.Restrictions; + +package body System.Finalization_Implementation is + + use Ada.Exceptions; + use System.Finalization_Root; + + package SSL renames System.Soft_Links; + + use type SSE.Storage_Offset; + + ----------------------- + -- Local Subprograms -- + ----------------------- + + type RC_Ptr is access all Record_Controller; + + function To_RC_Ptr is + new Ada.Unchecked_Conversion (Address, RC_Ptr); + + 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; + From_Abort : Boolean; + E_Occ : Exception_Occurrence); + -- Deal with an exception raised during finalization of a list. L is a + -- pointer to the list of element not yet finalized. From_Abort is true + -- if the finalization actions come from an abort rather than a normal + -- exit. E_Occ represents the exception being raised. + + 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; T : Ada.Tags.Tag) + return SSE.Storage_Count; + pragma Import (Ada, Parent_Size, "ada__tags__parent_size"); + + 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 -- + ------------ + + overriding procedure Adjust (Object : in out Record_Controller) is + + First_Comp : Finalizable_Ptr; + My_Offset : constant SSE.Storage_Offset := + Object.My_Address - Object'Address; + + procedure Ptr_Adjust (Ptr : in out Finalizable_Ptr); + -- Subtract the offset to the pointer + + procedure Reverse_Adjust (P : Finalizable_Ptr); + -- Adjust 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 + Ptr := To_Finalizable_Ptr (To_Addr (Ptr) - My_Offset); + end if; + end Ptr_Adjust; + + -------------------- + -- Reverse_Adjust -- + -------------------- + + procedure Reverse_Adjust (P : Finalizable_Ptr) is + begin + if P /= null then + Ptr_Adjust (P.Next); + Reverse_Adjust (P.Next); + Adjust (P.all); + Object.F := P; -- Successfully adjusted, so place in list + end if; + end Reverse_Adjust; + + -- 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. + + First_Comp := Object.F; + Object.F := null; -- nothing adjusted yet. + Ptr_Adjust (First_Comp); -- set address of first component. + Reverse_Adjust (First_Comp); + + -- Then Adjust the controller itself + + Object.My_Address := Object'Address; + + exception + 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. + + Finalize (Object); + raise; + end Adjust; + + -------------------------- + -- Attach_To_Final_List -- + -------------------------- + + procedure Attach_To_Final_List + (L : in out Finalizable_Ptr; + Obj : in out Finalizable; + Nb_Link : Short_Short_Integer) + is + begin + -- 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. 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; + Obj.Prev := L.Next.Prev; + L.Next.Prev := Obj'Unchecked_Access; + L.Next := Obj'Unchecked_Access; + SSL.Unlock_Task.all; + + exception + when others => + SSL.Unlock_Task.all; + raise; + end Locked_Processing; + + -- 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. + + elsif Nb_Link = 3 then + declare + P : Finalizable_Ptr := Obj'Unchecked_Access; + + begin + while P.Next /= null loop + P := P.Next; + end loop; + + P.Next := L; + L := Obj'Unchecked_Access; + end; + + -- Make the object completely unattached (case of a library-level, + -- Finalize_Storage_Only object). + + elsif Nb_Link = 4 then + Obj.Prev := null; + Obj.Next := null; + end if; + end Attach_To_Final_List; + + --------------------- + -- Deep_Tag_Attach -- + ---------------------- + + procedure Deep_Tag_Attach + (L : in out SFR.Finalizable_Ptr; + A : System.Address; + B : Short_Short_Integer) + is + V : constant SFR.Finalizable_Ptr := To_Finalizable_Ptr (A); + Controller : constant RC_Ptr := Get_Deep_Controller (A); + + begin + if Controller /= null then + Attach_To_Final_List (L, Controller.all, B); + end if; + + -- Is controlled + + if V.all in Finalizable then + Attach_To_Final_List (L, V.all, B); + end if; + 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, 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 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; + + exception + when others => + SSL.Unlock_Task.all; + raise; + end Detach_From_Final_List; + + -------------- + -- Finalize -- + -------------- + + overriding procedure Finalize (Object : in out Limited_Record_Controller) is + begin + Finalize_List (Object.F); + end Finalize; + + -------------------------- + -- Finalize_Global_List -- + -------------------------- + + procedure Finalize_Global_List is + begin + -- There are three case here: + + -- a. the application uses tasks, in which case Finalize_Global_Tasks + -- 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 abort, since Finalize_Global_List is the last procedure + -- called before exiting the partition. + + SSL.Abort_Defer.all; + Finalize_List (Global_Final_List); + end Finalize_Global_List; + + ------------------- + -- Finalize_List -- + ------------------- + + procedure Finalize_List (L : Finalizable_Ptr) is + P : Finalizable_Ptr := L; + Q : Finalizable_Ptr; + + type Fake_Exception_Occurrence is record + Id : Exception_Id; + end record; + type Ptr is access all Fake_Exception_Occurrence; + + function To_Ptr is new + 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); + P := Q; + end loop; + + exception + when E_Occ : others => + Raise_From_Finalize ( + Q, + X = Standard'Abort_Signal'Identity, + E_Occ); + end Finalize_List; + + ------------------ + -- Finalize_One -- + ------------------ + + procedure Finalize_One (Obj : in out Finalizable) is + begin + Detach_From_Final_List (Obj); + Finalize (Obj); + exception + when E_Occ : others => Raise_From_Finalize (null, False, E_Occ); + end Finalize_One; + + ------------------------- + -- 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); + + begin + -- Fetch the controller from the Parent or above if necessary + -- when there are no controller at this level. + + while Offset = -2 loop + The_Tag := Ada.Tags.Parent_Tag (The_Tag); + Offset := RC_Offset (The_Tag); + end loop; + + -- No Controlled component case + + if Offset = 0 then + return null; + + -- The _controller Offset is known statically + + elsif Offset > 0 then + return To_RC_Ptr (Obj + Offset); + + -- 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 + -- component right after the parent. + + -- ??? 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 -- + ---------------- + + overriding procedure Initialize + (Object : in out Limited_Record_Controller) + is + pragma Warnings (Off, Object); + begin + null; + end Initialize; + + overriding procedure Initialize (Object : in out Record_Controller) is + begin + 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 -- + ------------------------- + + procedure Raise_From_Finalize + (L : Finalizable_Ptr; + From_Abort : Boolean; + E_Occ : Exception_Occurrence) + is + P : Finalizable_Ptr := L; + Q : Finalizable_Ptr; + + begin + -- We already got an exception. We now finalize the remainder of + -- the list, ignoring all further exceptions. + + while P /= null loop + Q := P.Next; + + begin + Finalize (P.all); + exception + when others => null; + end; + + P := Q; + end loop; + + if From_Abort then + -- If finalization from an Abort, then nothing to do + + null; + + else + -- 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.Finalize_Global_List := Finalize_Global_List'Access; +end System.Finalization_Implementation; |