diff options
Diffstat (limited to 'gcc/ada/s-finimp.adb')
| -rw-r--r-- | gcc/ada/s-finimp.adb | 540 |
1 files changed, 0 insertions, 540 deletions
diff --git a/gcc/ada/s-finimp.adb b/gcc/ada/s-finimp.adb deleted file mode 100644 index 050f79995ec..00000000000 --- a/gcc/ada/s-finimp.adb +++ /dev/null @@ -1,540 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- 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; |