Naming, value types and tests for Addr# atomics

The atomic Exchange and CAS operations on integral types are updated to
take and return more natural `Word#` rather than `Int#` values.  These
are bit-block not arithmetic operations, and the sign bit plays no
special role.

Standardises the names to `atomic<OpType><ValType>Addr#`, where `OpType` is one
of `Cas` or `Exchange` and `ValType` is presently either `Word` or `Addr`.
Eventually, variants for `Word32` and `Word64` can and should be added,
once #11953 and related issues (e.g. #13825) are resolved.

Adds tests for `Addr#` CAS that mirror existing tests for
`MutableByteArray#`.

8 files changed, 128 insertions, 30 deletions

diff --git a/compiler/GHC/Builtin/primops.txt.pp b/compiler/GHC/Builtin/primops.txt.pp
index 261d02aa67..170c6b2f8d 100644
--- a/compiler/GHC/Builtin/primops.txt.pp
+++ b/compiler/GHC/Builtin/primops.txt.pp
@@ -2471,17 +2471,47 @@ primop  WriteOffAddrOp_Word64 "writeWord64OffAddr#" GenPrimOp
    with has_side_effects = True
         can_fail         = True
 
-primop  InterlockedExchange_Addr "interlockedExchangeAddr#" GenPrimOp
+primop  InterlockedExchange_Addr "atomicExchangeAddrAddr#" GenPrimOp
    Addr# -> Addr# -> State# s -> (# State# s, Addr# #)
    {The atomic exchange operation. Atomically exchanges the value at the first address
     with the Addr# given as second argument. Implies a read barrier.}
    with has_side_effects = True
+        can_fail         = True
 
-primop  InterlockedExchange_Int "interlockedExchangeInt#" GenPrimOp
-   Addr# -> Int# -> State# s -> (# State# s, Int# #)
+primop  InterlockedExchange_Word "atomicExchangeWordAddr#" GenPrimOp
+   Addr# -> Word# -> State# s -> (# State# s, Word# #)
    {The atomic exchange operation. Atomically exchanges the value at the address
     with the given value. Returns the old value. Implies a read barrier.}
    with has_side_effects = True
+        can_fail         = True
+
+primop  CasAddrOp_Addr "atomicCasAddrAddr#" GenPrimOp
+   Addr# -> Addr# -> Addr# -> State# s -> (# State# s, Addr# #)
+   { Compare and swap on a word-sized memory location.
+
+     Use as: \s -> atomicCasAddrAddr# location expected desired s
+
+     This version always returns the old value read. This follows the normal
+     protocol for CAS operations (and matches the underlying instruction on
+     most architectures).
+
+     Implies a full memory barrier.}
+   with has_side_effects = True
+        can_fail         = True
+
+primop  CasAddrOp_Word "atomicCasWordAddr#" GenPrimOp
+   Addr# -> Word# -> Word# -> State# s -> (# State# s, Word# #)
+   { Compare and swap on a word-sized and aligned memory location.
+
+     Use as: \s -> atomicCasWordAddr# location expected desired s
+
+     This version always returns the old value read. This follows the normal
+     protocol for CAS operations (and matches the underlying instruction on
+     most architectures).
+
+     Implies a full memory barrier.}
+   with has_side_effects = True
+        can_fail         = True
 
 ------------------------------------------------------------------------
 section "Mutable variables"
diff --git a/compiler/GHC/StgToCmm/Prim.hs b/compiler/GHC/StgToCmm/Prim.hs
index afbcc34836..1bc6954f3c 100644
--- a/compiler/GHC/StgToCmm/Prim.hs
+++ b/compiler/GHC/StgToCmm/Prim.hs
@@ -846,9 +846,14 @@ emitPrimOp dflags primop = case primop of
 -- Atomic operations
   InterlockedExchange_Addr -> \[src, value] -> opIntoRegs $ \[res] ->
     emitPrimCall [res] (MO_Xchg (wordWidth platform)) [src, value]
-  InterlockedExchange_Int -> \[src, value] -> opIntoRegs $ \[res] ->
+  InterlockedExchange_Word -> \[src, value] -> opIntoRegs $ \[res] ->
     emitPrimCall [res] (MO_Xchg (wordWidth platform)) [src, value]
 
+  CasAddrOp_Addr -> \[dst, expected, new] -> opIntoRegs $ \[res] ->
+    emitPrimCall [res] (MO_Cmpxchg (wordWidth platform)) [dst, expected, new]
+  CasAddrOp_Word -> \[dst, expected, new] -> opIntoRegs $ \[res] ->
+    emitPrimCall [res] (MO_Cmpxchg (wordWidth platform)) [dst, expected, new]
+
 -- SIMD primops
   (VecBroadcastOp vcat n w) -> \[e] -> opIntoRegs $ \[res] -> do
     checkVecCompatibility dflags vcat n w
diff --git a/libraries/base/GHC/Ptr.hs b/libraries/base/GHC/Ptr.hs
index 6cbcc07ddc..612d3ef94b 100644
--- a/libraries/base/GHC/Ptr.hs
+++ b/libraries/base/GHC/Ptr.hs
@@ -171,7 +171,7 @@ castPtrToFunPtr (Ptr addr) = FunPtr addr
 exchangePtr :: Ptr (Ptr a) -> Ptr b -> IO (Ptr c)
 exchangePtr (Ptr dst) (Ptr val) =
   IO $ \s ->
-      case (interlockedExchangeAddr# dst val s) of
+      case (atomicExchangeAddrAddr# dst val s) of
         (# s2, old_val #) -> (# s2, Ptr old_val #)
 
 ------------------------------------------------------------------------
diff --git a/libraries/ghc-prim/changelog.md b/libraries/ghc-prim/changelog.md
index 3df0b5e2ed..4a3e9f640c 100644
--- a/libraries/ghc-prim/changelog.md
+++ b/libraries/ghc-prim/changelog.md
@@ -21,8 +21,13 @@
 
 - Add primops for atomic exchange:
 
-        interlockedExchangeAddr# :: Addr# -> Addr# -> State# s -> (# State# s, Addr# #)
-        interlockedExchangeInt# :: Addr# -> Int# -> State# s -> (# State# s, Int# #)
+        atomicExchangeAddrAddr# :: Addr# -> Addr# -> State# s -> (# State# s, Addr# #)
+        atomicExchangeWordAddr# :: Addr# -> Word# -> State# s -> (# State# s, Word# #)
+
+- Add primops for atomic compare and swap at a given Addr#:
+
+        atomicCasAddrAddr# :: Addr# -> Addr# -> Addr# -> State# s -> (# State# s, Addr# #)
+        atomicCasWordAddr# :: Addr# -> Word# -> Word# -> State# s -> (# State# s, Word# #)
 
 - Add an explicit fixity for `(~)` and `(~~)`: 
 
diff --git a/testsuite/tests/codeGen/should_compile/cg011.hs b/testsuite/tests/codeGen/should_compile/cg011.hs
index 5d80968547..77f2e6f7f9 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 atomicExchangeWordAddr# primop.
 
 module M where
 
-import GHC.Exts (interlockedExchangeInt#, Int#, Addr#, State# )
+import GHC.Exts (atomicExchangeWordAddr#, Word#, Addr#, State# )
 
-swap :: Addr# -> Int# -> State# s -> (# #)
-swap ptr val s = case (interlockedExchangeInt# ptr val s) of
+swap :: Addr# -> Word# -> State# s -> (# #)
+swap ptr val s = case (atomicExchangeWordAddr# ptr val s) of
             (# s2, old_val #) -> (# #)
diff --git a/testsuite/tests/codeGen/should_run/cgrun080.hs b/testsuite/tests/codeGen/should_run/cgrun080.hs
index 5390dd11ae..78d54700f9 100644
--- a/testsuite/tests/codeGen/should_run/cgrun080.hs
+++ b/testsuite/tests/codeGen/should_run/cgrun080.hs
@@ -25,8 +25,8 @@ import GHC.Types
 
 main = do
    alloca $ \ptr_i -> do
-      poke ptr_i (1 :: Int)
-      w1 <- newEmptyMVar :: IO (MVar Int)
+      poke ptr_i (1 :: Word)
+      w1 <- newEmptyMVar :: IO (MVar Word)
       forkIO $ do
          v <- swapN 50000 2 ptr_i
          putMVar w1 v
@@ -37,15 +37,14 @@ main = do
       -- Should be [1,2,3]
       print $ sort [v0,v1,v2]
 
-swapN :: Int -> Int -> Ptr Int -> IO Int
+swapN :: Word -> Word -> Ptr Word -> IO Word
 swapN 0 val ptr = return val
 swapN n val ptr = do
    val' <- swap ptr val
    swapN (n-1) val' ptr
 
 
-swap :: Ptr Int -> Int -> IO Int
-swap (Ptr ptr) (I# val) = do
-   IO $ \s -> case (interlockedExchangeInt# ptr val s) of
-            (# s2, old_val #) -> (# s2, I# old_val #)
-
+swap :: Ptr Word -> Word -> IO Word
+swap (Ptr ptr) (W# val) = do
+   IO $ \s -> case (atomicExchangeWordAddr# ptr val s) of
+            (# s2, old_val #) -> (# s2, W# old_val #)
diff --git a/testsuite/tests/concurrent/should_run/AtomicPrimops.hs b/testsuite/tests/concurrent/should_run/AtomicPrimops.hs
index 1789e26bbb..aeed9eaab6 100644
--- a/testsuite/tests/concurrent/should_run/AtomicPrimops.hs
+++ b/testsuite/tests/concurrent/should_run/AtomicPrimops.hs
@@ -6,6 +6,8 @@ module Main ( main ) where
 import Control.Concurrent
 import Control.Concurrent.MVar
 import Control.Monad (when)
+import Foreign.Marshal.Alloc
+import Foreign.Ptr
 import Foreign.Storable
 import GHC.Exts
 import GHC.IO
@@ -22,6 +24,7 @@ main = do
     fetchOrTest
     fetchXorTest
     casTest
+    casTestAddr
     readWriteTest
 
 -- | Test fetchAddIntArray# by having two threads concurrenctly
@@ -54,12 +57,14 @@ fetchXorTest = do
     work mba 0 val = return ()
     work mba n val = fetchXorIntArray mba 0 val >> work mba (n-1) val
 
-    -- Initial value is a large prime and the two patterns are 1010...
-    -- and 0101...
+    -- The two patterns are 1010...  and 0101...  The second pattern is larger
+    -- than maxBound, avoid warnings by initialising as a Word.
     (n0, t1pat, t2pat)
         | sizeOf (undefined :: Int) == 8 =
-            (0x00000000ffffffff, 0x5555555555555555, 0x9999999999999999)
-        | otherwise = (0x0000ffff, 0x55555555, 0x99999999)
+            ( 0x00000000ffffffff, 0x5555555555555555
+            , fromIntegral (0x9999999999999999 :: Word))
+        | otherwise = ( 0x0000ffff, 0x55555555
+                      , fromIntegral (0x99999999 :: Word))
     expected
         | sizeOf (undefined :: Int) == 8 = 4294967295
         | otherwise = 65535
@@ -90,13 +95,15 @@ fetchOpTest op expected name = do
 
 -- | Initial value and operation arguments for race test.
 --
--- Initial value is a large prime and the two patterns are 1010...
--- and 0101...
+-- The two patterns are 1010...  and 0101...  The second pattern is larger than
+-- maxBound, avoid warnings by initialising as a Word.
 n0, t1pat, t2pat :: Int
 (n0, t1pat, t2pat)
     | sizeOf (undefined :: Int) == 8 =
-        (0x00000000ffffffff, 0x5555555555555555, 0x9999999999999999)
-    | otherwise = (0x0000ffff, 0x55555555, 0x99999999)
+        ( 0x00000000ffffffff, 0x5555555555555555
+        , fromIntegral (0x9999999999999999 :: Word))
+    | otherwise = ( 0x0000ffff, 0x55555555
+                  , fromIntegral (0x99999999 :: Word))
 
 fetchAndTest :: IO ()
 fetchAndTest = fetchOpTest fetchAndIntArray expected "fetchAndTest"
@@ -120,8 +127,10 @@ fetchNandTest = do
 fetchOrTest :: IO ()
 fetchOrTest = fetchOpTest fetchOrIntArray expected "fetchOrTest"
   where expected
-            | sizeOf (undefined :: Int) == 8 = 15987178197787607039
-            | otherwise = 3722313727
+            | sizeOf (undefined :: Int) == 8
+            = fromIntegral (15987178197787607039 :: Word)
+            | otherwise
+            = fromIntegral (3722313727 :: Word)
 
 -- | Test casIntArray# by using it to emulate fetchAddIntArray# and
 -- then having two threads concurrenctly increment a counter,
@@ -131,7 +140,7 @@ casTest = do
     tot <- race 0
         (\ mba -> work mba iters 1)
         (\ mba -> work mba iters 2)
-    assertEq 3000000 tot "casTest"
+    assertEq (3 * iters) tot "casTest"
   where
     work :: MByteArray -> Int -> Int -> IO ()
     work mba 0 val = return ()
@@ -179,6 +188,45 @@ race n0 thread1 thread2 = do
     mapM_ takeMVar [done1, done2]
     readIntArray mba 0
 
+-- | Test atomicCasWordAddr# by having two threads concurrenctly increment a
+-- counter, checking the sum at the end.
+casTestAddr :: IO ()
+casTestAddr = do
+    tot <- raceAddr 0
+        (\ addr -> work addr (fromIntegral iters) 1)
+        (\ addr -> work addr (fromIntegral iters) 2)
+    assertEq (3 * fromIntegral iters) tot "casTestAddr"
+  where
+    work :: Ptr Word -> Word -> Word -> IO ()
+    work ptr 0 val = return ()
+    work ptr n val = add ptr val >> work ptr (n-1) val
+
+    -- Fetch-and-add implemented using CAS.
+    add :: Ptr Word -> Word -> IO ()
+    add ptr n = peek ptr >>= go
+      where
+        go old = do
+            old' <- atomicCasWordPtr ptr old (old + n)
+            when (old /= old') $ go old'
+
+    -- | Create two threads that mutate the byte array passed to them
+    -- concurrently. The array is one word large.
+    raceAddr :: Word                -- ^ Initial value of array element
+            -> (Ptr Word -> IO ())  -- ^ Thread 1 action
+            -> (Ptr Word -> IO ())  -- ^ Thread 2 action
+            -> IO Word              -- ^ Final value of array element
+    raceAddr n0 thread1 thread2 = do
+        done1 <- newEmptyMVar
+        done2 <- newEmptyMVar
+        ptr <- asWordPtr <$> callocBytes (sizeOf (undefined :: Word))
+        forkIO $ thread1 ptr >> putMVar done1 ()
+        forkIO $ thread2 ptr >> putMVar done2 ()
+        mapM_ takeMVar [done1, done2]
+        peek ptr
+      where
+        asWordPtr :: Ptr a -> Ptr Word
+        asWordPtr = castPtr
+
 ------------------------------------------------------------------------
 -- Test helper
 
@@ -254,3 +302,13 @@ casIntArray :: MByteArray -> Int -> Int -> Int -> IO Int
 casIntArray (MBA mba#) (I# ix#) (I# old#) (I# new#) = IO $ \ s# ->
     case casIntArray# mba# ix# old# new# s# of
         (# s2#, old2# #) -> (# s2#, I# old2# #)
+
+------------------------------------------------------------------------
+-- Wrappers around Addr#
+
+-- Should this be added to Foreign.Storable?  Similar to poke, but does the
+-- update atomically.
+atomicCasWordPtr :: Ptr Word -> Word -> Word -> IO Word
+atomicCasWordPtr (Ptr addr#) (W# old#) (W# new#) = IO $ \ s# ->
+    case atomicCasWordAddr# addr# old# new# s# of
+        (# s2#, old2# #) -> (# s2#, W# old2# #)
diff --git a/testsuite/tests/concurrent/should_run/AtomicPrimops.stdout b/testsuite/tests/concurrent/should_run/AtomicPrimops.stdout
index c37041a040..c9ea7ee500 100644
--- a/testsuite/tests/concurrent/should_run/AtomicPrimops.stdout
+++ b/testsuite/tests/concurrent/should_run/AtomicPrimops.stdout
@@ -4,4 +4,5 @@ fetchNandTest: OK
 fetchOrTest: OK
 fetchXorTest: OK
 casTest: OK
+casTestAddr: OK
 readWriteTest: OK