[commit: testsuite] atomics: Update casArray# test and add simple casMutVar# test. (d7f5812)

[git at git.haskell.org]

Repository : ssh://git@git.haskell.org/testsuite

On branch  : atomics
Link       : http://ghc.haskell.org/trac/ghc/changeset/d7f58121f10f749e930d5576b845c501205487dd/testsuite

>---------------------------------------------------------------

commit d7f58121f10f749e930d5576b845c501205487dd
Author: Ryan Newton <rrnewton at gmail.com>
Date:   Sun Aug 4 23:40:51 2013 -0400

    Update casArray# test and add simple casMutVar# test.


>---------------------------------------------------------------

d7f58121f10f749e930d5576b845c501205487dd
 tests/concurrent/should_run/compareAndSwap.hs     |   39 +++++++++++++++++++++
 tests/concurrent/should_run/compareAndSwap.stdout |    5 ++-
 2 files changed, 43 insertions(+), 1 deletion(-)

diff --git a/tests/concurrent/should_run/compareAndSwap.hs b/tests/concurrent/should_run/compareAndSwap.hs
index a0966ab..a55734a 100644
--- a/tests/concurrent/should_run/compareAndSwap.hs
+++ b/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,6 +21,30 @@ 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 #-}
@@ -23,6 +52,14 @@ mynum :: Int
 mynum = 33
 
 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/tests/concurrent/should_run/compareAndSwap.stdout b/tests/concurrent/should_run/compareAndSwap.stdout
index b3f1466..1b33a04 100644
--- a/tests/concurrent/should_run/compareAndSwap.stdout
+++ b/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