aboutsummaryrefslogtreecommitdiffstats
path: root/gcc-4.8.3/gcc/ada/s-finmas.adb
diff options
context:
space:
mode:
Diffstat (limited to 'gcc-4.8.3/gcc/ada/s-finmas.adb')
-rw-r--r--gcc-4.8.3/gcc/ada/s-finmas.adb563
1 files changed, 563 insertions, 0 deletions
diff --git a/gcc-4.8.3/gcc/ada/s-finmas.adb b/gcc-4.8.3/gcc/ada/s-finmas.adb
new file mode 100644
index 000000000..918519b67
--- /dev/null
+++ b/gcc-4.8.3/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;