Subversion Repositories openrisc_me

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

--                                                                          --

--                         GNAT RUN-TIME COMPONENTS                         --

--                                                                          --

--                     S Y S T E M . P O O L _ S I Z E                      --

--                                                                          --

--                                 B o d y                                  --

--                                                                          --

--          Copyright (C) 1992-2009, 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 System.Soft_Links;

with Ada.Unchecked_Conversion;

package body System.Pool_Size is

   package SSE renames System.Storage_Elements;

   use type SSE.Storage_Offset;

   --  Even though these storage pools are typically only used by a single

   --  task, if multiple tasks are declared at the same or a more nested scope

   --  as the storage pool, there still may be concurrent access. The current

   --  implementation of Stack_Bounded_Pool always uses a global lock for

   --  protecting access. This should eventually be replaced by an atomic

   --  linked list implementation for efficiency reasons.

   package SSL renames System.Soft_Links;

   type Storage_Count_Access is access SSE.Storage_Count;

   function To_Storage_Count_Access is

     new Ada.Unchecked_Conversion (Address, Storage_Count_Access);

   SC_Size : constant :=  SSE.Storage_Count'Object_Size / System.Storage_Unit;

   package Variable_Size_Management is

      --  Embedded pool that manages allocation of variable-size data

      --  This pool is used as soon as the Elmt_Size of the pool object is 0

      --  Allocation is done on the first chunk long enough for the request.

      --  Deallocation just puts the freed chunk at the beginning of the list.

      procedure Initialize  (Pool : in out Stack_Bounded_Pool);

      procedure Allocate

        (Pool         : in out Stack_Bounded_Pool;

         Address      : out System.Address;

         Storage_Size : SSE.Storage_Count;

         Alignment    : SSE.Storage_Count);

      procedure Deallocate

        (Pool         : in out Stack_Bounded_Pool;

         Address      : System.Address;

         Storage_Size : SSE.Storage_Count;

         Alignment    : SSE.Storage_Count);

   end Variable_Size_Management;

   package Vsize renames Variable_Size_Management;

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

   -- Allocate --

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

   procedure Allocate

     (Pool         : in out Stack_Bounded_Pool;

      Address      : out System.Address;

      Storage_Size : SSE.Storage_Count;

      Alignment    : SSE.Storage_Count)

   is

   begin

      SSL.Lock_Task.all;

      if Pool.Elmt_Size = 0 then

         Vsize.Allocate (Pool, Address, Storage_Size, Alignment);

      elsif Pool.First_Free /= 0 then

         Address := Pool.The_Pool (Pool.First_Free)'Address;

         Pool.First_Free := To_Storage_Count_Access (Address).all;

      elsif

        Pool.First_Empty <= (Pool.Pool_Size - Pool.Aligned_Elmt_Size + 1)

      then

         Address := Pool.The_Pool (Pool.First_Empty)'Address;

         Pool.First_Empty := Pool.First_Empty + Pool.Aligned_Elmt_Size;

      else

         raise Storage_Error;

      end if;

      SSL.Unlock_Task.all;

   exception

      when others =>

         SSL.Unlock_Task.all;

         raise;

   end Allocate;

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

   -- Deallocate --

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

   procedure Deallocate

     (Pool         : in out Stack_Bounded_Pool;

      Address      : System.Address;

      Storage_Size : SSE.Storage_Count;

      Alignment    : SSE.Storage_Count)

   is

   begin

      SSL.Lock_Task.all;

      if Pool.Elmt_Size = 0 then

         Vsize.Deallocate (Pool, Address, Storage_Size, Alignment);

      else

         To_Storage_Count_Access (Address).all := Pool.First_Free;

         Pool.First_Free := Address - Pool.The_Pool'Address + 1;

      end if;

      SSL.Unlock_Task.all;

   exception

      when others =>

         SSL.Unlock_Task.all;

         raise;

   end Deallocate;

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

   -- Initialize --

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

   procedure Initialize  (Pool : in out Stack_Bounded_Pool) is

      --  Define the appropriate alignment for allocations. This is the

      --  maximum of the requested alignment, and the alignment required

      --  for Storage_Count values. The latter test is to ensure that we

      --  can properly reference the linked list pointers for free lists.

      Align : constant SSE.Storage_Count :=

                SSE.Storage_Count'Max

                  (SSE.Storage_Count'Alignment, Pool.Alignment);

   begin

      if Pool.Elmt_Size = 0 then

         Vsize.Initialize (Pool);

      else

         Pool.First_Free := 0;

         Pool.First_Empty := 1;

         --  Compute the size to allocate given the size of the element and

         --  the possible alignment requirement as defined above.

         Pool.Aligned_Elmt_Size :=

           SSE.Storage_Count'Max (SC_Size,

             ((Pool.Elmt_Size + Align - 1) / Align) * Align);

      end if;

   end Initialize;

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

   -- Storage_Size --

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

   function  Storage_Size

     (Pool : Stack_Bounded_Pool) return SSE.Storage_Count

   is

   begin

      return Pool.Pool_Size;

   end Storage_Size;

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

   -- Variable_Size_Management --

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

   package body Variable_Size_Management is

      Minimum_Size : constant := 2 * SC_Size;

      procedure Set_Size

        (Pool        : Stack_Bounded_Pool;

         Chunk, Size : SSE.Storage_Count);

      --  Update the field 'size' of a chunk of available storage

      procedure Set_Next

        (Pool        : Stack_Bounded_Pool;

         Chunk, Next : SSE.Storage_Count);

      --  Update the field 'next' of a chunk of available storage

      function Size

        (Pool  : Stack_Bounded_Pool;

         Chunk : SSE.Storage_Count) return SSE.Storage_Count;

      --  Fetch the field 'size' of a chunk of available storage

      function Next

        (Pool  : Stack_Bounded_Pool;

         Chunk : SSE.Storage_Count) return SSE.Storage_Count;

      --  Fetch the field 'next' of a chunk of available storage

      function Chunk_Of

        (Pool : Stack_Bounded_Pool;

         Addr : System.Address) return SSE.Storage_Count;

      --  Give the chunk number in the pool from its Address

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

      -- Allocate --

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

      procedure Allocate

        (Pool         : in out Stack_Bounded_Pool;

         Address      : out System.Address;

         Storage_Size : SSE.Storage_Count;

         Alignment    : SSE.Storage_Count)

      is

         Chunk      : SSE.Storage_Count;

         New_Chunk  : SSE.Storage_Count;

         Prev_Chunk : SSE.Storage_Count;

         Our_Align  : constant SSE.Storage_Count :=

                        SSE.Storage_Count'Max (SSE.Storage_Count'Alignment,

                                               Alignment);

         Align_Size : constant SSE.Storage_Count :=

                        SSE.Storage_Count'Max (

                          Minimum_Size,

                          ((Storage_Size + Our_Align - 1) / Our_Align) *

                                                                  Our_Align);

      begin

         --  Look for the first big enough chunk

         Prev_Chunk := Pool.First_Free;

         Chunk := Next (Pool, Prev_Chunk);

         while Chunk /= 0 and then Size (Pool, Chunk) < Align_Size loop

            Prev_Chunk := Chunk;

            Chunk := Next (Pool, Chunk);

         end loop;

         --  Raise storage_error if no big enough chunk available

         if Chunk = 0 then

            raise Storage_Error;

         end if;

         --  When the chunk is bigger than what is needed, take appropriate

         --  amount and build a new shrinked chunk with the remainder.

         if Size (Pool, Chunk) - Align_Size  > Minimum_Size then

            New_Chunk := Chunk + Align_Size;

            Set_Size (Pool, New_Chunk, Size (Pool, Chunk) - Align_Size);

            Set_Next (Pool, New_Chunk, Next (Pool, Chunk));

            Set_Next (Pool, Prev_Chunk, New_Chunk);

         --  If the chunk is the right size, just delete it from the chain

         else

            Set_Next (Pool, Prev_Chunk, Next (Pool, Chunk));

         end if;

         Address := Pool.The_Pool (Chunk)'Address;

      end Allocate;

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

      -- Chunk_Of --

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

      function Chunk_Of

        (Pool : Stack_Bounded_Pool;

         Addr : System.Address) return SSE.Storage_Count

      is

      begin

         return 1 + abs (Addr - Pool.The_Pool (1)'Address);

      end Chunk_Of;

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

      -- Deallocate --

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

      procedure Deallocate

        (Pool         : in out Stack_Bounded_Pool;

         Address      : System.Address;

         Storage_Size : SSE.Storage_Count;

         Alignment    : SSE.Storage_Count)

      is

         pragma Warnings (Off, Pool);

         Align_Size : constant SSE.Storage_Count :=

                        ((Storage_Size + Alignment - 1) / Alignment) *

                                                                 Alignment;

         Chunk : constant SSE.Storage_Count := Chunk_Of (Pool, Address);

      begin

         --  Attach the freed chunk to the chain

         Set_Size (Pool, Chunk,

                         SSE.Storage_Count'Max (Align_Size, Minimum_Size));

         Set_Next (Pool, Chunk, Next (Pool, Pool.First_Free));

         Set_Next (Pool, Pool.First_Free,  Chunk);

      end Deallocate;

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

      -- Initialize --

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

      procedure Initialize  (Pool : in out Stack_Bounded_Pool) is

      begin

         Pool.First_Free := 1;

         if Pool.Pool_Size > Minimum_Size then

            Set_Next (Pool, Pool.First_Free, Pool.First_Free + Minimum_Size);

            Set_Size (Pool, Pool.First_Free, 0);

            Set_Size (Pool, Pool.First_Free + Minimum_Size,

                                              Pool.Pool_Size - Minimum_Size);

            Set_Next (Pool, Pool.First_Free + Minimum_Size, 0);

         end if;

      end Initialize;

      ----------

      -- Next --

      ----------

      function Next

        (Pool  : Stack_Bounded_Pool;

         Chunk : SSE.Storage_Count) return SSE.Storage_Count

      is

      begin

         pragma Warnings (Off);

         --  Kill alignment warnings, we are careful to make sure

         --  that the alignment is correct.

         return To_Storage_Count_Access

                  (Pool.The_Pool (Chunk + SC_Size)'Address).all;

         pragma Warnings (On);

      end Next;

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

      -- Set_Next --

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

      procedure Set_Next

        (Pool        : Stack_Bounded_Pool;

         Chunk, Next : SSE.Storage_Count)

      is

      begin

         pragma Warnings (Off);

         --  Kill alignment warnings, we are careful to make sure

         --  that the alignment is correct.

         To_Storage_Count_Access

           (Pool.The_Pool (Chunk + SC_Size)'Address).all := Next;

         pragma Warnings (On);

      end Set_Next;

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

      -- Set_Size --

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

      procedure Set_Size

        (Pool        : Stack_Bounded_Pool;

         Chunk, Size : SSE.Storage_Count)

      is

      begin

         pragma Warnings (Off);

         --  Kill alignment warnings, we are careful to make sure

         --  that the alignment is correct.

         To_Storage_Count_Access

           (Pool.The_Pool (Chunk)'Address).all := Size;

         pragma Warnings (On);

      end Set_Size;

      ----------

      -- Size --

      ----------

      function Size

        (Pool  : Stack_Bounded_Pool;

         Chunk : SSE.Storage_Count) return SSE.Storage_Count

      is

      begin

         pragma Warnings (Off);

         --  Kill alignment warnings, we are careful to make sure

         --  that the alignment is correct.

         return To_Storage_Count_Access (Pool.The_Pool (Chunk)'Address).all;

         pragma Warnings (On);

      end Size;

   end  Variable_Size_Management;

end System.Pool_Size;