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

-- no 386 support due to Atomic_Problem

with System.Machine_Code, Ada.Characters.Latin_1,
   Interfaces, Turbo_Private.CPUID;

use  System.Machine_Code, Ada.Characters.Latin_1,
   Interfaces, Turbo_Private.CPUID;

-- Turbo_Private.Generic_Atomic_32, x86 version

package body Turbo_Private.Generic_Atomic_32 is

   ---------
   -- Get --
   ---------

   function Get (Source : in Atomic_Type_32)
      return Type_32
   is
      -- circumvent Source's read-onlyness
      Item : Type_32;
      for Item'Address use Source.Item'Address;
      Result : Type_32;
   begin
      Asm (
         "lock xaddl %2, %0",
         Outputs  => (Type_32'Asm_Output ("=m", Item),
                      Type_32'Asm_Output ("=r", Result)),
         Inputs   => Unsigned_32'Asm_Input ("1", 0),
         Volatile => True
      );
      return Result;
   end Get;

   ---------
   -- Get --
   ---------

   function Get (Source : not null access Atomic_Type_32)
      return Type_32
   is
      Result : Type_32;
   begin
      Asm (
         "lock xaddl %2, %0",
         Outputs  => (Type_32'Asm_Output ("=m", Source.Item),
                      Type_32'Asm_Output ("=r", Result)),
         Inputs   => Unsigned_32'Asm_Input ("1", 0),
         Volatile => True
      );
      return Result;
   end Get;

   ---------
   -- Set --
   ---------

   procedure Set (Target : not null access Atomic_Type_32;
      Item : Type_32)
   is
      Dummy : Type_32;
   begin
      Asm (
         "lock xchgl %2, %0",
         Outputs  => (Type_32'Asm_Output ("=m", Target.Item),
                      Type_32'Asm_Output ("=r", Dummy)),
         Inputs   => Type_32'Asm_Input ("1", Item),
         Volatile => True
      );
   end Set;

   ---------
   -- Set --
   ---------

   procedure Set (Target : in out Atomic_Type_32;
      Item : Type_32)
   is
      Dummy : Type_32;
   begin
      Asm (
         "lock xchgl %2, %0",
         Outputs  => (Type_32'Asm_Output ("=m", Target.Item),
                      Type_32'Asm_Output ("=r", Dummy)),
         Inputs   => Type_32'Asm_Input ("1", Item),
         Volatile => True
      );
   end Set;

   ------------
   -- Create --
   ------------

   function Create (Item : Type_32) return Atomic_Type_32 is
   begin
      return Result : Atomic_Type_32 do
         Set (Result, Item);
      end return;
   end Create;

   ----------
   -- Swap --
   ----------

   function Swap (Target : not null access Atomic_Type_32;
      Item : Type_32) return Type_32
   is
      Result : Type_32;
   begin
      Asm (
         "lock xchgl %1, %0",
         Outputs  => (Type_32'Asm_Output ("+m", Target.Item),
                      Type_32'Asm_Output ("=r", Result)),
         Inputs   => Type_32'Asm_Input ("1", Item),
         Volatile => True
      );
      return Result;
   end Swap;

   ------------------
   -- Compare_Swap --
   ------------------
   
   function Compare_Swap (Target : not null access Atomic_Type_32;
      Comparand, New_Item : Type_32) return Boolean
   is
      Result : Boolean;
      Dummy : Type_32;
   begin
      Asm (
         "lock cmpxchgl %3, %0" & LF & HT &
         "setzb %1",
         Outputs  => (Type_32'Asm_Output ("+m", Target.Item),
                      Boolean'Asm_Output ("=rm", Result),
                      Type_32'Asm_Output ("=a", Dummy)),
         Inputs   => (Type_32'Asm_Input ("r", New_Item),
                      Type_32'Asm_Input ("a", Comparand)),
         Volatile => True
      );
      return Result;
   end Compare_Swap;

   ------------------
   -- Compare_Swap --
   ------------------

   -- internal
   function Compare_Swap (Target : not null access Type_32;
      Comparand, New_Item : Type_32) return Type_32
   is
      Result : Type_32;
   begin
      Asm (
         "lock cmpxchgl %2, %0",
         Outputs  => (Type_32'Asm_Output ("+m", Target.all),
                      Type_32'Asm_Output ("=a", Result)),
         Inputs   => (Type_32'Asm_Input ("r", New_Item),
                      Type_32'Asm_Input ("a", Comparand)),
         Volatile => True
      );
      return Result;
   end Compare_Swap;

   ------------------
   -- Compare_Swap --
   ------------------

   function Compare_Swap (Target : not null access Atomic_Type_32;
      Comparand, New_Item : Type_32) return Type_32
   is
      Result : Type_32;
   begin
      Asm (
         "lock cmpxchgl %2, %0",
         Outputs  => (Type_32'Asm_Output ("+m", Target.Item),
                      Type_32'Asm_Output ("=a", Result)),
         Inputs   => (Type_32'Asm_Input ("r", New_Item),
                      Type_32'Asm_Input ("a", Comparand)),
         Volatile => True
      );
      return Result;
   end Compare_Swap;

   ------------------
   -- Compare_Swap --
   ------------------

   function Compare_Swap (Target : not null access Atomic_Type_32;
      Comparand, New_Item : Type_32; Fetched : not null access Type_32)
      return Boolean
   is
      Result : Boolean;
   begin
      Asm (
         "lock cmpxchgl %3, %0" & LF & HT &
         "setzb %1",
         Outputs  => (Type_32'Asm_Output ("+m", Target.Item),
                      Boolean'Asm_Output ("=mr", Result),
                      Type_32'Asm_Output ("=a", Fetched.all)),
         Inputs   => (Type_32'Asm_Input ("r", New_Item),
                      Type_32'Asm_Input ("a", Comparand)),
         Volatile => True
      );
      return Result;
   end Compare_Swap;

end Turbo_Private.Generic_Atomic_32;
