Subversion Repositories openrisc

------------------------------------------------------------------------------
--                                                                          --
--                         GNAT COMPILER COMPONENTS                         --
--                                                                          --
--        S Y S T E M . S T O R A G E _ P O O L S . S U B P O O L 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 Ada.Unchecked_Conversion;
with Ada.Unchecked_Deallocation;
with System.Address_Image;
with System.Finalization_Masters; use System.Finalization_Masters;
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.Storage_Pools.Subpools is
 
   Finalize_Address_Table_In_Use : Boolean := False;
   --  This flag should be set only when a successfull allocation on a subpool
   --  has been performed and the associated Finalize_Address has been added to
   --  the hash table in System.Finalization_Masters.
 
   function Address_To_FM_Node_Ptr is
     new Ada.Unchecked_Conversion (Address, FM_Node_Ptr);
 
   procedure Attach (N : not null SP_Node_Ptr; L : not null SP_Node_Ptr);
   --  Attach a subpool node to a pool
 
   procedure Free is new Ada.Unchecked_Deallocation (SP_Node, SP_Node_Ptr);
 
   procedure Detach (N : not null SP_Node_Ptr);
   --  Unhook a subpool node from an arbitrary subpool list
 
   --------------
   -- Allocate --
   --------------
 
   overriding procedure Allocate
     (Pool                     : in out Root_Storage_Pool_With_Subpools;
      Storage_Address          : out System.Address;
      Size_In_Storage_Elements : System.Storage_Elements.Storage_Count;
      Alignment                : System.Storage_Elements.Storage_Count)
   is
   begin
      --  Dispatch to the user-defined implementations of Allocate_From_Subpool
      --  and Default_Subpool_For_Pool.
 
      Allocate_From_Subpool
        (Root_Storage_Pool_With_Subpools'Class (Pool),
         Storage_Address,
         Size_In_Storage_Elements,
         Alignment,
         Default_Subpool_For_Pool
           (Root_Storage_Pool_With_Subpools'Class (Pool)));
   end Allocate;
 
   -----------------------------
   -- Allocate_Any_Controlled --
   -----------------------------
 
   procedure Allocate_Any_Controlled
     (Pool            : in out Root_Storage_Pool'Class;
      Context_Subpool : Subpool_Handle;
      Context_Master  : Finalization_Masters.Finalization_Master_Ptr;
      Fin_Address     : Finalization_Masters.Finalize_Address_Ptr;
      Addr            : out System.Address;
      Storage_Size    : System.Storage_Elements.Storage_Count;
      Alignment       : System.Storage_Elements.Storage_Count;
      Is_Controlled   : Boolean;
      On_Subpool      : Boolean)
   is
      Is_Subpool_Allocation : constant Boolean :=
                                Pool in Root_Storage_Pool_With_Subpools'Class;
 
      Master  : Finalization_Master_Ptr := null;
      N_Addr  : Address;
      N_Ptr   : FM_Node_Ptr;
      N_Size  : Storage_Count;
      Subpool : Subpool_Handle := null;
 
      Allocation_Locked : Boolean;
      --  This flag stores the state of the associated collection
 
      Header_And_Padding : Storage_Offset;
      --  This offset includes the size of a FM_Node plus any additional
      --  padding due to a larger alignment.
 
   begin
      --  Step 1: Pool-related runtime checks
 
      --  Allocation on a pool_with_subpools. In this scenario there is a
      --  master for each subpool. The master of the access type is ignored.
 
      if Is_Subpool_Allocation then
 
         --  Case of an allocation without a Subpool_Handle. Dispatch to the
         --  implementation of Default_Subpool_For_Pool.
 
         if Context_Subpool = null then
            Subpool :=
              Default_Subpool_For_Pool
                (Root_Storage_Pool_With_Subpools'Class (Pool));
 
         --  Allocation with a Subpool_Handle
 
         else
            Subpool := Context_Subpool;
         end if;
 
         --  Ensure proper ownership and chaining of the subpool
 
         if Subpool.Owner /=
              Root_Storage_Pool_With_Subpools'Class (Pool)'Unchecked_Access
           or else Subpool.Node = null
           or else Subpool.Node.Prev = null
           or else Subpool.Node.Next = null
         then
            raise Program_Error with "incorrect owner of subpool";
         end if;
 
         Master := Subpool.Master'Unchecked_Access;
 
      --  Allocation on a simple pool. In this scenario there is a master for
      --  each access-to-controlled type. No context subpool should be present.
 
      else
         --  If the master is missing, then the expansion of the access type
         --  failed to create one. This is a serious error.
 
         if Context_Master = null then
            raise Program_Error
              with "missing master in pool allocation";
 
         --  If a subpool is present, then this is the result of erroneous
         --  allocator expansion. This is not a serious error, but it should
         --  still be detected.
 
         elsif Context_Subpool /= null then
            raise Program_Error
              with "subpool not required in pool allocation";
 
         --  If the allocation is intended to be on a subpool, but the access
         --  type's pool does not support subpools, then this is the result of
         --  erroneous end-user code.
 
         elsif On_Subpool then
            raise Program_Error
              with "pool of access type does not support subpools";
         end if;
 
         Master := Context_Master;
      end if;
 
      --  Step 2: Master, Finalize_Address-related runtime checks and size
      --  calculations.
 
      --  Allocation of a descendant from [Limited_]Controlled, a class-wide
      --  object or a record with controlled components.
 
      if Is_Controlled then
 
         --  Synchronization:
         --    Read  - allocation, finalization
         --    Write - finalization
 
         Lock_Task.all;
         Allocation_Locked := Finalization_Started (Master.all);
         Unlock_Task.all;
 
         --  Do not allow the allocation of controlled objects while the
         --  associated master is being finalized.
 
         if Allocation_Locked then
            raise Program_Error with "allocation after finalization started";
         end if;
 
         --  Check whether primitive Finalize_Address is available. If it is
         --  not, then either the expansion of the designated type failed or
         --  the expansion of the allocator failed. This is a serious error.
 
         if Fin_Address = null then
            raise Program_Error
              with "primitive Finalize_Address not available";
         end if;
 
         --  The size must acount for the hidden header preceding the object.
         --  Account for possible padding space before the header due to a
         --  larger alignment.
 
         Header_And_Padding := Header_Size_With_Padding (Alignment);
 
         N_Size := Storage_Size + Header_And_Padding;
 
      --  Non-controlled allocation
 
      else
         N_Size := Storage_Size;
      end if;
 
      --  Step 3: Allocation of object
 
      --  For descendants of Root_Storage_Pool_With_Subpools, dispatch to the
      --  implementation of Allocate_From_Subpool.
 
      if Is_Subpool_Allocation then
         Allocate_From_Subpool
           (Root_Storage_Pool_With_Subpools'Class (Pool),
            N_Addr, N_Size, Alignment, Subpool);
 
      --  For descendants of Root_Storage_Pool, dispatch to the implementation
      --  of Allocate.
 
      else
         Allocate (Pool, N_Addr, N_Size, Alignment);
      end if;
 
      --  Step 4: Attachment
 
      if Is_Controlled then
         Lock_Task.all;
 
         --  Map the allocated memory into a FM_Node record. This converts the
         --  top of the allocated bits into a list header. If there is padding
         --  due to larger alignment, the header is placed right next to the
         --  object:
 
         --     N_Addr  N_Ptr
         --     |       |
         --     V       V
         --     +-------+---------------+----------------------+
         --     |Padding|    Header     |        Object        |
         --     +-------+---------------+----------------------+
         --     ^       ^               ^
         --     |       +- Header_Size -+
         --     |                       |
         --     +- Header_And_Padding --+
 
         N_Ptr := Address_To_FM_Node_Ptr
                    (N_Addr + Header_And_Padding - Header_Offset);
 
         --  Prepend the allocated object to the finalization master
 
         --  Synchronization:
         --    Write - allocation, deallocation, finalization
 
         Attach_Unprotected (N_Ptr, Objects (Master.all));
 
         --  Move the address from the hidden list header to the start of the
         --  object. This operation effectively hides the list header.
 
         Addr := N_Addr + Header_And_Padding;
 
         --  Homogeneous masters service the following:
 
         --    1) Allocations on / Deallocations from regular pools
         --    2) Named access types
         --    3) Most cases of anonymous access types usage
 
         --  Synchronization:
         --    Read  - allocation, finalization
         --    Write - outside
 
         if Master.Is_Homogeneous then
 
            --  Synchronization:
            --    Read  - finalization
            --    Write - allocation, outside
 
            Set_Finalize_Address_Unprotected (Master.all, Fin_Address);
 
         --  Heterogeneous masters service the following:
 
         --    1) Allocations on / Deallocations from subpools
         --    2) Certain cases of anonymous access types usage
 
         else
            --  Synchronization:
            --    Read  - finalization
            --    Write - allocation, deallocation
 
            Set_Heterogeneous_Finalize_Address_Unprotected (Addr, Fin_Address);
            Finalize_Address_Table_In_Use := True;
         end if;
 
         Unlock_Task.all;
 
      --  Non-controlled allocation
 
      else
         Addr := N_Addr;
      end if;
   end Allocate_Any_Controlled;
 
   ------------
   -- Attach --
   ------------
 
   procedure Attach (N : not null SP_Node_Ptr; L : not null SP_Node_Ptr) is
   begin
      --  Ensure that the node has not been attached already
 
      pragma Assert (N.Prev = null and then N.Next = null);
 
      Lock_Task.all;
 
      L.Next.Prev := N;
      N.Next := L.Next;
      L.Next := N;
      N.Prev := L;
 
      Unlock_Task.all;
 
      --  Note: No need to unlock in case of an exception because the above
      --  code can never raise one.
   end Attach;
 
   -------------------------------
   -- Deallocate_Any_Controlled --
   -------------------------------
 
   procedure Deallocate_Any_Controlled
     (Pool          : in out Root_Storage_Pool'Class;
      Addr          : System.Address;
      Storage_Size  : System.Storage_Elements.Storage_Count;
      Alignment     : System.Storage_Elements.Storage_Count;
      Is_Controlled : Boolean)
   is
      N_Addr : Address;
      N_Ptr  : FM_Node_Ptr;
      N_Size : Storage_Count;
 
      Header_And_Padding : Storage_Offset;
      --  This offset includes the size of a FM_Node plus any additional
      --  padding due to a larger alignment.
 
   begin
      --  Step 1: Detachment
 
      if Is_Controlled then
         Lock_Task.all;
 
         --  Destroy the relation pair object - Finalize_Address since it is no
         --  longer needed.
 
         if Finalize_Address_Table_In_Use then
 
            --  Synchronization:
            --    Read  - finalization
            --    Write - allocation, deallocation
 
            Delete_Finalize_Address_Unprotected (Addr);
         end if;
 
         --  Account for possible padding space before the header due to a
         --  larger alignment.
 
         Header_And_Padding := Header_Size_With_Padding (Alignment);
 
         --    N_Addr  N_Ptr           Addr (from input)
         --    |       |               |
         --    V       V               V
         --    +-------+---------------+----------------------+
         --    |Padding|    Header     |        Object        |
         --    +-------+---------------+----------------------+
         --    ^       ^               ^
         --    |       +- Header_Size -+
         --    |                       |
         --    +- Header_And_Padding --+
 
         --  Convert the bits preceding the object into a list header
 
         N_Ptr := Address_To_FM_Node_Ptr (Addr - Header_Offset);
 
         --  Detach the object from the related finalization master. This
         --  action does not need to know the prior context used during
         --  allocation.
 
         --  Synchronization:
         --    Write - allocation, deallocation, finalization
 
         Detach_Unprotected (N_Ptr);
 
         --  Move the address from the object to the beginning of the list
         --  header.
 
         N_Addr := Addr - Header_And_Padding;
 
         --  The size of the deallocated object must include the size of the
         --  hidden list header.
 
         N_Size := Storage_Size + Header_And_Padding;
 
         Unlock_Task.all;
 
      else
         N_Addr := Addr;
         N_Size := Storage_Size;
      end if;
 
      --  Step 2: Deallocation
 
      --  Dispatch to the proper implementation of Deallocate. This action
      --  covers both Root_Storage_Pool and Root_Storage_Pool_With_Subpools
      --  implementations.
 
      Deallocate (Pool, N_Addr, N_Size, Alignment);
   end Deallocate_Any_Controlled;
 
   ------------------------------
   -- Default_Subpool_For_Pool --
   ------------------------------
 
   function Default_Subpool_For_Pool
     (Pool : Root_Storage_Pool_With_Subpools) return not null Subpool_Handle
   is
   begin
      raise Program_Error;
      return Pool.Subpools.Subpool;
   end Default_Subpool_For_Pool;
 
   ------------
   -- Detach --
   ------------
 
   procedure Detach (N : not null SP_Node_Ptr) is
   begin
      --  Ensure that the node is attached to some list
 
      pragma Assert (N.Next /= null and then N.Prev /= null);
 
      Lock_Task.all;
 
      N.Prev.Next := N.Next;
      N.Next.Prev := N.Prev;
      N.Prev := null;
      N.Next := null;
 
      Unlock_Task.all;
 
      --  Note: No need to unlock in case of an exception because the above
      --  code can never raise one.
   end Detach;
 
   --------------
   -- Finalize --
   --------------
 
   overriding procedure Finalize (Controller : in out Pool_Controller) is
   begin
      Finalize_Pool (Controller.Enclosing_Pool.all);
   end Finalize;
 
   -------------------
   -- Finalize_Pool --
   -------------------
 
   procedure Finalize_Pool (Pool : in out Root_Storage_Pool_With_Subpools) is
      Curr_Ptr : SP_Node_Ptr;
      Ex_Occur : Exception_Occurrence;
      Raised   : Boolean := False;
 
      function Is_Empty_List (L : not null SP_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 SP_Node_Ptr) return Boolean is
      begin
         return L.Next = L and then L.Prev = L;
      end Is_Empty_List;
 
   --  Start of processing for Finalize_Pool
 
   begin
      --  It is possible for multiple tasks to cause the finalization of a
      --  common pool. Allow only one task to finalize the contents.
 
      if Pool.Finalization_Started then
         return;
      end if;
 
      --  Lock the pool to prevent the creation of additional subpools while
      --  the available ones are finalized. The pool remains locked because
      --  either it is about to be deallocated or the associated access type
      --  is about to go out of scope.
 
      Pool.Finalization_Started := True;
 
      while not Is_Empty_List (Pool.Subpools'Unchecked_Access) loop
         Curr_Ptr := Pool.Subpools.Next;
 
         --  Perform the following actions:
 
         --    1) Finalize all objects chained on the subpool's master
         --    2) Remove the the subpool from the owner's list of subpools
         --    3) Deallocate the doubly linked list node associated with the
         --       subpool.
 
         begin
            Finalize_Subpool (Curr_Ptr.Subpool);
 
         exception
            when Fin_Occur : others =>
               if not Raised then
                  Raised := True;
                  Save_Occurrence (Ex_Occur, Fin_Occur);
               end if;
         end;
      end loop;
 
      --  If the finalization of a particular master failed, reraise the
      --  exception now.
 
      if Raised then
         Reraise_Occurrence (Ex_Occur);
      end if;
   end Finalize_Pool;
 
   ----------------------
   -- Finalize_Subpool --
   ----------------------
 
   procedure Finalize_Subpool (Subpool : not null Subpool_Handle) is
   begin
      --  Do nothing if the subpool was never used
 
      if Subpool.Owner = null or else Subpool.Node = null then
         return;
      end if;
 
      --  Clean up all controlled objects chained on the subpool's master
 
      Finalize (Subpool.Master);
 
      --  Remove the subpool from its owner's list of subpools
 
      Detach (Subpool.Node);
 
      --  Destroy the associated doubly linked list node which was created in
      --  Set_Pool_Of_Subpool.
 
      Free (Subpool.Node);
   end Finalize_Subpool;
 
   ------------------------------
   -- Header_Size_With_Padding --
   ------------------------------
 
   function Header_Size_With_Padding
     (Alignment : System.Storage_Elements.Storage_Count)
      return System.Storage_Elements.Storage_Count
   is
      Size : constant Storage_Count := Header_Size;
 
   begin
      if Size mod Alignment = 0 then
         return Size;
 
      --  Add enough padding to reach the nearest multiple of the alignment
      --  rounding up.
 
      else
         return ((Size + Alignment - 1) / Alignment) * Alignment;
      end if;
   end Header_Size_With_Padding;
 
   ----------------
   -- Initialize --
   ----------------
 
   overriding procedure Initialize (Controller : in out Pool_Controller) is
   begin
      Initialize_Pool (Controller.Enclosing_Pool.all);
   end Initialize;
 
   ---------------------
   -- Initialize_Pool --
   ---------------------
 
   procedure Initialize_Pool (Pool : in out Root_Storage_Pool_With_Subpools) is
   begin
      --  The dummy head must point to itself in both directions
 
      Pool.Subpools.Next := Pool.Subpools'Unchecked_Access;
      Pool.Subpools.Prev := Pool.Subpools'Unchecked_Access;
   end Initialize_Pool;
 
   ---------------------
   -- Pool_Of_Subpool --
   ---------------------
 
   function Pool_Of_Subpool
     (Subpool : not null Subpool_Handle)
      return access Root_Storage_Pool_With_Subpools'Class
   is
   begin
      return Subpool.Owner;
   end Pool_Of_Subpool;
 
   ----------------
   -- Print_Pool --
   ----------------
 
   procedure Print_Pool (Pool : Root_Storage_Pool_With_Subpools) is
      Head      : constant SP_Node_Ptr := Pool.Subpools'Unrestricted_Access;
      Head_Seen : Boolean := False;
      SP_Ptr    : SP_Node_Ptr;
 
   begin
      --  Output the contents of the pool
 
      --    Pool      : 0x123456789
      --    Subpools  : 0x123456789
      --    Fin_Start : TRUE <or> FALSE
      --    Controller: OK <or> NOK
 
      Put ("Pool      : ");
      Put_Line (Address_Image (Pool'Address));
 
      Put ("Subpools  : ");
      Put_Line (Address_Image (Pool.Subpools'Address));
 
      Put ("Fin_Start : ");
      Put_Line (Pool.Finalization_Started'Img);
 
      Put ("Controlled: ");
      if Pool.Controller.Enclosing_Pool = Pool'Unrestricted_Access then
         Put_Line ("OK");
      else
         Put_Line ("NOK (ERROR)");
      end if;
 
      SP_Ptr := Head;
      while SP_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 SP_Ptr = Head then
            exit when Head_Seen;
 
            Head_Seen := True;
         end if;
 
         --  The current element is null. This should never happend since the
         --  list is circular.
 
         if SP_Ptr.Prev = null then
            Put_Line ("null (ERROR)");
 
         --  The current element points back to the correct element
 
         elsif SP_Ptr.Prev.Next = SP_Ptr then
            Put_Line ("^");
 
         --  The current element points to an erroneous element
 
         else
            Put_Line ("? (ERROR)");
         end if;
 
         --  Output the contents of the node
 
         Put ("|Header: ");
         Put (Address_Image (SP_Ptr.all'Address));
         if SP_Ptr = Head then
            Put_Line (" (dummy head)");
         else
            Put_Line ("");
         end if;
 
         Put ("|  Prev: ");
 
         if SP_Ptr.Prev = null then
            Put_Line ("null");
         else
            Put_Line (Address_Image (SP_Ptr.Prev.all'Address));
         end if;
 
         Put ("|  Next: ");
 
         if SP_Ptr.Next = null then
            Put_Line ("null");
         else
            Put_Line (Address_Image (SP_Ptr.Next.all'Address));
         end if;
 
         Put ("|  Subp: ");
 
         if SP_Ptr.Subpool = null then
            Put_Line ("null");
         else
            Put_Line (Address_Image (SP_Ptr.Subpool.all'Address));
         end if;
 
         SP_Ptr := SP_Ptr.Next;
      end loop;
   end Print_Pool;
 
   -------------------
   -- Print_Subpool --
   -------------------
 
   procedure Print_Subpool (Subpool : Subpool_Handle) is
   begin
      if Subpool = null then
         Put_Line ("null");
         return;
      end if;
 
      --  Output the contents of a subpool
 
      --    Owner : 0x123456789
      --    Master: 0x123456789
      --    Node  : 0x123456789
 
      Put ("Owner : ");
      if Subpool.Owner = null then
         Put_Line ("null");
      else
         Put_Line (Address_Image (Subpool.Owner'Address));
      end if;
 
      Put ("Master: ");
      Put_Line (Address_Image (Subpool.Master'Address));
 
      Put ("Node  : ");
      if Subpool.Node = null then
         Put ("null");
 
         if Subpool.Owner = null then
            Put_Line (" OK");
         else
            Put_Line (" (ERROR)");
         end if;
      else
         Put_Line (Address_Image (Subpool.Node'Address));
      end if;
 
      Print_Master (Subpool.Master);
   end Print_Subpool;
 
   -------------------------
   -- Set_Pool_Of_Subpool --
   -------------------------
 
   procedure Set_Pool_Of_Subpool
     (Subpool : not null Subpool_Handle;
      To      : in out Root_Storage_Pool_With_Subpools'Class)
   is
      N_Ptr : SP_Node_Ptr;
 
   begin
      --  If the subpool is already owned, raise Program_Error. This is a
      --  direct violation of the RM rules.
 
      if Subpool.Owner /= null then
         raise Program_Error with "subpool already belongs to a pool";
      end if;
 
      --  Prevent the creation of a new subpool while the owner is being
      --  finalized. This is a serious error.
 
      if To.Finalization_Started then
         raise Program_Error
           with "subpool creation after finalization started";
      end if;
 
      Subpool.Owner := To'Unchecked_Access;
 
      --  Create a subpool node and decorate it. Since this node is not
      --  allocated on the owner's pool, it must be explicitly destroyed by
      --  Finalize_And_Detach.
 
      N_Ptr := new SP_Node;
      N_Ptr.Subpool := Subpool;
      Subpool.Node := N_Ptr;
 
      Attach (N_Ptr, To.Subpools'Unchecked_Access);
 
      --  Mark the subpool's master as being a heterogeneous collection of
      --  controlled objects.
 
      Set_Is_Heterogeneous (Subpool.Master);
   end Set_Pool_Of_Subpool;
 
end System.Storage_Pools.Subpools;