Natools

------------------------------------------------------------------------------
-- Copyright (c) 2014, Natacha Porté                                        --
--                                                                          --
-- Permission to use, copy, modify, and distribute this software for any    --
-- purpose with or without fee is hereby granted, provided that the above   --
-- copyright notice and this permission notice appear in all copies.        --
--                                                                          --
-- THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES --
-- WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF         --
-- MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR  --
-- ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES   --
-- WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN    --
-- ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF  --
-- OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.           --
------------------------------------------------------------------------------

package body Natools.References.Pools is

   ------------------------
   -- Helper Subprograms --
   ------------------------

   overriding procedure Finalize (Object : in out Pool_Backend) is
   begin
      Unchecked_Free (Object.Refs);
   end Finalize;


   procedure Find
     (Container : in Pool_Backend;
      First_Available : out Extended_Index;
      First_Empty : out Extended_Index) is
   begin
      First_Available := 0;
      First_Empty := 0;

      if Container.Refs = null then
         return;
      end if;

      for I in Container.Refs'Range loop
         if Container.Refs (I).Is_Empty then
            if First_Empty = 0 then
               First_Empty := I;
               exit when First_Available /= 0;
            end if;
         elsif Container.Refs (I).Is_Last then
            if First_Available = 0 then
               First_Available := I;
               exit when First_Empty /= 0;
            end if;
         end if;
      end loop;
   end Find;


   not overriding procedure Preallocate
     (Container : in out Pool_Backend;
      New_Item_Count : in Pool_Size;
      Constructor : access function return Held_Data := null) is
   begin
      if New_Item_Count = 0 then
         return;
      end if;

      if Container.Refs = null then
         Container.Refs := new Reference_Array (1 .. New_Item_Count);

         if Constructor /= null then
            for I in Container.Refs'Range loop
               Container.Refs (I) := Create (Constructor);
            end loop;
         end if;

      else
         declare
            New_Data : Reference_Array_Access
              := new Reference_Array
                 (1 .. Container.Refs'Length + New_Item_Count);
         begin
            New_Data (1 .. Container.Refs'Length) := Container.Refs.all;

            if Constructor /= null then
               for I in Container.Refs'Length + 1 .. New_Data'Last loop
                  New_Data (I) := Create (Constructor);
               end loop;
            end if;

            Unchecked_Free (Container.Refs);
            Container.Refs := New_Data;
         exception
            when others =>
               Unchecked_Free (New_Data);
               raise;
         end;
      end if;
   end Preallocate;



   ----------------------------------
   -- Public Protected Subprograms --
   ----------------------------------

   protected body Pool is

      procedure Get (Ref : out Reference) is
         First_Available, First_Empty : Extended_Index;
      begin
         Backend.Find (First_Available, First_Empty);

         if First_Available in Reference_Index then
            Ref := Backend.Refs (First_Available);
         else
            raise Constraint_Error
              with "No non-empty unused reference in pool";
         end if;
      end Get;


      procedure Get
        (Constructor : not null access function return Held_Data;
         Ref : out Reference)
      is
         First_Available, First_Empty : Extended_Index;
      begin
         Backend.Find (First_Available, First_Empty);

         if First_Available in Reference_Index then
            Ref := Backend.Refs (First_Available);
         elsif First_Empty in Reference_Index then
            Backend.Refs (First_Empty) := Create (Constructor);
            Ref := Backend.Refs (First_Empty);
         else
            raise Constraint_Error with "No unused reference in pool";
         end if;
      end Get;


      procedure Create
        (Constructor : not null access function return Held_Data;
         Ref : out Reference;
         Expand_Count : in Pool_Size := 1)
      is
         First_Available, First_Empty : Extended_Index;
      begin
         Backend.Find (First_Available, First_Empty);

         if First_Available in Reference_Index then
            Ref := Backend.Refs (First_Available);

         elsif First_Empty in Reference_Index then
            Backend.Refs (First_Empty) := Create (Constructor);
            Ref := Backend.Refs (First_Empty);

         else
            First_Available := Backend.Length + 1;
            Backend.Preallocate (Expand_Count, Constructor);
            Ref := Backend.Refs (First_Available);
         end if;
      end Create;


      procedure Preallocate
        (New_Item_Count : in Pool_Size;
         Constructor : access function return Held_Data := null) is
      begin
         Backend.Preallocate (New_Item_Count, Constructor);
      end Preallocate;


      procedure Release_Unused is
      begin
         if Backend.Refs = null then
            return;
         end if;

         for I in Backend.Refs'Range loop
            if not Backend.Refs (I).Is_Empty
              and then Backend.Refs (I).Is_Last
            then
               Backend.Refs (I).Reset;
            end if;
         end loop;
      end Release_Unused;


      procedure Trim is
         Index : Extended_Index := 0;
         New_Count : constant Pool_Size := Initialized_Size;
         New_Data : Reference_Array_Access := null;
      begin
         if New_Count = Backend.Length then
            return;
         end if;

         New_Data := new Reference_Array (1 .. New_Count);

         for I in Backend.Refs'Range loop
            if not Backend.Refs (I).Is_Empty then
               Index := Index + 1;
               New_Data (Index) := Backend.Refs (I);
            end if;
         end loop;

         pragma Assert (Index = New_Count);

         Unchecked_Free (Backend.Refs);
         Backend.Refs := New_Data;
      exception
         when others =>
            Unchecked_Free (New_Data);
            raise;
      end Trim;


      procedure Purge is
      begin
         Release_Unused;
         Trim;
      end Purge;


      function Capacity return Pool_Size is
      begin
         return Backend.Length;
      end Capacity;


      function Initialized_Size return Pool_Size is
         Result : Pool_Size := 0;
      begin
         if Backend.Refs /= null then
            for I in Backend.Refs'Range loop
               if not Backend.Refs (I).Is_Empty then
                  Result := Result + 1;
               end if;
            end loop;
         end if;

         return Result;
      end Initialized_Size;


      function Active_Size return Pool_Size is
         Result : Pool_Size := 0;
      begin
         if Backend.Refs /= null then
            for I in Backend.Refs'Range loop
               if not Backend.Refs (I).Is_Empty
                 and then not Backend.Refs (I).Is_Last
               then
                  Result := Result + 1;
               end if;
            end loop;
         end if;

         return Result;
      end Active_Size;


      procedure Unchecked_Iterate
        (Process : not null access procedure (Ref : in Reference)) is
      begin
         for I in Backend.Refs'Range loop
            Process.all (Backend.Refs (I));
         end loop;
      end Unchecked_Iterate;

   end Pool;

end Natools.References.Pools;

------------------------------------------------------------------------------
-- Copyright (c) 2014, Natacha Porté                                        --
--                                                                          --
-- Permission to use, copy, modify, and distribute this software for any    --
-- purpose with or without fee is hereby granted, provided that the above   --
-- copyright notice and this permission notice appear in all copies.        --
--                                                                          --
-- THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES --
-- WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF         --
-- MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR  --
-- ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES   --
-- WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN    --
-- ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF  --
-- OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.           --
------------------------------------------------------------------------------

------------------------------------------------------------------------------
-- Natools.References.Pools provides a task-safe dynamic pool of            --
-- homogeneous references.                                                  --
------------------------------------------------------------------------------

private with Ada.Unchecked_Deallocation;

generic
package Natools.References.Pools is
   pragma Preelaborate;

   type Pool_Backend is limited private;
   pragma Preelaborable_Initialization (Pool_Backend);

   type Pool_Size is new Natural;

   protected type Pool is

      procedure Get (Ref : out Reference)
        with Post => not Ref.Is_Empty;
         --  Return an existing non-empty available reference from the pool,
         --  raising Constraint_Error when not possible.

      procedure Get
        (Constructor : not null access function return Held_Data;
         Ref : out Reference)
        with Post => not Ref.Is_Empty;
         --  Return an available reference from the pool, initializing it
         --  if needed, but without expanding the pool.
         --  Raise Constraint_Error when all references are in use.

      procedure Create
        (Constructor : not null access function return Held_Data;
         Ref : out Reference;
         Expand_Count : in Pool_Size := 1)
        with Pre => Expand_Count > 0, Post => not Ref.Is_Empty;
         --  Return a reference from the pool, creating it and/or initializing
         --  it if needed.

      procedure Preallocate
        (New_Item_Count : in Pool_Size;
         Constructor : access function return Held_Data := null);
         --  Add New_Item_Count references to the pool, using Constructor to
         --  initialize them if not null.

      procedure Release_Unused;
         --  Empty all references from the pool that are not used externally

      procedure Trim;
         --  Remove empty references from the pool, diminishing its capacity

      procedure Purge;
         --  Remove empty and available references from the pool.
         --  Equivalent to Release_Unused followed by Trim.

      function Capacity return Pool_Size;
         --  Return the number of references in the pool

      function Initialized_Size return Pool_Size;
         --  Return the number of non-empty references in the pool

      function Active_Size return Pool_Size;
         --  Return the number of externally-used references in the pool.
         --  WARNING: the result might be stale before it can be used by the
         --  client, do not take any sensitive decision from it.

      procedure Unchecked_Iterate
        (Process : not null access procedure (Ref : in Reference));
         --  Iterate over all references held in the pool.
         --  WARNING: Process must not call any potentially blocking operations
         --  or any operation on the current pool, and safety of any tampering
         --  with Ref or its referred object must be ensured independently.

   private
      Backend : Pool_Backend;
   end Pool;

private

   --  Basic types

   subtype Reference_Index is Pool_Size range 1 .. Pool_Size'Last;
   subtype Extended_Index is Pool_Size range 0 .. Pool_Size'Last;

   type Reference_Array is array (Reference_Index range <>) of Reference;

   type Reference_Array_Access is access Reference_Array;

   procedure Unchecked_Free is new Ada.Unchecked_Deallocation
     (Reference_Array, Reference_Array_Access);


   --  Dynamic array backend

   type Pool_Backend is new Ada.Finalization.Limited_Controlled with record
      Refs : Reference_Array_Access := null;
   end record;

   overriding procedure Finalize (Object : in out Pool_Backend);

   not overriding procedure Find
     (Container : in Pool_Backend;
      First_Available : out Extended_Index;
      First_Empty : out Extended_Index)
   with Post =>
     (First_Available = 0 or else
        (not Container.Refs (First_Available).Is_Empty
           and then Container.Refs (First_Available).Is_Last))
     and then (First_Empty = 0 or else Container.Refs (First_Empty).Is_Empty);

   not overriding function Length (Container : Pool_Backend) return Pool_Size
     is (if Container.Refs = null then 0 else Container.Refs'Length);

   not overriding procedure Preallocate
     (Container : in out Pool_Backend;
      New_Item_Count : in Pool_Size;
      Constructor : access function return Held_Data := null)
   with Post => (Container.Length = Container.Length'Old + New_Item_Count);

end Natools.References.Pools;