URL
https://opencores.org/ocsvn/openrisc/openrisc/trunk
Subversion Repositories openrisc
[/] [openrisc/] [trunk/] [gnu-dev/] [or1k-gcc/] [gcc/] [ada/] [s-finmas.adb] - Rev 848
Go to most recent revision | Compare with Previous | Blame | View Log
------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- S Y S T E M . F I N A L I Z A T I O N _ M A S T E R S -- -- -- -- B o d y -- -- -- -- Copyright (C) 2011, 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; use Ada.Exceptions; with System.Address_Image; with System.HTable; use System.HTable; with System.IO; use System.IO; with System.Soft_Links; use System.Soft_Links; with System.Storage_Elements; use System.Storage_Elements; package body System.Finalization_Masters is -- Finalize_Address hash table types. In general, masters are homogeneous -- collections of controlled objects. Rare cases such as allocations on a -- subpool require heterogeneous masters. The following table provides a -- relation between object address and its Finalize_Address routine. type Header_Num is range 0 .. 127; function Hash (Key : System.Address) return Header_Num; -- Address --> Finalize_Address_Ptr package Finalize_Address_Table is new Simple_HTable (Header_Num => Header_Num, Element => Finalize_Address_Ptr, No_Element => null, Key => System.Address, Hash => Hash, Equal => "="); --------------------------- -- Add_Offset_To_Address -- --------------------------- function Add_Offset_To_Address (Addr : System.Address; Offset : System.Storage_Elements.Storage_Offset) return System.Address is begin return System.Storage_Elements."+" (Addr, Offset); end Add_Offset_To_Address; ------------ -- Attach -- ------------ procedure Attach (N : not null FM_Node_Ptr; L : not null FM_Node_Ptr) is begin Lock_Task.all; Attach_Unprotected (N, L); Unlock_Task.all; -- Note: No need to unlock in case of an exception because the above -- code can never raise one. end Attach; ------------------------ -- Attach_Unprotected -- ------------------------ procedure Attach_Unprotected (N : not null FM_Node_Ptr; L : not null FM_Node_Ptr) is begin L.Next.Prev := N; N.Next := L.Next; L.Next := N; N.Prev := L; end Attach_Unprotected; --------------- -- Base_Pool -- --------------- function Base_Pool (Master : Finalization_Master) return Any_Storage_Pool_Ptr is begin return Master.Base_Pool; end Base_Pool; ----------------------------------------- -- Delete_Finalize_Address_Unprotected -- ----------------------------------------- procedure Delete_Finalize_Address_Unprotected (Obj : System.Address) is begin Finalize_Address_Table.Remove (Obj); end Delete_Finalize_Address_Unprotected; ------------ -- Detach -- ------------ procedure Detach (N : not null FM_Node_Ptr) is begin Lock_Task.all; Detach_Unprotected (N); Unlock_Task.all; -- Note: No need to unlock in case of an exception because the above -- code can never raise one. end Detach; ------------------------ -- Detach_Unprotected -- ------------------------ procedure Detach_Unprotected (N : not null FM_Node_Ptr) is begin if N.Prev /= null and then N.Next /= null then N.Prev.Next := N.Next; N.Next.Prev := N.Prev; N.Prev := null; N.Next := null; end if; end Detach_Unprotected; -------------- -- Finalize -- -------------- overriding procedure Finalize (Master : in out Finalization_Master) is Cleanup : Finalize_Address_Ptr; Curr_Ptr : FM_Node_Ptr; Ex_Occur : Exception_Occurrence; Obj_Addr : Address; Raised : Boolean := False; function Is_Empty_List (L : not null FM_Node_Ptr) return Boolean; -- Determine whether a list contains only one element, the dummy head ------------------- -- Is_Empty_List -- ------------------- function Is_Empty_List (L : not null FM_Node_Ptr) return Boolean is begin return L.Next = L and then L.Prev = L; end Is_Empty_List; -- Start of processing for Finalize begin Lock_Task.all; -- Synchronization: -- Read - allocation, finalization -- Write - finalization if Master.Finalization_Started then Unlock_Task.all; -- Double finalization may occur during the handling of stand alone -- libraries or the finalization of a pool with subpools. Due to the -- potential aliasing of masters in these two cases, do not process -- the same master twice. return; end if; -- Lock the master to prevent any allocations while the objects are -- being finalized. The master remains locked because either the master -- is explicitly deallocated or the associated access type is about to -- go out of scope. -- Synchronization: -- Read - allocation, finalization -- Write - finalization Master.Finalization_Started := True; while not Is_Empty_List (Master.Objects'Unchecked_Access) loop Curr_Ptr := Master.Objects.Next; -- Synchronization: -- Write - allocation, deallocation, finalization Detach_Unprotected (Curr_Ptr); -- Skip the list header in order to offer proper object layout for -- finalization. Obj_Addr := Curr_Ptr.all'Address + Header_Offset; -- Retrieve TSS primitive Finalize_Address depending on the master's -- mode of operation. -- Synchronization: -- Read - allocation, finalization -- Write - outside if Master.Is_Homogeneous then -- Synchronization: -- Read - finalization -- Write - allocation, outside Cleanup := Master.Finalize_Address; else -- Synchronization: -- Read - finalization -- Write - allocation, deallocation Cleanup := Finalize_Address_Unprotected (Obj_Addr); end if; begin Cleanup (Obj_Addr); exception when Fin_Occur : others => if not Raised then Raised := True; Save_Occurrence (Ex_Occur, Fin_Occur); end if; end; -- When the master is a heterogeneous collection, destroy the object -- - Finalize_Address pair since it is no longer needed. -- Synchronization: -- Read - finalization -- Write - outside if not Master.Is_Homogeneous then -- Synchronization: -- Read - finalization -- Write - allocation, deallocation, finalization Delete_Finalize_Address_Unprotected (Obj_Addr); end if; end loop; Unlock_Task.all; -- If the finalization of a particular object failed or Finalize_Address -- was not set, reraise the exception now. if Raised then Reraise_Occurrence (Ex_Occur); end if; end Finalize; ---------------------- -- Finalize_Address -- ---------------------- function Finalize_Address (Master : Finalization_Master) return Finalize_Address_Ptr is begin return Master.Finalize_Address; end Finalize_Address; ---------------------------------- -- Finalize_Address_Unprotected -- ---------------------------------- function Finalize_Address_Unprotected (Obj : System.Address) return Finalize_Address_Ptr is begin return Finalize_Address_Table.Get (Obj); end Finalize_Address_Unprotected; -------------------------- -- Finalization_Started -- -------------------------- function Finalization_Started (Master : Finalization_Master) return Boolean is begin return Master.Finalization_Started; end Finalization_Started; ---------- -- Hash -- ---------- function Hash (Key : System.Address) return Header_Num is begin return Header_Num (To_Integer (Key) mod Integer_Address (Header_Num'Range_Length)); end Hash; ----------------- -- Header_Size -- ----------------- function Header_Size return System.Storage_Elements.Storage_Count is begin return FM_Node'Size / Storage_Unit; end Header_Size; ------------------- -- Header_Offset -- ------------------- function Header_Offset return System.Storage_Elements.Storage_Offset is begin return FM_Node'Size / Storage_Unit; end Header_Offset; ---------------- -- Initialize -- ---------------- overriding procedure Initialize (Master : in out Finalization_Master) is begin -- The dummy head must point to itself in both directions Master.Objects.Next := Master.Objects'Unchecked_Access; Master.Objects.Prev := Master.Objects'Unchecked_Access; end Initialize; -------------------- -- Is_Homogeneous -- -------------------- function Is_Homogeneous (Master : Finalization_Master) return Boolean is begin return Master.Is_Homogeneous; end Is_Homogeneous; ------------- -- Objects -- ------------- function Objects (Master : Finalization_Master) return FM_Node_Ptr is begin return Master.Objects'Unrestricted_Access; end Objects; ------------------ -- Print_Master -- ------------------ procedure Print_Master (Master : Finalization_Master) is Head : constant FM_Node_Ptr := Master.Objects'Unrestricted_Access; Head_Seen : Boolean := False; N_Ptr : FM_Node_Ptr; begin -- Output the basic contents of a master -- Master : 0x123456789 -- Is_Hmgen : TURE <or> FALSE -- Base_Pool: null <or> 0x123456789 -- Fin_Addr : null <or> 0x123456789 -- Fin_Start: TRUE <or> FALSE Put ("Master : "); Put_Line (Address_Image (Master'Address)); Put ("Is_Hmgen : "); Put_Line (Master.Is_Homogeneous'Img); Put ("Base_Pool: "); if Master.Base_Pool = null then Put_Line ("null"); else Put_Line (Address_Image (Master.Base_Pool'Address)); end if; Put ("Fin_Addr : "); if Master.Finalize_Address = null then Put_Line ("null"); else Put_Line (Address_Image (Master.Finalize_Address'Address)); end if; Put ("Fin_Start: "); Put_Line (Master.Finalization_Started'Img); -- Output all chained elements. The format is the following: -- ^ <or> ? <or> null -- |Header: 0x123456789 (dummy head) -- | Prev: 0x123456789 -- | Next: 0x123456789 -- V -- ^ - the current element points back to the correct element -- ? - the current element points back to an erroneous element -- n - the current element points back to null -- Header - the address of the list header -- Prev - the address of the list header which the current element -- points back to -- Next - the address of the list header which the current element -- points to -- (dummy head) - present if dummy head N_Ptr := Head; while N_Ptr /= null loop -- Should never be null Put_Line ("V"); -- We see the head initially; we want to exit when we see the head a -- second time. if N_Ptr = Head then exit when Head_Seen; Head_Seen := True; end if; -- The current element is null. This should never happen since the -- list is circular. if N_Ptr.Prev = null then Put_Line ("null (ERROR)"); -- The current element points back to the correct element elsif N_Ptr.Prev.Next = N_Ptr then Put_Line ("^"); -- The current element points to an erroneous element else Put_Line ("? (ERROR)"); end if; -- Output the header and fields Put ("|Header: "); Put (Address_Image (N_Ptr.all'Address)); -- Detect the dummy head if N_Ptr = Head then Put_Line (" (dummy head)"); else Put_Line (""); end if; Put ("| Prev: "); if N_Ptr.Prev = null then Put_Line ("null"); else Put_Line (Address_Image (N_Ptr.Prev.all'Address)); end if; Put ("| Next: "); if N_Ptr.Next = null then Put_Line ("null"); else Put_Line (Address_Image (N_Ptr.Next.all'Address)); end if; N_Ptr := N_Ptr.Next; end loop; end Print_Master; ------------------- -- Set_Base_Pool -- ------------------- procedure Set_Base_Pool (Master : in out Finalization_Master; Pool_Ptr : Any_Storage_Pool_Ptr) is begin Master.Base_Pool := Pool_Ptr; end Set_Base_Pool; -------------------------- -- Set_Finalize_Address -- -------------------------- procedure Set_Finalize_Address (Master : in out Finalization_Master; Fin_Addr_Ptr : Finalize_Address_Ptr) is begin -- Synchronization: -- Read - finalization -- Write - allocation, outside Lock_Task.all; Set_Finalize_Address_Unprotected (Master, Fin_Addr_Ptr); Unlock_Task.all; end Set_Finalize_Address; -------------------------------------- -- Set_Finalize_Address_Unprotected -- -------------------------------------- procedure Set_Finalize_Address_Unprotected (Master : in out Finalization_Master; Fin_Addr_Ptr : Finalize_Address_Ptr) is begin if Master.Finalize_Address = null then Master.Finalize_Address := Fin_Addr_Ptr; end if; end Set_Finalize_Address_Unprotected; ---------------------------------------------------- -- Set_Heterogeneous_Finalize_Address_Unprotected -- ---------------------------------------------------- procedure Set_Heterogeneous_Finalize_Address_Unprotected (Obj : System.Address; Fin_Addr_Ptr : Finalize_Address_Ptr) is begin Finalize_Address_Table.Set (Obj, Fin_Addr_Ptr); end Set_Heterogeneous_Finalize_Address_Unprotected; -------------------------- -- Set_Is_Heterogeneous -- -------------------------- procedure Set_Is_Heterogeneous (Master : in out Finalization_Master) is begin -- Synchronization: -- Read - finalization -- Write - outside Lock_Task.all; Master.Is_Homogeneous := False; Unlock_Task.all; end Set_Is_Heterogeneous; end System.Finalization_Masters;
Go to most recent revision | Compare with Previous | Blame | View Log