--------------------------------
-- Ivan Levashew aka OCTAGRAM --
--              Barnaul, 2009 --
--------------------------------

with System; use System;
with Interfaces; use Interfaces;
with System.Storage_Pools; use System.Storage_Pools;
with System.Storage_Elements; use System.Storage_Elements;
with Turbo_Private.Bits; use Turbo_Private.Bits;
with Turbo_Private.Memory.Move;

-- TODO: Consider RM13.11(20):
-- The effect of calling Allocate and Deallocate for a standard storage
-- pool directly (rather than implicitly via an allocator or an instance
-- of Unchecked_Deallocation) is unspecified.
--
-- Ramification: For example, an allocator might put the pool element on
-- a finalization list. If the user directly Deallocates it, instead of
-- calling an instance of Unchecked_Deallocation, then the implementation
-- would probably try to finalize the object upon master completion, which
-- would be bad news. Therefore, the implementation should define such
-- situations as erroneous.
-- TODO: Reason whether it's applicable in my case

package body Turbo_Private.Memory.Fallback is

   type Dummy_Access_Type is access Boolean;

   Base_Storage_Pool : Root_Storage_Pool'Class
      renames Dummy_Access_Type'Storage_Pool;

   type T_Info_Prefix is record
      Size, All_Size : Storage_Count;
      Alignment : Storage_Count;
      Original_Address : Address;
   end record;

   -- Q: What is All_Prefix_Size for?
   -- A: Imagine that Alignment is big.
   -- We are forced to ask the underlying
   -- memory manager to allocate additional
   -- Alignment bytes. We place Info_Prefix
   -- right before the allocated memory at a
   -- fixed negative offset.
   -- So far, we have:
   -- |Wasted space|Info_Prefix|Memory_Data
   -- |------------|-----------|-------------...
   -- |<---All_Prefix_Size---->|
   -- Memory_Data'Address - All_Prefix_Size = Original_Address
   --
   -- Original_Address does not necessarily equal to
   -- Memory_Data'Address - Info_Prefix_Size, that's
   -- why it must be kept.

   -- the latter one is being ceiled to own alignment
   Info_Prefix_Size : constant Storage_Count :=
      ((T_Info_Prefix'Max_Size_In_Storage_Elements +
        T_Info_Prefix'Alignment - 1) / T_Info_Prefix'Alignment) *
        T_Info_Prefix'Alignment;

   function GCD (Left, Right : Storage_Count) return Storage_Count is
   -- TODO: use Bruno Haible's efficient GCD (gnulib-lib)
      X : Storage_Count;
      Y : Storage_Count;
      Z : Storage_Count;
   begin
      if Left > Right then
         X := Left; Y := Right;
      else
         X := Right; Y := Left;
      end if;
      while Y /= 0 loop
         Z := X mod Y;
         X := Y;
         Y := Z;
      end loop;
      return X;
   end GCD;

   procedure Allocate (
      Pool : in out Fallback_Storage_Pool;
      Storage_Address : out Address;
      Size_In_Storage_Elements : in Storage_Elements.Storage_Count;
      Alignment : in Storage_Elements.Storage_Count)
   is
      Info_Alignment_Now : constant Storage_Count :=
         Alignment *
            (T_Info_Prefix'Alignment /
               GCD (Alignment, T_Info_Prefix'Alignment));
      All_Prefix_Size_Now : constant Storage_Count :=
         ((Info_Prefix_Size + Info_Alignment_Now - 1)
            / Info_Alignment_Now) * Info_Alignment_Now;
      All_Size : constant Storage_Count :=
         All_Prefix_Size_Now + Size_In_Storage_Elements;
      All_Address : Address := Null_Address;
   begin
      Allocate (Base_Storage_Pool, All_Address, All_Size, Info_Alignment_Now);
      declare
         Info_Prefix : T_Info_Prefix;
         for Info_Prefix'Address use All_Address + (All_Prefix_Size_Now - Info_Prefix_Size);
         pragma Import (Ada, Info_Prefix); -- deny finalization
      begin
         Info_Prefix := 
            (Size             => Size_In_Storage_Elements,
             All_Size         => All_Size,
             Alignment        => Alignment,
             Original_Address => All_Address);
      end;
      Storage_Address := All_Address + All_Prefix_Size_Now;
   exception
      when others =>
         if All_Address /= Null_Address then
            Deallocate (Base_Storage_Pool, All_Address, All_Size, Info_Alignment_Now);
         end if;
         raise;
   end Allocate;

   procedure Deallocate (
      Pool : in out Fallback_Storage_Pool;
      Storage_Address : in Address;
      Size_In_Storage_Elements : in Storage_Elements.Storage_Count;
      Alignment : in Storage_Elements.Storage_Count) is
   begin
      if Storage_Address /= Null_Address then
         declare
            Info_Prefix : T_Info_Prefix;
            for Info_Prefix'Address use Storage_Address - Info_Prefix_Size;
            pragma Import (Ada, Info_Prefix);
         begin
            Deallocate (Base_Storage_Pool,
               Info_Prefix.Original_Address,
               Info_Prefix.Size,
               Info_Prefix.Alignment);
         end;
      end if;
   end Deallocate;

   function Storage_Size (Pool : Fallback_Storage_Pool)
        return Storage_Elements.Storage_Count is
   begin
      return Storage_Size (Base_Storage_Pool);
   end Storage_Size;

   procedure Reallocate (
      Pool : in out Fallback_Storage_Pool;
      Storage_Address : in out Address;
      Size_In_Storage_Elements, New_Size_In_Storage_Elements : in Storage_Elements.Storage_Count;
      Alignment : in Storage_Elements.Storage_Count) is
   begin
      if Storage_Address = Null_Address then
         Allocate (Pool, Storage_Address, New_Size_In_Storage_Elements, Alignment);
         return;
      end if;

      declare
         New_Address : Address := Null_Address;
      begin
         declare
            Info_Prefix : T_Info_Prefix;
            for Info_Prefix'Address use Storage_Address - Info_Prefix_Size;
            pragma Import (Ada, Info_Prefix);
         begin
            Allocate (Pool, New_Address, New_Size_In_Storage_Elements, Alignment);
            Move (Storage_Address, New_Address,
               Unsigned_Addr (Storage_Count'Min (Info_Prefix.Size,
                                              New_Size_In_Storage_Elements)));
         end;
         Deallocate (Pool, Storage_Address);
         Storage_Address := New_Address;
      exception
         when others =>
            Deallocate (Pool, New_Address, New_Size_In_Storage_Elements, Alignment);
            raise;
      end;
   end Reallocate;

   procedure Deallocate (
      Pool : in out Fallback_Storage_Pool;
      Storage_Address : in Address) is
   begin
      if Storage_Address /= Null_Address then
         declare
            Info_Prefix : T_Info_Prefix;
            for Info_Prefix'Address use Storage_Address - Info_Prefix_Size;
            pragma Import (Ada, Info_Prefix);
         begin
            Deallocate (Base_Storage_Pool,
               Info_Prefix.Original_Address,
               Info_Prefix.Size,
               Info_Prefix.Alignment);
         end;
      end if;
   end Deallocate;

   procedure Reallocate (
      Pool : in out Fallback_Storage_Pool;
      Storage_Address : in out Address;
      New_Size_In_Storage_Elements : in Storage_Elements.Storage_Count) is
   begin
      if Storage_Address = Null_Address then
         raise Constraint_Error with "Cannot reallocate Null_Address (Alignment can't be computed)";
      end if;

      declare
         New_Address : Address := Null_Address;
         Alignment : Storage_Count;
      begin
         declare
            Info_Prefix : T_Info_Prefix;
            for Info_Prefix'Address use Storage_Address - Info_Prefix_Size;
            pragma Import (Ada, Info_Prefix);
         begin
            Alignment := Info_Prefix.Alignment;
            Allocate (Pool, New_Address, New_Size_In_Storage_Elements, Alignment);
            Move (Storage_Address, New_Address,
               Unsigned_Addr (Storage_Count'Min (Info_Prefix.Size,
                                              New_Size_In_Storage_Elements)));
         end;
         Deallocate (Pool, Storage_Address);
         Storage_Address := New_Address;
      exception
         when others =>
            Deallocate (Pool, New_Address, New_Size_In_Storage_Elements, Alignment);
            raise;
      end;
   end Reallocate;

end Turbo_Private.Memory.Fallback;
