Memory pools

Memory pools

[John Perry]

I apologize if this is a dumb question, but:

I've read that Ada uses memory pools for each type. When I read this, I think it means, for instance, Ada sets up something like an array of 10000 elements for each type, and when the user asks to allocate a new object of such-and-such type, the run-time system hands that to you.

Is that the idea, or do they mean something else?

Re: Memory pools

[joakimds]

> I apologize if this is a dumb question, but:
> 
> I've read that Ada uses memory pools for each type. When I read this, I think it means, for instance, Ada sets up something like an array of 10000 elements for each type, and when the user asks to allocate a new object of such-and-such type, the run-time system hands that to you.
> 
> Is that the idea, or do they mean something else?

I agree the descriptions can be fuzzy. The way I understand it is that whenever one defines an access type a memory pool is associated with it. If one doesn't specify a memory pool, the default is to use the Global memory pool which on ordinary desktop computers means the heap.

When it comes to memory pools I've used Deepend. Maybe I can find the time to write more about this tonight when I come home from work but Brad Moore wrote the following in February 2017:

Its been a while since a new release of Deepend has been announced, the last announced version being version 3.4, though there have been updates since then. 

Now that 3.9 has been posted, seems like a good time to mention the availability of new features and fixes. 

Deepend is a set of storage pools for Ada 95, Ada 2005, and Ada 2012 that 
includes subpool capabilities. Groups of memory allocations from a storage 
pool can be assigned to specific subpools where groups of objects can be  deallocated as a group by deallocating the subpool, rather than by individual deallocations of objects. 

Each subpool is "owned" by a specific task in Ada, allowing allocations and 
deallocations to be efficient, as well as being safer and less error prone. 

Since version 3.4, the most notable changes are; 

- Ada 2012 subpools were not working in version 3.4, but now work properly 
  with the Ada 2012 subpool syntax. 
- It is now possible to set task ownership of the storage pool itself, as 
  well as subpools. 
- Portability changes made to integrate with PTC's ObjectAda 64bit compiler 
  for Ada 2005 and Ada 95 
- Portability changes made to integrate with RR Software's Janus Ada 
  compiler for Ada 95 
- Memory allocations returned by the generic allocators were not 
  initializing memory. This is important for types that have discriminants 
  or tags. Now memory is initialised which is consistent with behaviour when 
  one uses Ada's "new" keyword syntax to provide the allocations. 
- The generic allocator routines now support allocating unconstrained types, 
  such as strings. 

There are 4 different storage pools to choose from; 
   - Unbounded storage pool with subpool support 
   - Bounded storage pool with subpool support 
   - Unbounded storage pool without subpool support 
   - Bounded storage pool without subpool support 

Deepend source code can be found at; 

https://sourceforge.net/projects/deepend/files/ 

Regards, 

Brad Moore

Re: Memory pools

[gorgelo]

To followup on what I started to write upon. There are several different kinds of memory pools but what first comes to my mind is single task RAII (Resource Acquisition Is Allocation) e.g. a pool is used during a subprogram/function call. At subprogram entry a pool object is allocated on the stack and then any subsequent heap allocations of objects are allocated inside the pool instead of on the heap. Note that the pool object is allocated on the stack but the objects it contains are stored on the heap in pre-allocated heap memory or heap memory allocated on demand. When the pool object goes out of scope all heap memory is deallocated. And for this scenario there are two kinds of memory pools, bounded and unbounded.

The pool implementations of Deepend are built upon the idea that allocated objects (of varying sizes) are only allocated in the pool but never deallocated. Using Unchecked_Deallocation for the pools in Deepend only results in No-ops. For implementation of the Treap algorithm in Ada it is essential that deallocations "work as expected" which rules out the usage of Deepend which is what I usually use. Also note that when one uses Deepend one never does any deallocations using Unchecked_Deallocation and that is taken care of under the hood by Deepend.

Re: Memory pools

[gorgelo]

Den tisdag 29 maj 2018 kl. 21:41:14 UTC+2 skrev John Perry:
> I apologize if this is a dumb question, but:
> 
> I've read that Ada uses memory pools for each type. When I read this, I think it means, for instance, Ada sets up something like an array of 10000 elements for each type, and when the user asks to allocate a new object of such-and-such type, the run-time system hands that to you.
> 
> Is that the idea, or do they mean something else?

The pre-allocations scheme that you think of is the oldest form of memory pools in Ada, already offerred by many Ada 83 compilers and then included in the Ada95 standard. It means that one allocates a bounded amount of memory to an access type (pointer). The idea to do this originates from the observation that an access type (pointer) does not need to have the same life-time as the application. The idea is to define the access type in the beginning of a subprogram and pre-allocate memory to it and then when the access type goes out of scope all heap-memory is deallocation (RAII-pattern again). This simple form of memory pool has since then been generalised.

Re: Memory pools

[gorgelo]

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

Re: Memory pools

[gorgelo]

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;

Re: Memory pools

[Simon Wright]

gorgelo@hotmail.com writes:

> -- Tampering checks are only for multi-task applications.
> -- Since this application is single task we can safely
> -- suppress tampering checks of the standard containers.

Not true! Try forward looping over a Vector to find particuler members
and deleting them in the loop.

Re: Memory pools

[Randy Brukardt]

<gorgelo@hotmail.com> wrote in message 
news:bbd7511d-c190-4ddd-992a-011dd2531ea0@googlegroups.com...
...
> 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.

This is a completely false statement. Tampering checks are designed to 
prevent problems with iterators and element access, no tasks need to be 
involved (indeed, they don't do anything in a tasking environment - such 
code is usually erroneous). For instance, without tampering checks, an 
iterator might run forever or otherwise malfunction. Similarly, for 
Update_Element and other sorts of element access.

                                                                    Randy.

Re: Memory pools

[gorgelo]

Den fredag 1 juni 2018 kl. 00:57:10 UTC+2 skrev Randy Brukardt:
> ...
> > 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.
> 
> This is a completely false statement. Tampering checks are designed to 
> prevent problems with iterators and element access, no tasks need to be 
> involved (indeed, they don't do anything in a tasking environment - such 
> code is usually erroneous). For instance, without tampering checks, an 
> iterator might run forever or otherwise malfunction. Similarly, for 
> Update_Element and other sorts of element access.
> 
>                                                                     Randy.

> Simon wrote:
> Not true! Try forward looping over a Vector to find particuler members
> and deleting them in the loop.

Thanks for the correction Simon and Randy!
/Joakim

Re: Memory pools

[John Perry]

I want to thank everyone for the replies, and apologize for my own tardy reply. I've been traveling, so I can't reply very well right now, but I did read all the replies and I appreciate them.

I wasn't thinking so much of the Treap program at the time; it was a more general question. I actually though of posting it afterwards to Stack Overflow, per the earlier thread suggestion, and if someone else thinks that's a good idea I'll go ahead & do that.