Commit 17d5c518 authored by vdukhovni's avatar vdukhovni Committed by Marge Bot
Browse files

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#`.
parent 81560981
Pipeline #27175 failed with stages
in 129 minutes and 41 seconds
......@@ -2079,39 +2079,47 @@ primop WriteOffAddrOp_Word64 "writeWord64OffAddr#" GenPrimOp
with has_side_effects = True
can_fail = True
primop InterlockedExchange_Addr "atomicExchangeAddr#" 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 "atomicExchangeInt#" 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 AtomicCompareExchange_Int "atomicCasInt#" GenPrimOp
Addr# -> Int# -> Int# -> State# s -> (# State# s, Int# #)
primop CasAddrOp_Addr "atomicCasAddrAddr#" GenPrimOp
Addr# -> Addr# -> Addr# -> State# s -> (# State# s, Addr# #)
{ Compare and swap on a word-sized memory location.
Use as atomicCasInt# location expected desired
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).
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 AtomicCompareExchange_Addr "atomicCasAddr#" GenPrimOp
Addr# -> Addr# -> Addr# -> State# s -> (# State# s, Addr# #)
{ Compare and swap on a word-sized memory location.
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 atomicCasAddr# location expected desired
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).
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"
......
......@@ -848,11 +848,11 @@ 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]
AtomicCompareExchange_Int -> \[dst, expected, new] -> opIntoRegs $ \[res] ->
CasAddrOp_Addr -> \[dst, expected, new] -> opIntoRegs $ \[res] ->
emitPrimCall [res] (MO_Cmpxchg (wordWidth platform)) [dst, expected, new]
AtomicCompareExchange_Addr -> \[dst, expected, new] -> opIntoRegs $ \[res] ->
CasAddrOp_Word -> \[dst, expected, new] -> opIntoRegs $ \[res] ->
emitPrimCall [res] (MO_Cmpxchg (wordWidth platform)) [dst, expected, new]
-- SIMD primops
......
......@@ -109,5 +109,5 @@ throwErrnoIfMinus1NoRetry loc f = do
exchangePtr :: Ptr (Ptr a) -> Ptr a -> IO (Ptr a)
exchangePtr (Ptr dst) (Ptr val) =
IO $ \s ->
case (atomicExchangeAddr# dst val s) of
case (atomicExchangeAddrAddr# dst val s) of
(# s2, old_val #) -> (# s2, Ptr old_val #)
## 0.7.0 (edit as necessary)
- Shipped with GHC 8.12.1
- Shipped with GHC 9.0.1
- Add known-key `cstringLength#` to `GHC.CString`. This is just the
C function `strlen`, but a built-in rewrite rule allows GHC to
......@@ -21,8 +21,13 @@
- Add primops for atomic exchange:
atomicExchangeAddr# :: Addr# -> Addr# -> State# s -> (# State# s, Addr# #)
atomicExchangeInt# :: 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 `(~~)`:
......
......@@ -4,8 +4,8 @@
module M where
import GHC.Exts (atomicExchangeInt#, Int#, Addr#, State# )
import GHC.Exts (atomicExchangeWordAddr#, Word#, Addr#, State# )
swap :: Addr# -> Int# -> State# s -> (# #)
swap ptr val s = case (atomicExchangeInt# ptr val s) of
swap :: Addr# -> Word# -> State# s -> (# #)
swap ptr val s = case (atomicExchangeWordAddr# ptr val s) of
(# s2, old_val #) -> (# #)
......@@ -26,16 +26,16 @@ 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)
alloca $ \(ptr_p :: Ptr (Ptr Word)) -> do
alloca $ \(ptr_i :: Ptr Word) -> do
alloca $ \(ptr_j :: Ptr Word) -> do
poke ptr_i (1 :: Word)
poke ptr_j (2 :: Word)
--expected to swap
res_i <- cas ptr_i 1 3 :: IO Int
res_i <- cas ptr_i 1 3 :: IO Word
-- expected to fail
res_j <- cas ptr_j 1 4 :: IO Int
res_j <- cas ptr_j 1 4 :: IO Word
putStrLn "Returned results:"
--(1,2)
......@@ -48,7 +48,7 @@ main = do
--(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 #)
cas :: Ptr Word -> Word -> Word -> IO Word
cas (Ptr ptr) (W# expected) (W# desired)= do
IO $ \s -> case (atomicCasWordAddr# ptr expected desired s) of
(# s2, old_val #) -> (# s2, W# old_val #)
......@@ -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 (atomicExchangeInt# 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 #)
......@@ -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# #)
......@@ -4,4 +4,5 @@ fetchNandTest: OK
fetchOrTest: OK
fetchXorTest: OK
casTest: OK
casTestAddr: OK
readWriteTest: OK
Supports Markdown
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment