Re: Memory pools

[gorgelo@hotmail.com]

And to follow up on the naive benchmarks:
https://github.com/frol/completely-unscientific-benchmarks

Using the memory pool in the previous post it can be used to implement the Treap algorithm (after some minor modifications):

pragma Suppress (Tampering_Check);
-- Tampering checks are only for multi-task applications.
-- Since this application is single task we can safely
-- suppress tampering checks of the standard containers.
-- If performance is an issue, the Ada-Traits Containers may be used instead.

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;
with Ada.Numerics.Discrete_Random;

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;

   subtype Count_Type is Ada.Containers.Count_Type;

   use type 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, 0);
      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;

   generic
      Slot_Size : Positive;
      -- 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.

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

   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

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

      subtype Slot_Index is Storage_Offset range 1.. Storage_Offset (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 (Ada.Containers.Count_Type (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 (Storage_Offset (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;

         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 (Storage_Offset (MAX))'Address;

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

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

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

      function Storage_Size (Pool : Arena) return Storage_Count is
         Result : Storage_Count := 0;
      begin
         for Envelope of Pool.Envelopes loop
            Result := Storage_Count (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;
      end Finalize;

   end Arena_Pools;

   package Pools is new Arena_Pools (24, 200_000);

   Pool : Pools.Arena := Pools.Make;

   -- Here ends the definition of the Storage pool and here begins
   -- implementation of the algorithm.

   package Integer_Random is new Ada.Numerics.Discrete_Random (Integer);

   G : Integer_Random.Generator;

   type Node;
   type Node_Ptr is access all Node with
     Storage_Pool => Pool;

   type Node is record
      Left  : Node_Ptr;
      Right : Node_Ptr;
      X     : Integer := 0;
      Y     : Integer := Integer_Random.Random (G);
   end record with
     Size => 24*8;

   package Tree_Def is

      type Tree is tagged private;

      function Has_Value (T : in out Tree;
                          X : in     Integer) return Boolean;

      procedure Insert (T : in out Tree;
                        X : in     Integer);

      procedure Erase (T : in out Tree;
                       X : in     Integer);

   private

      function Merge (Lower   : Node_Ptr;
                      Greater : Node_Ptr) return Node_Ptr;

      function Merge (Lower   : Node_Ptr;
                      Equal   : Node_Ptr;
                      Greater : Node_Ptr) return Node_Ptr;

      procedure Split (Orig             : in     Node_Ptr;
                       Lower            : in out Node_Ptr;
                       Greater_Or_Equal : in out Node_Ptr;
                       Value            : in     Integer);

      procedure Split (Orig    : in     Node_Ptr;
                       Lower   : in out Node_Ptr;
                       Equal   : in out Node_Ptr;
                       Greater : in out Node_Ptr;
                       Value   : in     Integer);

      procedure Make_Node (Node :    out Node_Ptr;
                           X    : in     Integer);

      type Tree is tagged record
         Root: Node_Ptr := null;
      end record;

   end Tree_Def;

   package body Tree_Def is

      procedure Free is new Ada.Unchecked_Deallocation(Object => Node,
                                                       Name   => Node_Ptr);

      procedure Make_Node (Node :    out Node_Ptr;
                           X    : in     Integer) is
      begin
         Node := new Main.Node;
         Node.X := X;
         Node.Y := Integer_Random.Random (G);
      end Make_Node;

      procedure Delete_Node (Node : in out Node_Ptr) is
      begin
         if Node /= null then
            if Node.Left /= null then
               Delete_Node(Node.Left);
            end if;

            if Node.Right /= null then
               Delete_Node (Node.Right);
            end if;

            Free (Node);
         end if;
      end Delete_Node;

      function Merge (Lower   : Node_Ptr;
                      Greater : Node_Ptr) return Node_Ptr is
      begin
         if Lower = null then
            return Greater;
         end if;

         if Greater = null then
            return lower;
         end if;

         if Lower.Y < Greater.Y then
            Lower.Right := Merge (Lower.Right, Greater);
            return Lower;
         else
            Greater.Left := Merge (Lower, Greater.Left);
            return Greater;
         end if;
      end Merge;

      function Merge (Lower   : Node_Ptr;
                      Equal   : Node_Ptr;
                      Greater : Node_Ptr) return Node_Ptr is
      begin
         return Merge (Merge (Lower, Equal), Greater);
      end merge;

      procedure Split (Orig             : in     Node_Ptr;
                       Lower            : in out Node_Ptr;
                       Greater_Or_Equal : in out Node_Ptr;
                       Value            : in     Integer) is
      begin
         if Orig = null then
            Lower := null;
            Greater_Or_Equal := null;
            return;
         end if;
         if Orig.X < Value then
            Lower := Orig;
            Split (Lower.Right, Lower.Right, Greater_Or_Equal, Value);
         else
            Greater_Or_Equal := Orig;
            Split (Greater_Or_Equal.Left, Lower, Greater_Or_Equal.Left, Value);
         end if;
      end Split;

      procedure Split (Orig    : in     Node_Ptr;
                       Lower   : in out Node_Ptr;
                       Equal   : in out Node_Ptr;
                       Greater : in out Node_Ptr;
                       Value   : in     Integer)
      is
         Equal_Or_Greater: Node_Ptr;
      begin
         Split (Orig, Lower, Equal_Or_Greater, Value);
         Split (Equal_Or_Greater, Equal, Greater, Value + 1);
      end Split;

      function Has_Value (T : in out Tree;
                          X : in     Integer) return Boolean
      is
         Lower   : Node_Ptr;
         Equal   : Node_Ptr;
         Greater : Node_Ptr;

         Result : Boolean;
      begin
         Split (T.Root, Lower, Equal, Greater, X);
         Result := Equal /= null;
         T.Root := Merge (Lower, Equal, Greater);
         return Result;
      end Has_Value;

      procedure Insert (T : in out Tree;
                        X : in     Integer)
      is
         Lower   : Node_Ptr;
         Equal   : Node_Ptr;
         Greater : Node_Ptr;
      begin
         Split (T.Root, Lower, Equal, Greater, X);
         if Equal = null then
            Make_Node (Equal, X);
         end if;
         T.Root := Merge (Lower, Equal, Greater);
      end Insert;

      procedure Erase (T : in out Tree;
                       X : in     Integer) is
         Lower   : Node_Ptr;
         Equal   : Node_Ptr;
         Greater : Node_Ptr;
      begin
         Split (T.Root, Lower, Equal, Greater, X);
         T.Root := Merge (Lower, Greater);
         -- commenting out the following line
         -- doesn't seem to affect running time by much, if at all
         Delete_Node (Equal);
      end Erase;

   end Tree_Def;

   Tree    : Tree_Def.Tree;
   Current : Integer := 5;
   Result  : Integer := 0;
   Mode    : Integer;

begin
   Integer_Random.Reset (G);

   for I in 1..1_000_000 loop
      Mode := I mod 3;
      Current := (Current * 57 + 43) mod 10007;
      if Mode = 0 then
         Tree.Insert (Current);
      elsif Mode = 1 then
         Tree.Erase (Current);
      else
         Result := Result + (if Tree.Has_Value (Current) then 1 else 0);
      end if;
   end loop;
   Put_Line (Result);

end Main;