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;