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

-- TODO: Should Fetch use Read_Memory_Barrier?
-- rmb is "lock addl", "lock xaddl", "lock xchgl",
-- etc. on x86, so I decided to use lock xaddl to
-- implement Fetch. 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;

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;

   CPU_Type : Integer_32 := 0;
   pragma Atomic (CPU_Type);
   --   stands for
   -- 0 not detected yet
   -- 3 386
   -- 4 486
   -- 5 Pentium (or better)
   -- ? I was lazy enough to implement the further
   --   CPU detection, but one shouldn't count on my
   --   laziness. Once in a blue moon I might want to
   --   implement further CPU family detection.
   -- Use CPU_Type >= 5 as opposed to CPU_Type = 5

   ----------------
   -- Detect_CPU --
   ----------------

   procedure Detect_CPU is
      Dummy, Result : Integer_32;
      -- Q: What is this Dummy doing here?
      -- A: The manual named...
      -- Using the GNU Compiler Collection (GCC)
      -- 5.37 Assembler Instructions with C Expression Operands
      -- ...states the following:
      -- There is no way for you to specify that an input operand is
      -- modified without also specifying it as an output operand.
   begin
      -- 386 is guaranteed
      -- 486 has X86_EFLAGS_AC = 16#0004_0000#
      -- 586 has X86_EFLAGS_ID = 16#0020_0000#
      Asm (
         "pushfl" & NL &
            "pushfl" & NL &
            "popl %0" & NL &
            "movl %0, %1" & NL &
            "xorl %2, %0" & NL &
            "pushl %0" & NL &
            "popfl" & NL &
            "pushfl" & NL &
            "popl %0" & NL &
            "xorl %0, %1" & NL &
         "popfl",
          Outputs  => (Integer_32'Asm_Output ("=&r", Dummy),
                       Integer_32'Asm_Output ("=&r", Result)),
          Inputs   => (Integer_32'Asm_Input ("i", 16#0024_0000#))
      );
      case Result is
         when 16#0000_0000# => CPU_Type := 3;
         when 16#0004_0000# => CPU_Type := 4;
         when 16#0024_0000# => CPU_Type := 5;
            -- Detect further CPU here
         when others => raise Program_Error with "Failed to detect CPU family";
      end case;
   end Detect_CPU;

--    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;

   -----------
   -- Fetch --
   -----------

   function Fetch (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 Fetch;

   -----------
   -- Fetch --
   -----------

   function Fetch (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 Fetch;

   -----------
   -- Store --
   -----------

   procedure Store (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 Store;

   -----------
   -- Store --
   -----------

   procedure Store (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 Store;

   --------------
   -- Exchange --
   --------------

   function Exchange (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 Exchange;

   ----------------------
   -- Compare_Exchange --
   ----------------------
   
   function Compare_Exchange (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_Exchange;

   ----------------------
   -- Compare_Exchange --
   ----------------------

   -- Internal
   function Compare_Exchange (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_Exchange;

   ----------------------
   -- Compare_Exchange --
   ----------------------

   function Compare_Exchange (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_Exchange;

   ----------------------
   -- Compare_Exchange --
   ----------------------

   function Compare_Exchange (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_Exchange;

   ---------------------
   -- Increment_Fetch --
   ---------------------

   function Increment_Fetch (Addend : not null access Atomic_Integer_32)
      return Integer_32
   is
      -- Q: Why isn't Increment 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_Exchange (Addend, Old_Value, New_Value);
      exit when Fetched = Old_Value;
         Old_Value := Fetched;
      end loop;
      return New_Value;
   end Increment_Fetch;

   ---------------------
   -- Fetch_Increment --
   ---------------------

   function Fetch_Increment (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_Exchange (Addend, Old_Value, New_Value);
      exit when Fetched = Old_Value;
         Old_Value := Fetched;
      end loop;
      return Old_Value;
   end Fetch_Increment;

   ---------------
   -- Increment --
   ---------------

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

   ---------------
   -- Increment --
   ---------------

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

   ---------------------
   -- Increment_Fetch --
   ---------------------

   function Increment_Fetch (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_Exchange (Addend, Old_Value, New_Value);
      exit when Fetched = Old_Value;
         Old_Value := Fetched;
      end loop;
      return New_Value;
   end Increment_Fetch;

   ---------------------
   -- Fetch_Increment --
   ---------------------

   function Fetch_Increment (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_Exchange (Addend, Old_Value, New_Value);
      exit when Fetched = Old_Value;
         Old_Value := Fetched;
      end loop;
      return Old_Value;
   end Fetch_Increment;

   ---------------
   -- Increment --
   ---------------

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

   ---------------
   -- Increment --
   ---------------

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

   ---------------------
   -- Decrement_Fetch --
   ---------------------

   function Decrement_Fetch (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_Exchange (Addend, Old_Value, New_Value);
      exit when Fetched = Old_Value;
         Old_Value := Fetched;
      end loop;
      return New_Value;
   end Decrement_Fetch;

   ---------------------
   -- Fetch_Decrement --
   ---------------------

   function Fetch_Decrement (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_Exchange (Addend, Old_Value, New_Value);
      exit when Fetched = Old_Value;
         Old_Value := Fetched;
      end loop;
      return Old_Value;
   end Fetch_Decrement;

   ---------------
   -- Decrement --
   ---------------

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

   ---------------
   -- Decrement --
   ---------------

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

   ---------------------
   -- Decrement_Fetch --
   ---------------------

   function Decrement_Fetch (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_Exchange (Addend, Old_Value, New_Value);
      exit when Fetched = Old_Value;
         Old_Value := Fetched;
      end loop;
      return New_Value;
   end Decrement_Fetch;

   ---------------------
   -- Fetch_Decrement --
   ---------------------

   function Fetch_Decrement (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_Exchange (Addend, Old_Value, New_Value);
      exit when Fetched = Old_Value;
         Old_Value := Fetched;
      end loop;
      return Old_Value;
   end Fetch_Decrement;

   ---------------
   -- Decrement --
   ---------------

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

   ---------------
   -- Decrement --
   ---------------

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

end Turbo_Private.Atomic;
