Update casArray# test and add simple casMutVar# test.

2 files changed, 44 insertions, 2 deletions

diff --git a/testsuite/tests/concurrent/should_run/compareAndSwap.hs b/testsuite/tests/concurrent/should_run/compareAndSwap.hs
index a0966ab60e..a55734a9bd 100644
--- a/testsuite/tests/concurrent/should_run/compareAndSwap.hs
+++ b/testsuite/tests/concurrent/should_run/compareAndSwap.hs
@@ -1,5 +1,9 @@
 {-# Language MagicHash, UnboxedTuples  #-}
 
+-- | Note: extensive testing of atomic operations is performed in the
+-- "atomic-primops" library.  Only extremely rudimentary tests appear
+-- here.
+
 import GHC.IO
 import GHC.IORef
 import GHC.ST
@@ -7,6 +11,7 @@ import GHC.STRef
 import GHC.Prim
 import GHC.Base
 import Data.Primitive.Array
+import Data.IORef
 import Control.Monad
 
 ------------------------------------------------------------------------
@@ -16,13 +21,45 @@ casArrayST (MutableArray arr#) (I# i#) old new = ST$ \s1# ->
   case casArray# arr# i# old new s1# of 
     (# s2#, x#, res #) -> (# s2#, (x# ==# 0#, res) #)
 
+casSTRef :: STRef s a -- ^ The 'STRef' containing a value 'current'
+         -> a -- ^ The 'old' value to compare
+         -> a -- ^ The 'new' value to replace 'current' if @old == current@
+         -> ST s (Bool, a) 
+casSTRef (STRef var#) old new = ST $ \s1# ->
+   -- The primop treats the boolean as a sort of error code.
+   -- Zero means the CAS worked, one that it didn't.
+   -- We flip that here:
+    case casMutVar# var# old new s1# of
+      (# s2#, x#, res #) -> (# s2#, (x# ==# 0#, res) #)
+
+-- | Performs a machine-level compare and swap operation on an
+-- 'IORef'. Returns a tuple containing a 'Bool' which is 'True' when a
+-- swap is performed, along with the 'current' value from the 'IORef'.
+-- 
+-- Note \"compare\" here means pointer equality in the sense of
+-- 'GHC.Prim.reallyUnsafePtrEquality#'.
+casIORef :: IORef a -- ^ The 'IORef' containing a value 'current'
+         -> a -- ^ The 'old' value to compare
+         -> a -- ^ The 'new' value to replace 'current' if @old == current@
+         -> IO (Bool, a) 
+casIORef (IORef var) old new = stToIO (casSTRef var old new)
+
+
 ------------------------------------------------------------------------
 -- Make sure this Int corresponds to a single object in memory (NOINLINE):
 {-# NOINLINE mynum #-}
 mynum :: Int
 mynum = 33
 
-main = do 
+main = do
+  putStrLn "Perform a CAS within an IORef"
+  ref  <- newIORef mynum
+  res  <- casIORef ref mynum 44
+  res2 <- casIORef ref mynum 44
+  putStrLn$ "  1st try should succeed: "++show res
+  putStrLn$ "  2nd should fail: "++show res2
+
+  ------------------------------------------------------------
   putStrLn "Perform a CAS within a MutableArray#"
   arr <- newArray 5 mynum
 
@@ -36,4 +73,6 @@ main = do
     x <- readArray arr i 
     putStr ("  "++show x)
   putStrLn ""
+
+  ------------------------------------------------------------
   putStrLn "Done."
diff --git a/testsuite/tests/concurrent/should_run/compareAndSwap.stdout b/testsuite/tests/concurrent/should_run/compareAndSwap.stdout
index b3f1466e65..1b33a04630 100644
--- a/testsuite/tests/concurrent/should_run/compareAndSwap.stdout
+++ b/testsuite/tests/concurrent/should_run/compareAndSwap.stdout
@@ -1,5 +1,8 @@
+Perform a CAS within an IORef
+  1st try should succeed: (True,44)
+  2nd should fail: (False,44)
 Perform a CAS within a MutableArray#
-  1st try should succeed: (True,33)
+  1st try should succeed: (True,44)
   2nd should fail: (False,44)
 Printing array:
   33  33  33  44  33