Subversion Repositories openrisc

------------------------------------------------------------------------------

--                                                                          --

--                         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;