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

-- TODO: Should Get use Read_Memory_Barrier?
-- rmb is "lock addl", "lock xaddl", "lock xchgl",
-- etc. on x86, so I decided to use lock xaddl 0 to
-- implement Get. I'm wondering if x86 CPUs are
-- clever enough to omit overwritting memory cell
-- with the same value as before.

-- TODO: Look on Java implementation
-- It's not obvious where to look for.
-- Created topic on programmersforum.ru
-- TODO: Look harder

with Interfaces, System, System.Machine_Code;

use  Interfaces, System, System.Machine_Code;

with private Turbo_Private.Atomic_Integer_32_Package;

package body Turbo_Private.Atomic is

   LF : constant String := (1 => Character'Val (10));
   HT : constant String := (1 => Character'Val (9));

   NL : constant String := LF & HT;

--    procedure Memory_Barrier is
--    begin
--       Asm (
--          "lock addl $0, 0(%%esp)",
--          Clobber => "memory",
--          Volatile => True
--       );
--    end Memory_Barrier;

--    procedure Write_Memory_Barrier is
--    begin
--       Asm (
--          "",
--          Clobber => "memory",
--          Volatile => True
--       );
--    end Write_Memory_Barrier;

--    procedure Read_Memory_Barrier is
--    begin
--       Asm (
--          "lock addl $0, 0(%%esp)",
--          Clobber => "memory",
--          Volatile => True
--       );
--    end Read_Memory_Barrier;

--    ---------
--    -- Get --
--    ---------
-- 
--    function Get (Source : in Atomic_Integer_32)
--       return Integer_32
--    is
--       -- circumvent Source's read-onlyness
--       Item : Integer_32;
--       for Item'Address use Source.Item'Address;
--       Result : Integer_32;
--    begin
-- --      return Source.Item;
--       Asm (
--          "lock xaddl %2, %0",
--          Outputs  => (Integer_32'Asm_Output ("=m", Item),
--                       Integer_32'Asm_Output ("=r", Result)),
--          Inputs   => Integer_32'Asm_Input ("1", 0),
--          Volatile => True
--       );
--       return Result;
--    end Get;
-- 
--    ---------
--    -- Get --
--    ---------
-- 
--    function Get (Source : not null access Atomic_Integer_32)
--       return Integer_32
--    is
--       Result : Integer_32;
--    begin
--       Asm (
--          "lock xaddl %2, %0",
--          Outputs  => (Integer_32'Asm_Output ("=m", Source.Item),
--                       Integer_32'Asm_Output ("=r", Result)),
--          Inputs   => Integer_32'Asm_Input ("1", 0),
--          Volatile => True
--       );
--       return Result;
-- --      return Source.Item;
--    end Get;
-- 
--    ---------
--    -- Set --
--    ---------
-- 
--    procedure Set (Target : not null access Atomic_Integer_32;
--       Item : Integer_32)
--    is
--       Dummy : Integer_32;
--    begin
-- --      Target.Item := Item;
--       Asm (
--          "lock xchgl %2, %0",
--          Outputs  => (Integer_32'Asm_Output ("=m", Target.Item),
--                       Integer_32'Asm_Output ("=r", Dummy)),
--          Inputs   => Integer_32'Asm_Input ("1", Item),
--          Volatile => True
--       );
--    end Set;
-- 
--    ---------
--    -- Set --
--    ---------
-- 
--    procedure Set (Target : in out Atomic_Integer_32;
--       Item : Integer_32)
--    is
--       Dummy : Integer_32;
--    begin
-- --      Target.Item := Item;
--       Asm (
--          "lock xchgl %2, %0",
--          Outputs  => (Integer_32'Asm_Output ("=m", Target.Item),
--                       Integer_32'Asm_Output ("=r", Dummy)),
--          Inputs   => Integer_32'Asm_Input ("1", Item),
--          Volatile => True
--       );
--    end Set;
-- 
--    ------------
--    -- Create --
--    ------------
-- 
--    function Create (Item : Integer_32) return Atomic_Integer_32 is
--    begin
--       return Result : Atomic_Integer_32 do
--          Set (Result, Item);
--       end return;
--    end Create;
-- 
--    ----------
--    -- Swap --
--    ----------
-- 
--    function Swap (Target : not null access Atomic_Integer_32;
--       Item : Integer_32) return Integer_32
--    is
--       Result : Integer_32;
--    begin
--       Asm (
--          "lock xchgl %1, %0",
--          Outputs  => (Integer_32'Asm_Output ("+m", Target.Item),
--                       Integer_32'Asm_Output ("=r", Result)),
--          Inputs   => Integer_32'Asm_Input ("1", Item),
--          Volatile => True
--       );
--       return Result;
--    end Swap;
-- 
--    ------------------
--    -- Compare_Swap --
--    ------------------
--    
--    function Compare_Swap (Target : not null access Atomic_Integer_32;
--       Comparand, New_Item : Integer_32) return Boolean
--    is
--       Result : Boolean;
--       Dummy : Integer_32;
--    begin
--       Asm (
--          "lock cmpxchgl %3, %0" & NL &
--          "setzb %1",
--          Outputs  => (Integer_32'Asm_Output ("+m", Target.Item),
--                       Boolean'Asm_Output ("=rm", Result),
--                       Integer_32'Asm_Output ("=a", Dummy)),
--          Inputs   => (Integer_32'Asm_Input ("r", New_Item),
--                       Integer_32'Asm_Input ("a", Comparand)),
--          Volatile => True
--       );
--       return Result;
--    end Compare_Swap;
-- 
--    ------------------
--    -- Compare_Swap --
--    ------------------
-- 
--    -- Internal
--    function Compare_Swap (Target : not null access Integer_32;
--       Comparand, New_Item : Integer_32) return Integer_32
--    is
--       Result : Integer_32;
--    begin
--       Asm (
--          "lock cmpxchgl %2, %0",
--          Outputs  => (Integer_32'Asm_Output ("+m", Target.all),
--                       Integer_32'Asm_Output ("=a", Result)),
--          Inputs   => (Integer_32'Asm_Input ("r", New_Item),
--                       Integer_32'Asm_Input ("a", Comparand)),
--          Volatile => True
--       );
--       return Result;
--    end Compare_Swap;
-- 
--    ------------------
--    -- Compare_Swap --
--    ------------------
-- 
--    function Compare_Swap (Target : not null access Atomic_Integer_32;
--       Comparand, New_Item : Integer_32) return Integer_32
--    is
--       Result : Integer_32;
--    begin
--       Asm (
--          "lock cmpxchgl %2, %0",
--          Outputs  => (Integer_32'Asm_Output ("+m", Target.Item),
--                       Integer_32'Asm_Output ("=a", Result)),
--          Inputs   => (Integer_32'Asm_Input ("r", New_Item),
--                       Integer_32'Asm_Input ("a", Comparand)),
--          Volatile => True
--       );
--       return Result;
--    end Compare_Swap;
-- 
--    ------------------
--    -- Compare_Swap --
--    ------------------
-- 
--    function Compare_Swap (Target : not null access Atomic_Integer_32;
--       Comparand, New_Item : Integer_32; Fetched : not null access Integer_32)
--       return Boolean
--    is
--       Result : Boolean;
--    begin
--       Asm (
--          "lock cmpxchgl %3, %0" & NL &
--          "setzb %1",
--          Outputs  => (Integer_32'Asm_Output ("+m", Target.Item),
--                       Boolean'Asm_Output ("=mr", Result),
--                       Integer_32'Asm_Output ("=a", Fetched.all)),
--          Inputs   => (Integer_32'Asm_Input ("r", New_Item),
--                       Integer_32'Asm_Input ("a", Comparand)),
--          Volatile => True
--       );
--       return Result;
--    end Compare_Swap;

   -------------
   -- Inc_Get --
   -------------

   function Inc_Get (Addend : not null access Atomic_Integer_32)
      return Integer_32
   is
      -- Q: Why isn't Inc implemented with xaddl?
      -- A: This is due to potential overflow. Use
      -- Unsigned_* instead if you don't care about
      -- overflows.
      Old_Value, New_Value, Fetched : Integer_32;
   begin
      Old_Value := Addend.Item;
      loop
         New_Value := Old_Value + 1;
         Fetched := Compare_Swap (Addend, Old_Value, New_Value);
      exit when Fetched = Old_Value;
         Old_Value := Fetched;
      end loop;
      return New_Value;
   end Inc_Get;

   -------------
   -- Get_Inc --
   -------------

   function Get_Inc (Addend : not null access Atomic_Integer_32)
      return Integer_32
   is
      Old_Value, New_Value, Fetched : Integer_32;
   begin
      Old_Value := Addend.Item;
      loop
         New_Value := Old_Value + 1;
         Fetched := Compare_Swap (Addend, Old_Value, New_Value);
      exit when Fetched = Old_Value;
         Old_Value := Fetched;
      end loop;
      return Old_Value;
   end Get_Inc;

   ---------
   -- Inc --
   ---------

   procedure Inc (Addend : in out Atomic_Integer_32) is
      Value, Fetched : Integer_32;
   begin
      Value := Addend.Item;
      loop
         Fetched := Compare_Swap (Addend.Item'Access, Value, Value + 1);
      exit when Fetched = Value;
         Value := Fetched;
      end loop;      
   end Inc;

   ---------
   -- Inc --
   ---------

   procedure Inc (Addend : not null access Atomic_Integer_32) is
      Value, Fetched : Integer_32;
   begin
      Value := Addend.Item;
      loop
         Fetched := Compare_Swap (Addend, Value, Value + 1);
      exit when Fetched = Value;
         Value := Fetched;
      end loop;      
   end Inc;

   -------------
   -- Inc_Get --
   -------------

   function Inc_Get (Addend : not null access Atomic_Integer_32;
      Item : Integer_32) return Integer_32
   is
      Old_Value, New_Value, Fetched : Integer_32;
   begin
      Old_Value := Addend.Item;
      loop
         New_Value := Old_Value + Item;
         Fetched := Compare_Swap (Addend, Old_Value, New_Value);
      exit when Fetched = Old_Value;
         Old_Value := Fetched;
      end loop;
      return New_Value;
   end Inc_Get;

   -------------
   -- Get_Inc --
   -------------

   function Get_Inc (Addend : not null access Atomic_Integer_32;
      Item : Integer_32) return Integer_32
   is
      Old_Value, New_Value, Fetched : Integer_32;
   begin
      Old_Value := Addend.Item;
      loop
         New_Value := Old_Value + Item;
         Fetched := Compare_Swap (Addend, Old_Value, New_Value);
      exit when Fetched = Old_Value;
         Old_Value := Fetched;
      end loop;
      return Old_Value;
   end Get_Inc;

   ---------
   -- Inc --
   ---------

   procedure Inc (Addend : in out Atomic_Integer_32;
      Item : Integer_32)
   is
      Value, Fetched : Integer_32;
   begin
      Value := Addend.Item;
      loop
         Fetched := Compare_Swap (Addend.Item'Access, Value, Value + Item);
      exit when Fetched = Value;
         Value := Fetched;
      end loop;      
   end Inc;

   ---------
   -- Inc --
   ---------

   procedure Inc (Addend : not null access Atomic_Integer_32;
      Item : Integer_32)
   is
      Value, Fetched : Integer_32;
   begin
      Value := Addend.Item;
      loop
         Fetched := Compare_Swap (Addend, Value, Value + 1);
      exit when Fetched = Value;
         Value := Fetched;
      end loop;      
   end Inc;

   -------------
   -- Dec_Get --
   -------------

   function Dec_Get (Addend : not null access Atomic_Integer_32)
      return Integer_32
   is
      Old_Value, New_Value, Fetched : Integer_32;
   begin
      Old_Value := Addend.Item;
      loop
         New_Value := Old_Value - 1;
         Fetched := Compare_Swap (Addend, Old_Value, New_Value);
      exit when Fetched = Old_Value;
         Old_Value := Fetched;
      end loop;
      return New_Value;
   end Dec_Get;

   -------------
   -- Get_Dec --
   -------------

   function Get_Dec (Addend : not null access Atomic_Integer_32)
      return Integer_32
   is
      Old_Value, New_Value, Fetched : Integer_32;
   begin
      Old_Value := Addend.Item;
      loop
         New_Value := Old_Value - 1;
         Fetched := Compare_Swap (Addend, Old_Value, New_Value);
      exit when Fetched = Old_Value;
         Old_Value := Fetched;
      end loop;
      return Old_Value;
   end Get_Dec;

   ---------
   -- Dec --
   ---------

   procedure Dec (Addend : in out Atomic_Integer_32) is
      Value, Fetched : Integer_32;
   begin
      Value := Addend.Item;
      loop
         Fetched := Compare_Swap (Addend.Item'Access, Value, Value - 1);
      exit when Fetched = Value;
         Value := Fetched;
      end loop;      
   end Dec;

   ---------
   -- Dec --
   ---------

   procedure Dec (Addend : not null access Atomic_Integer_32) is
      Value, Fetched : Integer_32;
   begin
      Value := Addend.Item;
      loop
         Fetched := Compare_Swap (Addend.Item'Access, Value, Value - 1);
      exit when Fetched = Value;
         Value := Fetched;
      end loop;      
   end Dec;

   -------------
   -- Dec_Get --
   -------------

   function Dec_Get (Addend : not null access Atomic_Integer_32;
      Item : Integer_32) return Integer_32
   is
      Old_Value, New_Value, Fetched : Integer_32;
   begin
      Old_Value := Addend.Item;
      loop
         New_Value := Old_Value - Item;
         Fetched := Compare_Swap (Addend, Old_Value, New_Value);
      exit when Fetched = Old_Value;
         Old_Value := Fetched;
      end loop;
      return New_Value;
   end Dec_Get;

   -------------
   -- Get_Dec --
   -------------

   function Get_Dec (Addend : not null access Atomic_Integer_32;
      Item : Integer_32) return Integer_32
   is
      Old_Value, New_Value, Fetched : Integer_32;
   begin
      Old_Value := Addend.Item;
      loop
         New_Value := Old_Value - Item;
         Fetched := Compare_Swap (Addend, Old_Value, New_Value);
      exit when Fetched = Old_Value;
         Old_Value := Fetched;
      end loop;
      return Old_Value;
   end Get_Dec;

   ---------
   -- Dec --
   ---------

   procedure Dec (Addend : in out Atomic_Integer_32;
      Item : Integer_32)
   is
      Value, Fetched : Integer_32;
   begin
      Value := Addend.Item;
      loop
         Fetched := Compare_Swap (Addend.Item'Access, Value, Value - Item);
      exit when Fetched = Value;
         Value := Fetched;
      end loop;      
   end Dec;

   ---------
   -- Dec --
   ---------

   procedure Dec (Addend : not null access Atomic_Integer_32;
      Item : Integer_32)
   is
      Value, Fetched : Integer_32;
   begin
      Value := Addend.Item;
      loop
         Fetched := Compare_Swap (Addend, Value, Value - Item);
      exit when Fetched = Value;
         Value := Fetched;
      end loop;      
   end Dec;

end Turbo_Private.Atomic;
