Re: Memory pools

[gorgelo@hotmail.com]

Here is an example of an unbounded storage pool that handles deallocations and is used for allocating 3 Integers inside it and then deallocating them:

with System.Storage_Elements;
with System.Storage_Pools;
with Ada.Text_IO;
with Ada.Integer_Text_IO;
with Ada.Containers.Vectors;
with Ada.Unchecked_Deallocation;

procedure Main is

   subtype Storage_Offset is System.Storage_Elements.Storage_Offset;
   subtype Storage_Count  is System.Storage_Elements.Storage_Count;
   subtype Storage_Array  is System.Storage_Elements.Storage_Array;

   subtype Root_Storage_Pool is System.Storage_Pools.Root_Storage_Pool;

   subtype Integer_Address is System.Storage_Elements.Integer_Address;

   use type Ada.Containers.Count_Type;
   use type Storage_Offset;
   use type Integer_Address;

   procedure Put (Text : String) renames Ada.Text_IO.Put;

   procedure Put_Line (Text : String) renames Ada.Text_IO.Put_Line;

   procedure Put_Line (I : Integer) is
   begin
      Ada.Integer_Text_IO.Put (I);
      Ada.Text_IO.New_Line;
   end Put_Line;

   procedure Put (I : Integer) is
   begin
      Ada.Integer_Text_IO.Put (I, 0);
   end Put;

   procedure Put (I : Storage_Offset) is
   begin
      Ada.Integer_Text_IO.Put (Integer (I), 0);
   end Put;

   function To_Integer (Value : System.Address) return Integer_Address
                        renames System.Storage_Elements.To_Integer;

   package Arena_Pools is

      type Arena (<>) is new Root_Storage_Pool with private;

      function Make return Arena;

      overriding
      procedure Allocate
        (  Pool      : in out Arena;
           Address   : out System.Address;
           Size      : Storage_Count;
           Alignment : Storage_Count
          );

      overriding
      procedure Deallocate
        (  Pool      : in out Arena;
           Address   : System.Address;
           Size      : Storage_Count;
           Alignment : Storage_Count
          );

      overriding
      function Storage_Size (Pool : Arena) return Storage_Count;
      -- Approximation of how many Storage Elements (bytes)
      -- have been heap-allocated.

   private

      Slot_Size : constant := 20;
      -- Specifies the size of each slot in Storage Elements (bytes)
      -- Must be big enough to store any object one wishes to allocate
      -- inside the memory pool.

      type Slot is record
         Elements : Storage_Array (1..Slot_Size);
      end record;

      MAX : constant := 200_000;
      -- Specifies the number of slots that will be allocated in an array
      -- from the heap every time more memory needs to be pre-allocated.

      subtype Slot_Index is Storage_Offset range 1..MAX;

      type Slots_Array is array (Slot_Index) of Slot;

      subtype Free_Index is Integer range 1..MAX;
      -- This Integer type (32-bits) is created in order to not use the type
      -- Storage_Offset (64-bits) in the free indices vector.

      package Indices_Vector is new Ada.Containers.Vectors
        (Index_Type   => Positive,
         Element_Type => Free_Index,
         "="          => "=");

      type Slots_Envelope is record
         Items        : Slots_Array;
         Free_Indices : Indices_Vector.Vector;
      end record;

      type Slots_Envelope_Ptr is access all Slots_Envelope;

      package Envelope_Vectors is new Ada.Containers.Vectors
        (Index_Type   => Positive,
         Element_Type => Slots_Envelope_Ptr,
         "="          => "=");

      type Arena is new Root_Storage_Pool with record
         Index : Positive := 1;
         -- Indicates which array of slots to first search for a free index

         Envelopes : Envelope_Vectors.Vector;
      end record;

      overriding
      procedure Finalize (This : in out Arena);
      -- Deallocates all allocated memory from the heap

   end Arena_Pools;

   package body Arena_Pools is

      function Make return Slots_Envelope_Ptr is
         Envelope : Slots_Envelope_Ptr := new Slots_Envelope;
      begin
         Envelope.Free_Indices.Reserve_Capacity (MAX);
         for I in Slot_Index'Range loop
            Envelope.Free_Indices.Append (Free_Index (I));
         end loop;

         return Envelope;
      end Make;

      function Make return Arena is
         Envelope : Slots_Envelope_Ptr := Make;
      begin
         return This : Arena do
            This.Envelopes.Append (Envelope);
         end return;
      end Make;

      function Determine_Index (Pool    : Arena;
                                Address : System.Address) return Positive is
         Searched_For : Natural := 0;
         First_Address : System.Address;
         Last_Address  : System.Address;
      begin
         for I in Pool.Envelopes.First_Index..Pool.Envelopes.Last_Index loop
            First_Address := Pool.Envelopes (I).Items (1)'Address;
            Last_Address  := Pool.Envelopes (I).Items (MAX)'Address;
            if
              To_Integer (First_Address) <= To_Integer (Address) and
              To_Integer (Address)       <= To_Integer (Last_Address)
            then
               Searched_For := I;
               exit;
            end if;
         end loop;

         if Searched_For = 0 then
            raise Storage_Error;
         end if;

         return Searched_For;
      end Determine_Index;

      procedure Allocate
        (Pool      : in out Arena;
         Address   : out System.Address;
         Size      : Storage_Count;
         Alignment : Storage_Count)
      is
         Id : Slot_Index;
      begin
         if Pool.Envelopes (Pool.Index).Free_Indices.Length > 0 then
            Id := Slot_Index (Pool.Envelopes (Pool.Index).Free_Indices.Last_Element);
            Pool.Envelopes (Pool.Index).Free_Indices.Delete_Last;
         else
            declare
               Has_Found : Boolean := False;
            begin
               for I in Pool.Envelopes.First_Index .. Pool.Envelopes.Last_Index loop
                  if Pool.Envelopes (I).Free_Indices.Length > 0 then
                     Pool.Index := I;
                     Id := Slot_Index (Pool.Envelopes (Pool.Index).Free_Indices.Last_Element);
                     Pool.Envelopes (Pool.Index).Free_Indices.Delete_Last;
                     Has_Found := True;
                     exit;
                  end if;
               end loop;

               if not Has_Found then
                  declare
                     E : Slots_Envelope_Ptr := Make;
                  begin
                     Pool.Envelopes.Append (E);
                     Pool.Index := Pool.Envelopes.Last_Index;
                     Id := Slot_Index (Pool.Envelopes (Pool.Index).Free_Indices.Last_Element);
                     Pool.Envelopes (Pool.Index).Free_Indices.Delete_Last;
                  end;
               end if;
            end;
         end if;

         Put ("Will allocate (array, slot) := (");
         Put (Pool.Index);
         Put (",");
         Put (Id);
         Put_Line (")");

         Address := Pool.Envelopes (Pool.Index).Items (Id).Elements'Address;
      end Allocate;

      procedure Deallocate (Pool      : in out Arena;
                            Address   : System.Address;
                            Size      : Storage_Count;
                            Alignment : Storage_Count)
      is
         I : constant Positive := Determine_Index (Pool, Address);

         First_Address : System.Address;
         Last_Address  : System.Address;

         Slot_Id : Slot_Index;

         D : Integer_Address;
      begin
         First_Address := Pool.Envelopes (I).Items (1)'Address;
         Last_Address  := Pool.Envelopes (I).Items (MAX)'Address;

         D := (To_Integer (Last_Address) - To_Integer (First_Address) + Slot_Size) / MAX;

         Slot_Id := Slot_Index ((To_Integer (Address) + Slot_Size - To_Integer (First_Address))/ D);

         Pool.Envelopes (I).Free_Indices.Append (Free_Index (Slot_Id));

         Put ("Deallocate (array, slot) := (");
         Put (I);
         Put (",");
         Put (Slot_Id);
         Put_Line (")");
      end Deallocate;

      function Storage_Size (Pool : Arena) return Storage_Count is
         Result : Storage_Count := 0;
      begin
         for Envelope of Pool.Envelopes loop
            Result := Slot_Size*MAX + Storage_Count (Envelope.Free_Indices.Capacity * 4);
         end loop;

         return Result;
      end Storage_Size;

      procedure Free is new Ada.Unchecked_Deallocation (Object => Slots_Envelope,
                                                        Name   => Slots_Envelope_Ptr);

      procedure Finalize (This : in out Arena) is
      begin
         for Envelope of This.Envelopes loop
            Free (Envelope);
         end loop;
         This.Envelopes.Clear;
         Put_Line ("Deallocated all heap-allocated memory");
      end Finalize;

   end Arena_Pools;

   Pool : Arena_Pools.Arena := Arena_Pools.Make;

   type Integer_Ptr is access Integer with
     Storage_Pool => Pool;

   procedure Free is new Ada.Unchecked_Deallocation (Object => Integer,
                                                     Name   => Integer_Ptr);

   X : Integer_Ptr := new Integer'(1);
   Y : Integer_Ptr := new Integer'(2);
   Z : Integer_Ptr := new Integer'(3);

begin
   Free (X);
   Free (Y);
   Free (Z);
   Put_Line ("Has allocated" & Pool.Storage_Size'Image & " bytes.");
end Main;

It has the following output:
Will allocate (array, slot) := (1,200000)
Will allocate (array, slot) := (1,199999)
Will allocate (array, slot) := (1,199998)
Deallocate (array, slot) := (1,200000)
Deallocate (array, slot) := (1,199999)
Deallocate (array, slot) := (1,199998)
Has allocated 4800000 bytes.
Deallocated all heap-allocated memory


The implementation is inspired from Rosetta stone Arena pools:
http://rosettacode.org/wiki/Arena_storage_pool#Ada