WinIO: Small changes related to atomic request swaps.

Move the atomix exchange over the Ptr type to an internal module.

Fix a bug caused by us passing ptr-to-ptr instead of ptr to
atomic exchange.

Renamed interlockedExchange to exchangePtr.

I've also added an cas primitive. It turned out we don't need it
for WinIO but I'm leaving it in as it's useful for other things.

5 files changed, 63 insertions, 4 deletions

diff --git a/testsuite/tests/codeGen/should_compile/cg011.hs b/testsuite/tests/codeGen/should_compile/cg011.hs
index 5d80968547..5d86621784 100644
--- a/testsuite/tests/codeGen/should_compile/cg011.hs
+++ b/testsuite/tests/codeGen/should_compile/cg011.hs
@@ -1,11 +1,11 @@
 {-# LANGUAGE CPP, MagicHash, BlockArguments, UnboxedTuples #-}
 
--- Tests compilation for interlockedExchange primop.
+-- Tests compilation for atomic exchange primop.
 
 module M where
 
-import GHC.Exts (interlockedExchangeInt#, Int#, Addr#, State# )
+import GHC.Exts (atomicExchangeInt#, Int#, Addr#, State# )
 
 swap :: Addr# -> Int# -> State# s -> (# #)
-swap ptr val s = case (interlockedExchangeInt# ptr val s) of
+swap ptr val s = case (atomicExchangeInt# ptr val s) of
             (# s2, old_val #) -> (# #)
diff --git a/testsuite/tests/codeGen/should_run/all.T b/testsuite/tests/codeGen/should_run/all.T
index 8892b506e4..bc7dcbd8f1 100644
--- a/testsuite/tests/codeGen/should_run/all.T
+++ b/testsuite/tests/codeGen/should_run/all.T
@@ -90,6 +90,7 @@ test('cgrun077', [when(have_cpu_feature('bmi2'), extra_hc_opts('-mbmi2'))], comp
 test('cgrun078', omit_ways(['ghci']), compile_and_run, [''])
 test('cgrun079', normal, compile_and_run, [''])
 test('cgrun080', normal, compile_and_run, [''])
+test('cas_int', normal, compile_and_run, [''])
 
 test('T1852', normal, compile_and_run, [''])
 test('T1861', extra_run_opts('0'), compile_and_run, [''])
diff --git a/testsuite/tests/codeGen/should_run/cas_int.hs b/testsuite/tests/codeGen/should_run/cas_int.hs
new file mode 100644
index 0000000000..e1d4905944
--- /dev/null
+++ b/testsuite/tests/codeGen/should_run/cas_int.hs
@@ -0,0 +1,54 @@
+{-# LANGUAGE CPP, MagicHash, BlockArguments, UnboxedTuples #-}
+{-# LANGUAGE CPP, MagicHash, BlockArguments, ScopedTypeVariables #-}
+
+-- Test the atomic exchange primop.
+
+-- We initialize a value with 1, and then perform exchanges on it
+-- with two different values. At the end all the values should still
+-- be present.
+
+module Main ( main ) where
+
+import Data.Bits
+import GHC.Int
+import GHC.Prim
+import GHC.Word
+import Control.Monad
+import Control.Concurrent
+import Foreign.Marshal.Alloc
+import Foreign.Storable
+import Data.List (sort)
+
+import GHC.Exts
+import GHC.Types
+import GHC.Ptr
+
+#include "MachDeps.h"
+
+main = do
+   alloca $ \(ptr_p :: Ptr (Ptr Int)) -> do
+   alloca $ \(ptr_i :: Ptr Int) -> do
+   alloca $ \(ptr_j :: Ptr Int) -> do
+      poke ptr_i (1 :: Int)
+      poke ptr_j (2 :: Int)
+
+      --expected to swap
+      res_i <- cas ptr_i 1 3 :: IO Int
+      -- expected to fail
+      res_j <- cas ptr_j 1 4 :: IO Int
+
+      putStrLn "Returned results:"
+      --(1,2)
+      print (res_i, res_j)
+
+      i <-peek ptr_i
+      j <-peek ptr_j
+
+      putStrLn "Stored results:"
+      --(3,2)
+      print (i,j)
+
+cas :: Ptr Int -> Int -> Int -> IO Int
+cas (Ptr ptr) (I# expected) (I# desired)= do
+   IO $ \s -> case (atomicCasInt# ptr expected desired s) of
+            (# s2, old_val #) -> (# s2, I# old_val #)
diff --git a/testsuite/tests/codeGen/should_run/cas_int.stdout b/testsuite/tests/codeGen/should_run/cas_int.stdout
new file mode 100644
index 0000000000..0b50c37bfd
--- /dev/null
+++ b/testsuite/tests/codeGen/should_run/cas_int.stdout
@@ -0,0 +1,4 @@
+Returned results:
+(1,2)
+Stored results:
+(3,2)
diff --git a/testsuite/tests/codeGen/should_run/cgrun080.hs b/testsuite/tests/codeGen/should_run/cgrun080.hs
index 5390dd11ae..4e09cd7634 100644
--- a/testsuite/tests/codeGen/should_run/cgrun080.hs
+++ b/testsuite/tests/codeGen/should_run/cgrun080.hs
@@ -46,6 +46,6 @@ swapN n val ptr = do
 
 swap :: Ptr Int -> Int -> IO Int
 swap (Ptr ptr) (I# val) = do
-   IO $ \s -> case (interlockedExchangeInt# ptr val s) of
+   IO $ \s -> case (atomicExchangeInt# ptr val s) of
             (# s2, old_val #) -> (# s2, I# old_val #)