diff options
author | Ben Cheng <bccheng@google.com> | 2012-10-01 10:30:31 -0700 |
---|---|---|
committer | Ben Cheng <bccheng@google.com> | 2012-10-01 10:30:31 -0700 |
commit | 82bcbebce43f0227f506d75a5b764b6847041bae (patch) | |
tree | fe9f8597b48a430c4daeb5123e3e8eb28e6f9da9 /gcc-4.7/gcc/ada/s-finmas.adb | |
parent | 3c052de3bb16ac53b6b6ed659ec7557eb84c7590 (diff) | |
download | toolchain_gcc-82bcbebce43f0227f506d75a5b764b6847041bae.tar.gz toolchain_gcc-82bcbebce43f0227f506d75a5b764b6847041bae.tar.bz2 toolchain_gcc-82bcbebce43f0227f506d75a5b764b6847041bae.zip |
Initial check-in of gcc 4.7.2.
Change-Id: I4a2f5a921c21741a0e18bda986d77e5f1bef0365
Diffstat (limited to 'gcc-4.7/gcc/ada/s-finmas.adb')
-rw-r--r-- | gcc-4.7/gcc/ada/s-finmas.adb | 563 |
1 files changed, 563 insertions, 0 deletions
diff --git a/gcc-4.7/gcc/ada/s-finmas.adb b/gcc-4.7/gcc/ada/s-finmas.adb new file mode 100644 index 000000000..918519b67 --- /dev/null +++ b/gcc-4.7/gcc/ada/s-finmas.adb @@ -0,0 +1,563 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; |