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

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

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

-- Turbo_Private.Generic_Atomic_32, x86 version

package body Turbo_Private.Generic_Atomic_32 is

   NL : constant String := (LF, HT);

   -------------
   -- Get_486 --
   -------------

   function Get_486 (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_486;

   -------------
   -- Get_486 --
   -------------

   function Get_486 (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_486;

   -------------
   -- Get_386 --
   -------------

   function Get_386 (Source : in Atomic_Type_32)
      return Type_32 is
   begin
      return Source.Item; -- no read reorders on 386
   end Get_386;

   -------------
   -- Get_386 --
   -------------

   function Get_386 (Source : not null access Atomic_Type_32)
      return Type_32 is
   begin
      return Source.Item; -- no read reorders on 386
   end Get_386;

   ----------------
   -- Get_*_Init --
   ----------------

   type T_Get_in is access function (Source : in Atomic_Type_32)
      return Type_32;
   --pragma Atomic (T_Get_in);

   type T_Get_not_null_access is
      access function (Source : not null access Atomic_Type_32)
         return Type_32;
   --pragma Atomic (T_Get_not_null_access);

   function Get_in_Init (Source : in Atomic_Type_32)
      return Type_32;

   function Get_not_null_access_Init
      (Source : not null access Atomic_Type_32) return Type_32;

   Get_in              : T_Get_in := Get_in_Init'Access;
   --pragma Atomic (Get_in);

   Get_not_null_access : T_Get_not_null_access := Get_not_null_access_Init'Access;
   
   -----------------
   -- Get_in_Init --
   -----------------

   function Get_in_Init (Source : in Atomic_Type_32)
      return Type_32
   is
      function Get_in_386 (Source : in Atomic_Type_32)
         return Type_32 renames Get_386;
      function Get_in_486 (Source : in Atomic_Type_32)
         return Type_32 renames Get_486;
   begin
      if CPU_Arch >= 4 then
         Get_in := Get_in_486'Access;
      else
         Get_in := Get_in_386'Access;
      end if;
      return Get_in (Source);
   end Get_in_Init;

   ------------------------------
   -- Get_not_null_access_Init --
   ------------------------------

   function Get_not_null_access_Init
      (Source : not null access Atomic_Type_32) return Type_32
   is
      function Get_not_null_access_386
         (Source : not null access Atomic_Type_32) return Type_32
         renames Get_386;
      function Get_not_null_access_486
         (Source : not null access Atomic_Type_32) return Type_32
         renames Get_486;
   begin
      if CPU_Arch >= 4 then
         Get_not_null_access := Get_not_null_access_486'Access;
      else
         Get_not_null_access := Get_not_null_access_386'Access;
      end if;
      return Get_not_null_access (Source);
   end Get_not_null_access_Init;

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

   function Get (Source : in Atomic_Type_32) return Type_32 is
   begin
      return Get_in (Source);
   end Get;

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

   function Get (Source : not null access Atomic_Type_32) return Type_32 is
   begin
      return Get_not_null_access (Source);
   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" & NL &
         "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" & NL &
         "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;
