URL
https://opencores.org/ocsvn/openrisc_2011-10-31/openrisc_2011-10-31/trunk
Subversion Repositories openrisc_2011-10-31
[/] [openrisc/] [trunk/] [gnu-src/] [gcc-4.5.1/] [gcc/] [ada/] [s-finimp.adb] - Rev 523
Go to most recent revision | Compare with Previous | Blame | View Log
------------------------------------------------------------------------------ -- -- -- 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_Occurence is record Id : Exception_Id; end record; type Ptr is access all Fake_Exception_Occurence; 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;
Go to most recent revision | Compare with Previous | Blame | View Log