atomic-primops 0.7 → 0.8.8
raw patch · 15 files changed
Files
- CHANGELOG.md +88/−0
- Data/Atomics.hs +205/−74
- Data/Atomics/Counter.hs +10/−27
- Data/Atomics/Internal.hs +13/−73
- Setup.hs +2/−29
- atomic-primops.cabal +21/−92
- cbits/atomics.cmm +20/−0
- cbits/primops.cmm +0/−128
- testing/CommonTesting.hs +4/−4
- testing/Counter.hs +4/−138
- testing/CounterCommon.hs +152/−0
- testing/Fetch.hs +218/−0
- testing/Issue28.hs +2/−2
- testing/Test.hs +234/−84
- testing/test-atomic-primops.cabal +53/−30
+ CHANGELOG.md view
@@ -0,0 +1,88 @@+## 0.8.8 [2024.06.20]+* Fix infinite loops in the implementations of `storeLoadBarrier`,+ `loadLoadBarrier`, and `writeBarrier` when building with GHC 9.10 or later.++## 0.8.7 [2024.04.20]+* Fix typos in the `foreign import`s introduced in `atomic-primops-0.8.5` and+ `atomic-primops-0.8.6`, which would lead to linker errors when building+ executables with GHC 9.10.++## 0.8.6 [2024.04.16]+* Use `prim`, not `ccall`, for the `foreign import`s used when building the+ library with GHC 9.10 or later. This fixes a GHC 9.10-specific build issue.++## 0.8.5 [2024.02.17]+* Allow building with GHC 9.10.++## 0.8.4 [2020.10.03]+* Allow building with `base-4.15` (GHC 9.0).++## 0.8.3 [2019.05.02]+* Allow the tests to build with `base-4.13` (GHC 8.8).+* Require GHC 7.10 or later.++## 0.8.2 [2018.03.08]+* Allow building with `base-4.11`.++## 0.8.1.1 [2017.12.10]+* Bundle `testing/Fetch.hs` with the package tarball++## 0.8.1+* Simplify `Setup.hs` to support `Cabal-2.0`/GHC 8.2+* Properly link `store_load_barrier` and friends against the GHC RTS on Windows+ when using GHC 8.2 or later++## 0.8.0.4+* Internal changes to support forthcoming GHC 8.0++## 0.8+* Implements additional fetch primops available in GHC 7.10++## 0.7+* This release adds support for GHC 7.10 and its expanded library of (now inline) primops.++## 0.6.1+* This is a good version to use for GHC 7.8.3. It includes portability and bug fixes+ and adds atomicModifyIORefCAS.++## 0.6.0.5+* fix for GHC 7.8++## 0.6.0.1+* minor ghc 7.8 fix++## 0.6+* add atomicModifyIORefCAS, and bump due to prev bugfixes++## 0.5.0.2+* IMPORTANT BUGFIXES - don't use earlier versions. They have been marked deprecated.++## 0.5+* Nix Data.Atomics.Counter.Foreign and the bits-atomic dependency.++## 0.4.1+* Add advance support for GHC 7.8++## 0.4+* Further internal changes, duplicate 'cas' routine well as barriers.+* Add `fetchAddByteArrayInt`+* Add an `Unboxed` counter variant that uses movable "ByteArray"s on the GHC heap.++## 0.3+* Major internal change. Duplicate the barrier code from the GHC RTS and thus+ enable support for executables that are NOT built with '-threaded'.++## 0.2.2.1+* Minor, add warning.++## 0.2.2+* Add more counters++## 0.2+* Critical bugfix and add Counter.++## 0.1.0.2+* disable profiling++## 0.1.0.0+* initial release
Data/Atomics.hs view
@@ -1,5 +1,9 @@-{-# LANGUAGE MagicHash, UnboxedTuples, ScopedTypeVariables, BangPatterns, CPP #-}+{-# LANGUAGE MagicHash, UnboxedTuples, ScopedTypeVariables, BangPatterns, CPP #-} {-# LANGUAGE ForeignFunctionInterface #-}+#if __GLASGOW_HASKELL__ >= 909+{-# LANGUAGE GHCForeignImportPrim #-}+{-# LANGUAGE UnliftedFFITypes #-}+#endif -- | Provides atomic memory operations on IORefs and Mutable Arrays. --@@ -10,58 +14,60 @@ -- (`Tickets`). Currently, the user cannot coin new tickets, rather a `Ticket` -- provides evidence of a past observation, and grants permission to make a future -- change.-module Data.Atomics +module Data.Atomics ( -- * Types for atomic operations Ticket, peekTicket, -- CASResult(..), -- * Atomic operations on IORefs- readForCAS, casIORef, casIORef2, + readForCAS, casIORef, casIORef2, atomicModifyIORefCAS, atomicModifyIORefCAS_,- + -- * Atomic operations on mutable arrays- casArrayElem, casArrayElem2, readArrayElem, + casArrayElem, casArrayElem2, readArrayElem, -- * Atomic operations on byte arrays- casByteArrayInt, fetchAddByteArrayInt,- + casByteArrayInt,+ fetchAddIntArray,+ fetchSubIntArray,+ fetchAndIntArray,+ fetchNandIntArray,+ fetchOrIntArray,+ fetchXorIntArray,+ -- -- ** Reading and writing with barriers+ -- atomicReadIntArray,+ -- atomicWriteIntArray,+ -- * Atomic operations on raw MutVars -- | A lower-level version of the IORef interface. readMutVarForCAS, casMutVar, casMutVar2, -- * Memory barriers- storeLoadBarrier, loadLoadBarrier, writeBarrier+ storeLoadBarrier, loadLoadBarrier, writeBarrier,++ -- * Deprecated Functions+ fetchAddByteArrayInt ) where -import Control.Monad.ST (stToIO) import Control.Exception (evaluate) import Data.Primitive.Array (MutableArray(MutableArray)) import Data.Primitive.ByteArray (MutableByteArray(MutableByteArray)) import Data.Atomics.Internal-import Data.Int -- TEMPORARY-import Debug.Trace -import Data.IORef +import Data.IORef import GHC.IORef hiding (atomicModifyIORef) import GHC.STRef-import GHC.ST-#if MIN_VERSION_base(4,7,0)-import GHC.Prim hiding ((==#))+import GHC.Exts hiding ((==#)) import qualified GHC.PrimopWrappers as GPW-#else-import GHC.Prim-#endif-import GHC.Arr -import GHC.Base (Int(I#)) import GHC.IO (IO(IO))-import GHC.Word (Word(W#))+-- import GHC.Word (Word(W#)) #ifdef DEBUG_ATOMICS #warning "Activating DEBUG_ATOMICS... NOINLINE's and more" {-# NOINLINE seal #-} {-# NOINLINE casIORef #-}-{-# NOINLINE casArrayElem2 #-} +{-# NOINLINE casArrayElem2 #-} {-# NOINLINE readArrayElem #-} {-# NOINLINE readForCAS #-} {-# NOINLINE casArrayElem #-}@@ -69,9 +75,16 @@ {-# NOINLINE readMutVarForCAS #-} {-# NOINLINE casMutVar #-} {-# NOINLINE casMutVar2 #-}+{-# NOINLINE casByteArrayInt #-}+{-# NOINLINE fetchAddIntArray #-}+{-# NOINLINE fetchSubIntArray #-}+{-# NOINLINE fetchAndIntArray #-}+{-# NOINLINE fetchNandIntArray #-}+{-# NOINLINE fetchOrIntArray #-}+{-# NOINLINE fetchXorIntArray #-} #else {-# INLINE casIORef #-}-{-# INLINE casArrayElem2 #-} +{-# INLINE casArrayElem2 #-} {-# INLINE readArrayElem #-} {-# INLINE readForCAS #-} {-# INLINE casArrayElem #-}@@ -79,24 +92,28 @@ {-# INLINE readMutVarForCAS #-} {-# INLINE casMutVar #-} {-# INLINE casMutVar2 #-}+{-# INLINE fetchAddIntArray #-}+{-# INLINE fetchSubIntArray #-}+{-# INLINE fetchAndIntArray #-}+{-# INLINE fetchNandIntArray #-}+{-# INLINE fetchOrIntArray #-}+{-# INLINE fetchXorIntArray #-} #endif -- GHC 7.8 changed some primops-#if MIN_VERSION_base(4,7,0) (==#) :: Int# -> Int# -> Bool (==#) x y = case x GPW.==# y of { 0# -> False; _ -> True }-#endif -------------------------------------------------------------------------------- -- | Compare-and-swap. Follows the same rules as `casIORef`, returning the ticket for -- then next operation.--- +-- -- By convention this is WHNF strict in the "new" value provided. casArrayElem :: MutableArray RealWorld a -> Int -> Ticket a -> a -> IO (Bool, Ticket a) -- casArrayElem (MutableArray arr#) (I# i#) old new = IO$ \s1# ->--- case casArray# arr# i# old new s1# of +-- case casArray# arr# i# old new s1# of -- (# s2#, x#, res #) -> (# s2#, (x# ==# 0#, res) #) casArrayElem arr i old !new = casArrayElem2 arr i old (seal new) @@ -104,7 +121,7 @@ -- arbitrary, lifted, Haskell value. casArrayElem2 :: MutableArray RealWorld a -> Int -> Ticket a -> Ticket a -> IO (Bool, Ticket a) casArrayElem2 (MutableArray arr#) (I# i#) old new = IO$ \s1# ->- case casArrayTicketed# arr# i# old new s1# of + case casArrayTicketed# arr# i# old new s1# of (# s2#, x#, res #) -> (# s2#, (x# ==# 0#, res) #) -- | Ordinary processor load instruction (non-atomic, not implying any memory barriers).@@ -122,6 +139,8 @@ -- Further, this version always returns the /old value/, that was read from the array during -- the CAS operation. That is, it follows the normal protocol for CAS operations -- (and matches the underlying instruction on most architectures).+--+-- Implies a full memory barrier. casByteArrayInt :: MutableByteArray RealWorld -> Int -> Int -> Int -> IO Int casByteArrayInt (MutableByteArray mba#) (I# ix#) (I# old#) (I# new#) = IO$ \s1# ->@@ -136,27 +155,114 @@ (# s2#, (I# res) #) -- I don't know if a let will mak any difference here... hopefully not. ++--------------------------------------------------------------------------------+-- Fetch-and-* family of functions:++-- | Atomically add to a word of memory within a `MutableByteArray`, returning+-- the value *before* the operation. Implies a full memory barrier.+fetchAddIntArray :: MutableByteArray RealWorld+ -> Int -- ^ The offset into the array+ -> Int -- ^ The value to be added+ -> IO Int -- ^ The value *before* the addition+fetchAddIntArray (MutableByteArray mba#) (I# offset#) (I# incr#) = IO $ \ s1# ->+ let (# s2#, res #) = fetchAddIntArray# mba# offset# incr# s1# in+ (# s2#, (I# res) #)+++-- | Atomically subtract to a word of memory within a `MutableByteArray`,+-- returning the value *before* the operation. Implies a full memory barrier.+fetchSubIntArray :: MutableByteArray RealWorld+ -> Int -- ^ The offset into the array+ -> Int -- ^ The value to be subtracted+ -> IO Int -- ^ The value *before* the addition+fetchSubIntArray = doAtomicRMW fetchSubIntArray#++-- | Atomically bitwise AND to a word of memory within a `MutableByteArray`,+-- returning the value *before* the operation. Implies a full memory barrier.+fetchAndIntArray :: MutableByteArray RealWorld+ -> Int -- ^ The offset into the array+ -> Int -- ^ The value to be AND-ed+ -> IO Int -- ^ The value *before* the addition+fetchAndIntArray = doAtomicRMW fetchAndIntArray#++-- | Atomically bitwise NAND to a word of memory within a `MutableByteArray`,+-- returning the value *before* the operation. Implies a full memory barrier.+fetchNandIntArray :: MutableByteArray RealWorld+ -> Int -- ^ The offset into the array+ -> Int -- ^ The value to be NAND-ed+ -> IO Int -- ^ The value *before* the addition+fetchNandIntArray = doAtomicRMW fetchNandIntArray#++-- | Atomically bitwise OR to a word of memory within a `MutableByteArray`,+-- returning the value *before* the operation. Implies a full memory barrier.+fetchOrIntArray :: MutableByteArray RealWorld+ -> Int -- ^ The offset into the array+ -> Int -- ^ The value to be OR-ed+ -> IO Int -- ^ The value *before* the addition+fetchOrIntArray = doAtomicRMW fetchOrIntArray#++-- | Atomically bitwise XOR to a word of memory within a `MutableByteArray`,+-- returning the value *before* the operation. Implies a full memory barrier.+fetchXorIntArray :: MutableByteArray RealWorld+ -> Int -- ^ The offset into the array+ -> Int -- ^ The value to be XOR-ed+ -> IO Int -- ^ The value *before* the addition+fetchXorIntArray = doAtomicRMW fetchXorIntArray#+++-- Internals for our fetch* family of functions, with CAS loop fallbacks for+-- GHC < 7.10:+{-# INLINE doAtomicRMW #-}+doAtomicRMW :: (MutableByteArray# RealWorld -> Int# -> Int# -> State# RealWorld -> (# State# RealWorld, Int# #)) -- primop+ -> MutableByteArray RealWorld -> Int -> Int -> IO Int -- exported function+doAtomicRMW atomicOp# =+ \(MutableByteArray mba#) (I# offset#) (I# val#) ->+ IO $ \ s1# ->+ let (# s2#, res #) = atomicOp# mba# offset# val# s1# in+ (# s2#, (I# res) #)++ {-# DEPRECATED fetchAddByteArrayInt "Replaced by fetchAddIntArray which returns the OLD value" #-} -- | Atomically add to a word of memory within a `MutableByteArray`.--- +-- -- This function returns the NEW value of the location after the increment. -- Thus, it is a bit misnamed, and in other contexts might be called "add-and-fetch", -- such as in GCC's `__sync_add_and_fetch`. fetchAddByteArrayInt :: MutableByteArray RealWorld -> Int -> Int -> IO Int-fetchAddByteArrayInt (MutableByteArray mba#) (I# offset#) (I# incr#) = IO $ \ s1# -> +fetchAddByteArrayInt (MutableByteArray mba#) (I# offset#) (I# incr#) = IO $ \ s1# -> let (# s2#, res #) = fetchAddIntArray# mba# offset# incr# s1# in--- fetchAddIntArray# changed behavior in 7.10 to return the OLD value, so we--- need this to maintain forwards compatibility until removed:-#if MIN_VERSION_base(4,8,0) (# s2#, (I# (res +# incr#)) #)-#else- (# s2#, (I# res) #)-#endif + --------------------------------------------------------------------------------+{- WIP. Having trouble writing good tests for these, and not sure how useful+ - these are. See #43 discussion+ -+ - Also remember to add these to the INLINE / NOINLINE section when exported +++-- | Given an array and an offset in Int units, read an element. The index is+-- assumed to be in bounds. Implies a full memory barrier.+atomicReadIntArray :: MutableByteArray RealWorld -> Int -> IO Int+atomicReadIntArray (MutableByteArray mba#) (I# ix#) = IO $ \ s# ->+ case atomicReadIntArray# mba# ix# s# of+ (# s2#, n# #) -> (# s2#, I# n# #)++-- | Given an array and an offset in Int units, write an element. The index is+-- assumed to be in bounds. Implies a full memory barrier.+atomicWriteIntArray :: MutableByteArray RealWorld -> Int -> Int -> IO ()+atomicWriteIntArray (MutableByteArray mba#) (I# ix#) (I# n#) = IO $ \ s# ->+ case atomicWriteIntArray# mba# ix# n# s# of+ s2# -> (# s2#, () #)++-}++--------------------------------------------------------------------------------+ -- | Ordinary processor load instruction (non-atomic, not implying any memory barriers).--- +-- -- The difference between this function and `readIORef`, is that it returns a /ticket/, -- for use in future compare-and-swap operations. readForCAS :: IORef a -> IO ( Ticket a )@@ -171,8 +277,8 @@ -- The reason for the difference is the ticket API. This function always returns the -- ticket that you should use in your next CAS attempt. In case of success, this ticket -- corresponds to the `new` value which you yourself installed in the `IORef`, whereas--- in the case of failure it represents the preexisting value currently in the IORef. --- +-- in the case of failure it represents the preexisting value currently in the IORef.+-- -- Note \"compare\" here means pointer equality in the sense of -- 'GHC.Prim.reallyUnsafePtrEquality#'. However, the ticket API absolves -- the user of this module from needing to worry about the pointer equality of their@@ -186,15 +292,15 @@ -> Ticket a -- ^ A ticket for the 'old' value -> a -- ^ The 'new' value to replace 'current' if @old == current@ -> IO (Bool, Ticket a) -- ^ Success flag, plus ticket for the NEXT operation.-casIORef (IORef (STRef var)) old !new = casMutVar var old new +casIORef (IORef (STRef var)) old !new = casMutVar var old new -- | This variant takes two tickets, i.e. the 'new' value is a ticket rather than an -- arbitrary, lifted, Haskell value.-casIORef2 :: IORef a +casIORef2 :: IORef a -> Ticket a -- ^ A ticket for the 'old' value -> Ticket a -- ^ A ticket for the 'new' value -> IO (Bool, Ticket a)-casIORef2 (IORef (STRef var)) old new = casMutVar2 var old new +casIORef2 (IORef (STRef var)) old new = casMutVar2 var old new --------------------------------------------------------------------------------@@ -204,12 +310,12 @@ {-# NOINLINE peekTicket #-} -- At least this function MUST remain NOINLINE. Issue5 is an example of a bug that -- ensues otherwise.-peekTicket :: Ticket a -> a +peekTicket :: Ticket a -> a peekTicket = unsafeCoerce# -- Not exposing this for now. Presently the idea is that you must read from the -- mutable data structure itself to get a ticket.-seal :: a -> Ticket a +seal :: a -> Ticket a seal = unsafeCoerce# -- | Like `readForCAS`, but for `MutVar#`.@@ -220,17 +326,17 @@ -- -- By convention this is WHNF strict in the "new" value provided. casMutVar :: MutVar# RealWorld a -> Ticket a -> a -> IO (Bool, Ticket a)-casMutVar mv tick !new = - -- trace ("TEMPDBG: Inside casMutVar.. ") $ +casMutVar mv tick !new =+ -- trace ("TEMPDBG: Inside casMutVar.. ") $ casMutVar2 mv tick (seal new) -- | This variant takes two tickets, i.e. the 'new' value is a ticket rather than an -- arbitrary, lifted, Haskell value. casMutVar2 :: MutVar# RealWorld a -> Ticket a -> Ticket a -> IO (Bool, Ticket a)-casMutVar2 mv tick new = IO$ \st -> - case casMutVarTicketed# mv tick new st of - (# st, flag, tick' #) ->- (# st, (flag ==# 0#, tick') #)+casMutVar2 mv tick new = IO$ \st ->+ case casMutVarTicketed# mv tick new st of+ (# st', flag, tick' #) ->+ (# st', (flag ==# 0#, tick') #) -- (# st, if flag ==# 0# then Succeed tick' else Fail tick' #) -- if flag ==# 0# then else (# st, Fail (W# tick') #) @@ -239,30 +345,58 @@ -------------------------------------------------------------------------------- -- | Memory barrier implemented by the GHC rts (see SMP.h).-storeLoadBarrier :: IO ()+-- storeLoadBarrier :: IO () -- | Memory barrier implemented by the GHC rts (see SMP.h).-loadLoadBarrier :: IO ()+-- loadLoadBarrier :: IO () -- | Memory barrier implemented by the GHC rts (see SMP.h).+-- writeBarrier :: IO ()++#if __GLASGOW_HASKELL__ >= 909++foreign import prim "hs_atomic_primops_store_load_barrier" storeLoadBarrier#+ :: State# RealWorld -> State# RealWorld++-- | A memory barrier that prevents future loads occurring before preceding+-- stores.+storeLoadBarrier :: IO ()+storeLoadBarrier = IO $ \s -> case storeLoadBarrier# s of s' -> (# s', () #)++foreign import prim "hs_atomic_primops_load_load_barrier" loadLoadBarrier#+ :: State# RealWorld -> State# RealWorld++-- | A memory barrier that prevents future loads occurring before earlier loads.+loadLoadBarrier :: IO ()+loadLoadBarrier = IO $ \s -> case loadLoadBarrier# s of s' -> (# s', () #)++foreign import prim "hs_atomic_primops_write_barrier" writeBarrier#+ :: State# RealWorld -> State# RealWorld++-- | A memory barrier that prevents future stores occurring before preceding+-- stores. writeBarrier :: IO ()+writeBarrier = IO $ \s -> case writeBarrier# s of s' -> (# s', () #) --- GHC 7.8 consistently exposes these symbols while linking:-#if MIN_VERSION_base(4,7,0) && !defined(_WIN32) && !defined(_WIN64)+#elif !(defined(mingw32_HOST_OS) && __GLASGOW_HASKELL__ < 802)++-- | Memory barrier implemented by the GHC rts (see SMP.h). foreign import ccall unsafe "store_load_barrier" storeLoadBarrier- :: IO () + :: IO () +-- | Memory barrier implemented by the GHC rts (see SMP.h). foreign import ccall unsafe "load_load_barrier" loadLoadBarrier :: IO () +-- | Memory barrier implemented by the GHC rts (see SMP.h). foreign import ccall unsafe "write_barrier" writeBarrier :: IO ()- #else--- GHC 7.6 did not consistently expose them (e.g. in the non-threaded RTS),--- so rather we grab this functionality from RtsDup.c:+#warning "importing store_load_barrier and friends from the package's C code."++-- Workaround for Trac #12846, which affects old GHCs on Windows foreign import ccall unsafe "DUP_store_load_barrier" storeLoadBarrier- :: IO () + :: IO () foreign import ccall unsafe "DUP_load_load_barrier" loadLoadBarrier :: IO ()@@ -271,18 +405,17 @@ :: IO () #endif - -------------------------------------------------------------------------------- --- | A drop-in replacement for `atomicModifyIORefCAS` that+-- | A drop-in replacement for `atomicModifyIORef` that -- optimistically attempts to compute the new value and CAS it into -- place without introducing new thunks or locking anything. Note -- that this is more STRICT than its standard counterpart and will only -- place evaluated (WHNF) values in the IORef.--- --- The upside is that sometimes we see a performance benefit. --- The downside is that this version is speculative -- when it +--+-- The upside is that sometimes we see a performance benefit.+-- The downside is that this version is speculative -- when it -- retries, it must reexecute the compution. atomicModifyIORefCAS :: IORef a -- ^ Mutable location to modify -> (a -> (a,b)) -- ^ Computation runs one or more times (speculation)@@ -291,13 +424,13 @@ -- TODO: Should handle contention in a better way... tick <- readForCAS ref loop tick effort- where + where effort = 30 :: Int -- TODO: Tune this.- loop old 0 = atomicModifyIORef ref fn -- Fall back to the regular version.- loop old tries = do + loop _ 0 = atomicModifyIORef ref fn -- Fall back to the regular version.+ loop old tries = do (new,result) <- evaluate $ fn $ peekTicket old (b,tick) <- casIORef ref old new- if b + if b then return result else loop tick (tries-1) @@ -310,15 +443,13 @@ atomicModifyIORefCAS_ ref fn = do tick <- readForCAS ref loop tick effort- where + where effort = 30 :: Int -- TODO: Tune this.- loop old 0 = atomicModifyIORef_ ref fn- loop old tries = do + loop _ 0 = atomicModifyIORef ref (\ x -> (fn x, ()))+ loop old tries = do new <- evaluate $ fn $ peekTicket old (b,val) <- casIORef ref old new- if b + if b then return () else loop val (tries-1)- atomicModifyIORef_ ref fn = atomicModifyIORef ref (\ x -> (fn x, ())) -- </duplicated code>-
Data/Atomics/Counter.hs view
@@ -32,25 +32,14 @@ where -import GHC.Ptr-import Data.Atomics (casByteArrayInt)--- import Data.Atomics.Internal (casIntArray#, fetchAddIntArray#) import Data.Atomics.Internal-#if MIN_VERSION_base(4,7,0) import GHC.Base hiding ((==#))-import GHC.Prim hiding ((==#)) import qualified GHC.PrimopWrappers as GPW-#else-import GHC.Base-import GHC.Prim-#endif -- GHC 7.8 changed some primops-#if MIN_VERSION_base(4,7,0) (==#) :: Int# -> Int# -> Bool (==#) x y = case x GPW.==# y of { 0# -> False; _ -> True }-#endif @@ -83,23 +72,23 @@ {-# INLINE newRawCounter #-} newRawCounter :: IO AtomicCounter newRawCounter = IO $ \s ->- case newByteArray# size s of { (# s, arr #) ->- (# s, AtomicCounter arr #) }+ case newByteArray# size s of { (# s', arr #) ->+ (# s', AtomicCounter arr #) } where !(I# size) = SIZEOF_HSINT {-# INLINE readCounter #-} -- | Equivalent to `readCounterForCAS` followed by `peekCTicket`. readCounter :: AtomicCounter -> IO Int readCounter (AtomicCounter arr) = IO $ \s ->- case readIntArray# arr 0# s of { (# s, i #) ->- (# s, I# i #) }+ case readIntArray# arr 0# s of { (# s', i #) ->+ (# s', I# i #) } {-# INLINE writeCounter #-} -- | Make a non-atomic write to the counter. No memory-barrier. writeCounter :: AtomicCounter -> Int -> IO () writeCounter (AtomicCounter arr) (I# i) = IO $ \s ->- case writeIntArray# arr 0# i s of { s ->- (# s, () #) }+ case writeIntArray# arr 0# i s of { s' ->+ (# s', () #) } {-# INLINE readCounterForCAS #-} -- | Just like the "Data.Atomics" CAS interface, this routine returns an opaque@@ -127,9 +116,9 @@ False -> (# s2#, (False, I# res# ) #) -- Failure True -> (# s2#, (True , newBox ) #) -- Success -{-# INLINE sameCTicket #-}-sameCTicket :: CTicket -> CTicket -> Bool-sameCTicket = (==)+-- {-# INLINE sameCTicket #-}+-- sameCTicket :: CTicket -> CTicket -> Bool+-- sameCTicket = (==) {-# INLINE incrCounter #-} -- | Increment the counter by a given amount. Returns the value AFTER the increment@@ -142,17 +131,11 @@ incrCounter :: Int -> AtomicCounter -> IO Int incrCounter (I# incr#) (AtomicCounter mba#) = IO $ \ s1# -> let (# s2#, res #) = fetchAddIntArray# mba# 0# incr# s1# in--- fetchAddIntArray# changed behavior in 7.10 to return the OLD value, so we--- need this to maintain forwards compatibility:-#if MIN_VERSION_base(4,8,0) (# s2#, (I# (res +# incr#)) #)-#else- (# s2#, (I# res) #)-#endif {-# INLINE incrCounter_ #-} -- | An alternate version for when you don't care about the old value. incrCounter_ :: Int -> AtomicCounter -> IO () incrCounter_ (I# incr#) (AtomicCounter mba#) = IO $ \ s1# -> - let (# s2#, res #) = fetchAddIntArray# mba# 0# incr# s1# in+ let (# s2#, _ #) = fetchAddIntArray# mba# 0# incr# s1# in (# s2#, () #)
Data/Atomics/Internal.hs view
@@ -4,32 +4,20 @@ #define CASTFUN -- | This module provides only the raw primops (and necessary types) for atomic--- operations. -module Data.Atomics.Internal +-- operations.+module Data.Atomics.Internal (- casIntArray#, fetchAddIntArray#, - readForCAS#, casMutVarTicketed#, casArrayTicketed#, + casIntArray#, fetchAddIntArray#,+ readForCAS#, casMutVarTicketed#, casArrayTicketed#, Ticket, -- * Very unsafe, not to be used ptrEq )- where --import GHC.Base (Int(I#))-import GHC.Word (Word(W#))-import GHC.Prim (RealWorld, Int#, Word#, State#, MutableArray#, MutVar#,- MutableByteArray#, - unsafeCoerce#, reallyUnsafePtrEquality#) + where -#if MIN_VERSION_base(4,7,0)-import GHC.Prim (casArray#, casIntArray#, fetchAddIntArray#, Any, readMutVar#, casMutVar#)-#elif MIN_VERSION_base(4,6,0)--- Any is only supported in the FFI in the way we need in GHC 7.6+-import GHC.Prim (readMutVar#, casMutVar#, Any)-#else-#error "Need to figure out how to emulate Any () in GHC <= 7.4 !"--- type Any a = Word#-#endif +import GHC.Exts (Int(I#), Any, RealWorld, Int#, State#, MutableArray#, MutVar#,+ unsafeCoerce#, reallyUnsafePtrEquality#,+ casArray#, casIntArray#, fetchAddIntArray#, readMutVar#, casMutVar#) #ifdef DEBUG_ATOMICS {-# NOINLINE readForCAS# #-}@@ -45,18 +33,12 @@ -- CAS and friends -------------------------------------------------------------------------------- --- | Unsafe, machine-level atomic compare and swap on an element within an Array. -casArrayTicketed# :: MutableArray# RealWorld a -> Int# -> Ticket a -> Ticket a +-- | Unsafe, machine-level atomic compare and swap on an element within an Array.+casArrayTicketed# :: MutableArray# RealWorld a -> Int# -> Ticket a -> Ticket a -> State# RealWorld -> (# State# RealWorld, Int#, Ticket a #) -- WARNING: cast of a function -- need to verify these are safe or eta expand.-casArrayTicketed# = unsafeCoerce#-#if MIN_VERSION_base(4,7,0)- -- In GHC 7.8 onward we just want to expose the existing primop with a different type:- casArray#-#else- casArrayTypeErased#-#endif- +casArrayTicketed# = unsafeCoerce# casArray#+ -- | When performing compare-and-swaps, the /ticket/ encapsulates proof -- that a thread observed a specific previous value of a mutable -- variable. It is provided in lieu of the "old" value to@@ -98,46 +80,4 @@ casMutVarTicketed# :: MutVar# RealWorld a -> Ticket a -> Ticket a -> State# RealWorld -> (# State# RealWorld, Int#, Ticket a #) -- WARNING: cast of a function -- need to verify these are safe or eta expand:-casMutVarTicketed# =-#if MIN_VERSION_base(4,7,0) - unsafeCoerce# casMutVar#-#else- unsafeCoerce# casMutVar_TypeErased#-#endif------------------------------------------------------------------------------------- Type-erased versions that call the raw foreign primops:------------------------------------------------------------------------------------ Due to limitations of the "foreign import prim" mechanism, we can't use the--- polymorphic signature for the below functions. So we lie to the type system--- instead.--#if MIN_VERSION_base(4,7,0) -#else--foreign import prim "stg_casArrayzh" casArrayTypeErased#- :: MutableArray# RealWorld () -> Int# -> Any () -> Any () -> - State# RealWorld -> (# State# RealWorld, Int#, Any () #) --- out_of_line = True--- has_side_effects = True---- | This alternate version of casMutVar returns an opaque "ticket" for--- future CAS operations.-foreign import prim "stg_casMutVar2zh" casMutVar_TypeErased#- :: MutVar# RealWorld () -> Any () -> Any () ->- State# RealWorld -> (# State# RealWorld, Int#, Any () #)---- foreign import prim "stg_readMutVar2zh" readMutVar_TypeErased#--- :: MutVar# RealWorld () -> --- State# RealWorld -> (# State# RealWorld, Any () #)- -- with has_side_effects = True- -- commutable = False--foreign import prim "stg_casByteArrayIntzh" casIntArray#- :: MutableByteArray# s -> Int# -> Int# -> Int# ->- State# s -> (# State# s, Int# #) --foreign import prim "stg_fetchAddByteArrayIntzh" fetchAddIntArray#- :: MutableByteArray# s -> Int# -> Int# -> State# s -> (# State# s, Int# #) --#endif+casMutVarTicketed# = unsafeCoerce# casMutVar#
Setup.hs view
@@ -1,29 +1,2 @@--import Control.Monad (when)-import Language.Haskell.TH-import Distribution.Simple (defaultMainWithHooks, simpleUserHooks, UserHooks(postConf), Args)-import Distribution.Simple.Utils (cabalVersion)-import Distribution.Simple.LocalBuildInfo-import Distribution.Simple.Setup (ConfigFlags)-import Distribution.Version (Version(..))-import Distribution.PackageDescription (PackageDescription)-import Debug.Trace---- I couldn't figure out a way to do this check from the cabal file, so we drop down--- here to do it instead:-checkGoodVersion :: IO ()-checkGoodVersion =- if cabalVersion >= Version [1,17,0] []- then putStrLn (" [Setup.hs] This version of Cabal is ok for profiling: "++show cabalVersion)- else error (" [Setup.hs] This package should not be used in profiling mode with cabal version "++- show (versionBranch cabalVersion)++" < 1.17.0\n"++- " It will break, see cabal issue #1284")--main :: IO ()-main = do- let myPostConf :: Args -> ConfigFlags -> PackageDescription -> LocalBuildInfo -> IO ()- myPostConf _args confFlags _descr lbi =- when (withProfLib lbi)- checkGoodVersion- hooks = simpleUserHooks { postConf = myPostConf }- defaultMainWithHooks hooks+import Distribution.Simple+main = defaultMain
atomic-primops.cabal view
@@ -1,45 +1,20 @@+Cabal-version: 3.0 Name: atomic-primops-Version: 0.7-License: BSD3+Version: 0.8.8+License: BSD-3-Clause License-file: LICENSE Author: Ryan Newton Maintainer: rrnewton@gmail.com Category: Data -- Portability: non-portabile (x86_64)-Build-type: Custom--- TODO: This requirement needs to be bumped to 1.17 when the latest cabal is--- released. This package triggers issue #1284:--- Cabal-version: >=1.18-Cabal-version: >=1.10--- Egad! Requiring cabal version 1.18 triggers a seemingly spurious failure on Mac OS:--- http://tester-lin.soic.indiana.edu:8080/job/Haskell-LockFree_master/JENKINS_GHC=7.6.3,label=macos/346/console--- So for now I'm backing off about the cabal requirement. Setup.hs will catch it later IF an early version--- of cabal is used WITH profiling mode.-+Build-type: Simple+tested-with: GHC == 8.4.3, GHC == 8.2.2, GHC == 8.0.2, GHC == 7.10.3 HomePage: https://github.com/rrnewton/haskell-lockfree/wiki Bug-Reports: https://github.com/rrnewton/haskell-lockfree/issues --- Version History:--- 0.1.0.0 -- initial release--- 0.1.0.2 -- disable profiling--- 0.2 -- Critical bugfix and add Counter.--- 0.2.2 -- Add more counters--- 0.2.2.1 -- Minor, add warning.--- 0.3 -- Major internal change. Duplicate GHC RTS barriers and support non -threaded.--- 0.4 -- Duplicate 'cas' as well as barriers. Add fetchAdd on ByteArray, Counter.Unboxed.--- 0.4.1 -- Add advance support for GHC 7.8--- 0.5 -- Nix Data.Atomics.Counter.Foreign and the bits-atomic dependency.--- 0.5.0.2 -- IMPORTANT Bugfix release.--- 0.6 -- add atomicModifyIORefCAS, and bump due to prev bugfixes--- 0.6.0.1 -- minor ghc 7.8 fix--- 0.6.0.5 -- fix for GHC 7.8--- 0.6.1 -- several bug fixes, mainly re: platform portability--- 0.7 -- support for GHC 7.10 and several new primops- Synopsis: A safe approach to CAS and other atomic ops in Haskell. Description:- After GHC 7.4 a new `casMutVar#` primop became available, but it's difficult to use safely, because pointer equality is a highly unstable property in Haskell. This library provides a safer method@@ -50,46 +25,16 @@ interest, specifically, compare and swap inside an array. . Note that as of GHC 7.8, the relevant primops have been included in GHC itself.- This library is engineered to work pre- and post-GHC-7.8, while exposing the + This library is engineered to work pre- and post-GHC-7.8, while exposing the same interface.- .- Changes in 0.3:- .- * Major internal change. Duplicate the barrier code from the GHC RTS and thus - enable support for executables that are NOT built with '-threaded'.- .- Changes in 0.4:- . - * Further internal changes, duplicate 'cas' routine well as barriers. - .- * Add `fetchAddByteArrayInt`- .- * Add an `Unboxed` counter variant that uses movable "ByteArray"s on the GHC heap.- .- Changes in 0.5:- . - * Remove dependency on bits-atomic unless a flag is turned on.- . - Changes in 0.5.0.2:- .- * IMPORTANT BUGFIXES - don't use earlier versions. They have been marked deprecated.- .- Changes in 0.6.1- .- * This is a good version to use for GHC 7.8.3. It includes portability and bug fixes - and adds atomicModifyIORefCAS.- .- Changes in 0.7: - .- * This release adds support for GHC 7.10 and its expanded library of (now inline) primops. --Extra-Source-Files: DEVLOG.md,- testing/Test.hs, testing/test-atomic-primops.cabal, testing/ghci-test.hs- testing/Makefile, testing/CommonTesting.hs, testing/Counter.hs, testing/hello.hs+Extra-Source-Files: DEVLOG.md+ testing/Test.hs testing/test-atomic-primops.cabal testing/ghci-test.hs+ testing/Makefile testing/CommonTesting.hs testing/Counter.hs testing/CounterCommon.hs testing/hello.hs testing/Fetch.hs testing/Issue28.hs testing/TemplateHaskellSplices.hs testing/Raw781_test.hs+extra-doc-files: CHANGELOG.md Flag debug Description: Enable extra internal checks.@@ -101,39 +46,23 @@ Data.Atomics.Internal Data.Atomics.Counter ghc-options: -O2 -funbox-strict-fields-- -- casMutVar# had a bug in GHC 7.2, thus we require GHC 7.4 or greater- -- (base 4.5 or greater). We also need the "Any" kind.- build-depends: base >= 4.6.0.0 && < 4.9, ghc-prim, primitive+ ghc-options: -Wall - -- TODO: Try to push support back to 7.0, but make it default to an implementation- -- other than Unboxed.+ build-depends: base >= 4.8 && < 5+ , ghc-prim+ , primitive - -- Ah, but if we don't USE casMutVar# in this package we are ok:- -- build-depends: base >= 4.3, ghc-prim, primitive+ if impl(ghc >= 9.9)+ cmm-sources: cbits/atomics.cmm - if impl(ghc < 7.7) {- Include-Dirs: cbits- C-Sources: cbits/primops.cmm- -- Duplicate RTS functionality for GHC 7.6:- C-Sources: cbits/RtsDup.c+ if os(windows) {+ Include-Dirs: cbits+ C-Sources: cbits/RtsDup.c }- CC-Options: -Wall -- -- if( cabal-version < 1.17 ) {- -- ghc-prof-options: ERROR_DO_NOT_BUILD_THIS_WITH_PROFILING_YET__SEE_CABAL_ISSUE_1284- -- }+ CC-Options: -Wall if flag(debug)- cpp-options: -DDEBUG_ATOMICS ----- -- [2013.04.08] This isn't working presently:--- -- I'm having problems with building it along with the library; see DEVLOG.--- -- Switching to a separate package in ./testing/ --- Test-Suite test-atomic-primops--- type: exitcode-stdio-1.0--- ...+ cpp-options: -DDEBUG_ATOMICS Source-Repository head Type: git
+ cbits/atomics.cmm view
@@ -0,0 +1,20 @@+#include "Cmm.h"++// These approximate GHC's old barrier operations in terms of the new C11-style+// ordered atomic fences.++hs_atomic_primops_store_load_barrier() {+ prim %fence_seq_cst();+ return ();+}++hs_atomic_primops_load_load_barrier() {+ prim %fence_acquire();+ return ();+}++hs_atomic_primops_write_barrier() {+ prim %fence_release();+ return ();+}+
− cbits/primops.cmm
@@ -1,128 +0,0 @@--// ============================================================-// NOTE: We only use this file for GHC < 7.8.-// ============================================================--#include "Cmm.h"--#warning "Duplicating functionality from the GHC RTS..."-#define WHICH_CAS DUP_cas-#define WHICH_SLBARRIER DUP_store_load_barrier-#define WHICH_LLBARRIER DUP_load_load_barrier-#define WHICH_WBARRIER DUP_write_barrier--// These versions are linked directly from the RTS:-/* #define WHICH_CAS cas */-/* #define WHICH_SLBARRIER store_load_barrier */-/* #define WHICH_LLBARRIER load_load_barrier */-/* #define WHICH_WBARRIER write_barrier */--// ================================================================================--add1Op-/* Int# -> Int# */-{- W_ num;- num = R1 + 1;- RET_P(num);-}---stg_casArrayzh-/* MutableArray# s a -> Int# -> a -> a -> State# s -> (# State# s, Int#, a #) */-{- W_ arr, p, ind, old, new, h, len;- arr = R1; // anything else?- ind = R2;- old = R3;- new = R4;-- p = arr + SIZEOF_StgMutArrPtrs + WDS(ind);- (h) = foreign "C" WHICH_CAS(p, old, new) [];- if (h != old) {- // Failure, return what was there instead of 'old':- RET_NP(1,h);- } else {- // Compare and Swap Succeeded:- SET_HDR(arr, stg_MUT_ARR_PTRS_DIRTY_info, CCCS);- len = StgMutArrPtrs_ptrs(arr);- // The write barrier. We must write a byte into the mark table:- I8[arr + SIZEOF_StgMutArrPtrs + WDS(len) + (ind >> MUT_ARR_PTRS_CARD_BITS )] = 1;- RET_NP(0,new);- }-}---stg_casByteArrayIntzh-/* MutableByteArray# s -> Int# -> Int# -> Int# -> State# s -> (# State# s, Int# #) */-{- W_ arr, p, ind, old, new, h, len;- arr = R1; - ind = R2;- old = R3;- new = R4;-- p = arr + SIZEOF_StgArrWords + WDS(ind);- (h) = foreign "C" WHICH_CAS(p, old, new) [];-- RET_N(h);-}--stg_fetchAddByteArrayIntzh-/* MutableByteArray# s -> Int# -> Int# -> State# s -> (# State# s, Int# #) */-{- W_ arr, p, ind, incr, h, len;- arr = R1; - ind = R2;- incr = R3;-- p = arr + SIZEOF_StgArrWords + WDS(ind);- (h) = foreign "C" atomic_inc_with(incr, p) [];-- RET_N(h);-}--// One difference from casMutVar# is that this version returns the NEW-// pointer in the case of success, NOT the old one.-stg_casMutVar2zh- /* MutVar# s a -> Word# -> a -> State# s -> (# State#, Int#, a #) */-{- W_ mv, old, new, h, addr;- // Calling convention: Up to 8 registers contain arguments.- mv = R1;- old = R2;- new = R3;- addr = mv + SIZEOF_StgHeader + OFFSET_StgMutVar_var;-- // The "cas" function from the C runtime abstracts over- // platform/architecture differences. It returns the old value.- (h) = foreign "C" WHICH_CAS(addr, old, new) [];- if (h != old) {- // Failure:- RET_NP(1, h);- }- else - {- // Success means a mutation and thus GC write barrier:- if (GET_INFO(mv) == stg_MUT_VAR_CLEAN_info) {- foreign "C" dirty_MUT_VAR(BaseReg "ptr", mv "ptr") [];- }- // Return the NEW value as the ticket for next time.- RET_NP(0,new);- }-}---// Takes a single input argument in R1:-stg_readMutVar2zh-/* MutVar# RealWorld a -> State# RealWorld -> (# State# RealWorld, Word#, a #) */-{- W_ mv, res;- mv = R1;- // Do the actual read:- res = W_[mv + SIZEOF_StgHeader + OFFSET_StgMutVar_var];- RET_NP(res, res);-}-/* emitPrimOp [res] ReadMutVarOp [mutv] _ */-/* = stmtC (CmmAssign (CmmLocal res) (cmmLoadIndexW mutv fixedHdrSize gcWord)) */-
testing/CommonTesting.hs view
@@ -13,7 +13,7 @@ import System.CPUTime import System.Mem.StableName (makeStableName, hashStableName) import System.Environment (getEnvironment)-import System.IO (stdout, stderr, hPutStrLn, hFlush)+import System.IO (stderr, hPutStrLn, hFlush) import Debug.Trace (trace) -- import Test.Framework.TH (defaultMainGenerator)@@ -84,8 +84,8 @@ start <- getCPUTime v <- a end <- getCPUTime- let diff = (fromIntegral (end - start)) / (10^12)- printf "SELFTIMED: %0.3f sec\n" (diff :: Double)+ let diff = (fromIntegral (end - start)) / (10^(12::Int))+ _ <- printf "SELFTIMED: %0.3f sec\n" (diff :: Double) return v @@ -106,7 +106,7 @@ -- -- INLINE should not affect recursive functions. But here it seems to have a -- deleterious effect!-nTimes 0 !c = return ()+nTimes 0 _ = return () nTimes !n !c = c >> nTimes (n-1) c
testing/Counter.hs view
@@ -1,148 +1,14 @@+{-# LANGUAGE CPP #-} module Counter (tests) where---- This was formerly CounterCommon and #include-ed to test the different--- counter implementations which have been removed. --- TODO clean up remnants of that approach. import qualified Data.Atomics.Counter as C -import Control.Monad-import GHC.Conc-import System.CPUTime-import Test.Framework.Providers.HUnit (testCase)-import Test.HUnit (Assertion, assertEqual, assertBool)-import Text.Printf-import Data.IORef --import CommonTesting (numElems, forkJoin, timeit, nTimes)+#include "CounterCommon.hs" +name :: String name = "Unboxed" +default_seq_tries, default_conc_tries :: Int default_seq_tries = 10 * numElems -- Things are MUCH slower with contention: default_conc_tries = numElems ------------------------------------------------------------------------------------ Test the basics--case_basic1 = do - r <- C.newCounter 0- ret <- C.incrCounter 10 r- assertEqual "incrCounter returns the NEW value" 10 ret--case_basic2 = do - r <- C.newCounter 0- t <- C.readCounterForCAS r- (True,newt) <- C.casCounter r t 10- assertEqual "casCounter returns new val/ticket on success" 10 (C.peekCTicket newt)--case_basic3 = do - r <- C.newCounter 0- t <- C.readCounterForCAS r- _ <- C.incrCounter 1 r- (False,oldt) <- C.casCounter r t 10- assertEqual "casCounter returns read val on failure" 1 (C.peekCTicket oldt)--case_basic4 = do - let tries = numElems `quot` 100- r <- C.newCounter 0- nTimes tries $ do- t <- C.readCounterForCAS r- (True,_) <- C.casCounter r t (C.peekCTicket t + 1)- return ()- cnt <- C.readCounter r- assertEqual "Every CAS should succeed on one thread" tries cnt ------------------------------------------------------------------------------------- Repeated increments--incrloop tries = do r <- C.newCounter 0; nTimes tries $ void$ C.incrCounter 1 r- C.readCounter r-case_incrloop = do - cnt <- incrloop default_seq_tries- assertEqual "incrloop sum" default_seq_tries cnt---- | Here we do a loop to test the unboxing of results from incrCounter:--- As of now [2013.07.19], it is successfully unboxing the results --- for Data.Atomics.Counter.Unboxed.-incrloop4B tries = do- putStrLn " [incrloop4B] A test where we use the result of each incr."- r <- C.newCounter 1- loop r tries 1- where- loop :: C.AtomicCounter -> Int -> Int -> IO ()- loop r 0 _ = do v <- C.readCounter r- putStrLn$"Final value: "++show v- return ()- loop r tries last = do- n <- C.incrCounter last r- if n == 2- then loop r (tries-1) 2- else loop r (tries-1) 1---- | Here we let the counter overflow, which seems to be causing problems.-overflowTest tries = do- putStrLn " [incrloop4B] A test where we use the result of each incr."- r <- C.newCounter 1- loop r tries 1- where- loop :: C.AtomicCounter -> Int -> Int -> IO ()- loop r 0 _ = do v <- C.readCounter r- putStrLn$"Final value: "++show v- return ()- loop r tries last = do- putStrLn$ " [incrloop4B] Looping with tries left "++show tries - n <- C.incrCounter last r- -- This is HANGING afer passing 2,147,483,648. (using Unboxed)- -- Is there some defect wrt overflow?- putStrLn$ " [incrloop4B] Done incr, received "++show n- loop r (tries-1) n------------------------------------------------------------------------------------- Parallel repeated increments---{-# INLINE parIncrloop #-} -parIncrloop new incr iters = do- numcap <- getNumCapabilities- let (each,left) = iters `quotRem` numcap- putStrLn$ "Concurrently incrementing counter from all "++show numcap++" threads, incrs per thread: "++show each- r <- new 0- forkJoin numcap $ \ ix -> do- let mine = if ix==0 then each+left else each- nTimes mine $ void $ incr 1 r- C.readCounter r--case_parincrloop = do - cnt <- parIncrloop C.newCounter C.incrCounter default_conc_tries- assertEqual "incrloop sum" default_conc_tries cnt---- | Use CAS instead of the real incr so we can compare the overhead.-case_parincrloop_wCAS = do - cnt <- parIncrloop C.newCounter fakeIncr default_conc_tries- assertEqual "incrloop sum" default_conc_tries cnt- where- fakeIncr delt r = do tick <- C.readCounterForCAS r- loop r delt tick- loop r delt tick = do x <- C.casCounter r tick (C.peekCTicket tick + delt)- case x of - (True, newtick) -> return (C.peekCTicket newtick)- (False,newtick) -> loop r delt newtick- ------------------------------------------------------------------------------------tests = - [- testCase (name++"basic1_incrCounter") $ case_basic1- , testCase (name++"basic2_casCounter") $ case_basic2- , testCase (name++"basic3_casCounter") $ case_basic3- , testCase (name++"basic4_casCounter") $ case_basic4- ----------------------------------------- , testCase (name++"_single_thread_repeat_incr") $ timeit case_incrloop- , testCase (name++"_incr_with_result_feedback") $ timeit (incrloop4B default_seq_tries)- ------------------------------------------ -- Parallel versions:- , testCase (name++"_concurrent_repeat_incr") $ void$ timeit case_parincrloop- , testCase (name++"_concurrent_repeat_incrCAS") $ void$ timeit case_parincrloop_wCAS- ]
+ testing/CounterCommon.hs view
@@ -0,0 +1,152 @@+-- Common tests to the different counter implementations. N.B. #included from+-- other projects via soft links!++import Control.Monad+import GHC.Conc+import Test.Framework.Providers.HUnit (testCase)+import Test.Framework(Test)+import Test.HUnit (assertEqual)++import CommonTesting (numElems, forkJoin, timeit, nTimes)++--------------------------------------------------------------------------------+-- Test the basics++case_basic1 :: IO ()+case_basic1 = do + r <- C.newCounter 0+ ret <- C.incrCounter 10 r+ assertEqual "incrCounter returns the NEW value" 10 ret++case_basic2 :: IO ()+case_basic2 = do + r <- C.newCounter 0+ t <- C.readCounterForCAS r+ (True,newt) <- C.casCounter r t 10+ assertEqual "casCounter returns new val/ticket on success" 10 (C.peekCTicket newt)++case_basic3 :: IO ()+case_basic3 = do + r <- C.newCounter 0+ t <- C.readCounterForCAS r+ _ <- C.incrCounter 1 r+ (False,oldt) <- C.casCounter r t 10+ assertEqual "casCounter returns read val on failure" 1 (C.peekCTicket oldt)++case_basic4 :: IO ()+case_basic4 = do + let tries = numElems `quot` 100+ r <- C.newCounter 0+ nTimes tries $ do+ t <- C.readCounterForCAS r+ (True,_) <- C.casCounter r t (C.peekCTicket t + 1)+ return ()+ cnt <- C.readCounter r+ assertEqual "Every CAS should succeed on one thread" tries cnt ++--------------------------------------------------------------------------------+-- Repeated increments++incrloop :: Int -> IO Int+incrloop tries = do r <- C.newCounter 0; nTimes tries $ void$ C.incrCounter 1 r+ C.readCounter r++case_incrloop :: IO ()+case_incrloop = do + cnt <- incrloop default_seq_tries+ assertEqual "incrloop sum" default_seq_tries cnt++-- | Here we do a loop to test the unboxing of results from incrCounter:+-- As of now [2013.07.19], it is successfully unboxing the results +-- for Data.Atomics.Counter.Unboxed.+incrloop4B :: Int -> IO ()+incrloop4B tries = do+ putStrLn " [incrloop4B] A test where we use the result of each incr."+ r <- C.newCounter 1+ loop r tries 1+ where+ loop :: C.AtomicCounter -> Int -> Int -> IO ()+ loop r 0 _ = do v <- C.readCounter r+ putStrLn$"Final value: "++show v+ return ()+ loop r i l = do+ n <- C.incrCounter l r+ if n == 2+ then loop r (i-1) 2+ else loop r (i-1) 1++-- | Here we let the counter overflow, which seems to be causing problems.+-- NOTE 2/3/2015: THIS APPEARS TO BE WORKING NOW -Brandon +overflowTest :: Int -> IO ()+overflowTest tries = do+ putStrLn " [incrloop4B] A test where we use the result of each incr."+ r <- C.newCounter 1+ loop r tries 1+ where+ loop :: C.AtomicCounter -> Int -> Int -> IO ()+ loop r 0 _ = do v <- C.readCounter r+ putStrLn$"Final value: "++show v+ return ()+ loop r i l = do+ --putStrLn$ " [incrloop4B] Looping with tries left "++show i + n <- C.incrCounter l r+ -- This is HANGING afer passing 2,147,483,648. (using Unboxed)+ -- Is there some defect wrt overflow?+ --putStrLn$ " [incrloop4B] Done incr, received "++show n+ loop r (i-1) n++--------------------------------------------------------------------------------+-- Parallel repeated increments+++{-# INLINE parIncrloop #-} +parIncrloop :: (Int -> IO C.AtomicCounter)+ -> (Int -> C.AtomicCounter -> IO Int) -> Int -> IO Int+parIncrloop new incr iters = do+ numcap <- getNumCapabilities+ let (each,left) = iters `quotRem` numcap+ putStrLn$ "Concurrently incrementing counter from all "++show numcap++" threads, incrs per thread: "++show each+ r <- new 0+ void $ forkJoin numcap $ \ ix -> do+ let mine = if ix==0 then each+left else each+ nTimes mine $ void $ incr 1 r+ C.readCounter r++case_parincrloop :: IO ()+case_parincrloop = do + cnt <- parIncrloop C.newCounter C.incrCounter default_conc_tries+ assertEqual "incrloop sum" default_conc_tries cnt++-- | Use CAS instead of the real incr so we can compare the overhead.+case_parincrloop_wCAS :: IO ()+case_parincrloop_wCAS = do + cnt <- parIncrloop C.newCounter fakeIncr default_conc_tries+ assertEqual "incrloop sum" default_conc_tries cnt+ where+ fakeIncr delt r = do tick <- C.readCounterForCAS r+ loop r delt tick+ loop r delt tick = do x <- C.casCounter r tick (C.peekCTicket tick + delt)+ case x of + (True, newtick) -> return (C.peekCTicket newtick)+ (False,newtick) -> loop r delt newtick+ ++--------------------------------------------------------------------------------++tests :: [Test]+tests = + [+ testCase (name++"_basic1_incrCounter") $ case_basic1+ , testCase (name++"_basic2_casCounter") $ case_basic2+ , testCase (name++"_basic3_casCounter") $ case_basic3+ , testCase (name++"_basic4_casCounter") $ case_basic4+ ----------------------------------------+ , testCase (name++"_single_thread_repeat_incr") $ timeit case_incrloop+ , testCase (name++"_incr_with_result_feedback") $ timeit (incrloop4B default_seq_tries)+ , testCase (name++"_overflow_test") $ timeit (overflowTest 100000)+ ----------------------------------------++ -- Parallel versions:+ , testCase (name++"_concurrent_repeat_incr") $ void$ timeit case_parincrloop+ , testCase (name++"_concurrent_repeat_incrCAS") $ void$ timeit case_parincrloop_wCAS+ ]
+ testing/Fetch.hs view
@@ -0,0 +1,218 @@+module Fetch (tests) where++-- tests for our fetch-and-* family of functions.+import Control.Monad+import System.Random+import Test.Framework.Providers.HUnit (testCase)+import Test.Framework (Test)+import Test.HUnit (assertEqual,assertBool)+import Data.Primitive+import Data.List+import Data.Bits+import Data.Atomics+import Control.Monad.Primitive+import Control.Concurrent++tests :: [Test]+tests = [+ testCase "Fetch-and-* operations return previous value" case_return_previous+ , testCase "Fetch-and-* operations behave like their corresponding bitwise operators" case_like_bitwise+ , testCase "fetchAndIntArray and fetchOrIntArray are atomic" $ fetchAndOrTest 10000000+ , testCase "fetchNandIntArray atomic" $ fetchNandTest 1000000+ , testCase "fetchAddIntArray and fetchSubIntArray are atomic" $ fetchAddSubTest 10000000+ , testCase "fetchXorIntArray is atomic" $ fetchXorTest 10000000+ ] ++nand :: Bits a => a -> a -> a+nand x y = complement (x .&. y)++fetchOps :: [( String+ , MutableByteArray RealWorld -> Int -> Int -> IO Int+ , Int -> Int -> Int )]+fetchOps = [+ ("Add", fetchAddIntArray, (+)),+ ("Sub", fetchSubIntArray, (-)),+ ("And", fetchAndIntArray, (.&.)),+ ("Nand", fetchNandIntArray, nand),+ ("Or", fetchOrIntArray, (.|.)),+ ("Xor", fetchXorIntArray, xor)+ ]+++-- Test all operations at once, somewhat randomly, ensuring they behave like+-- their corresponding bitwise operator; we compose a few operations before+-- inspecting the intermediate result, and spread them randomly around a small+-- array.+-- TODO use quickcheck if we want+case_like_bitwise :: IO ()+case_like_bitwise = do+ let opGroupSize = 5+ let grp n = go n []+ where go _ stck [] = [stck]+ go 0 stck xs = stck : go n [] xs+ go i stck (x:xs) = go (i-1) (x:stck) xs+ -- Inf list of different short sequences of bitwise operations:+ let opGroups = grp opGroupSize $ cycle $ concat $ permutations fetchOps+ + let size = 4+ randIxs <- randomRs (0, size-1) <$> newStdGen + randArgs <- grp opGroupSize . randoms <$> newStdGen+ + a <- newByteArray (sizeOf (undefined::Int) * size)+ forM_ [0.. size-1] $ \ix-> writeByteArray a ix (0::Int)++ forM_ (take 1000000 $ zip randIxs $ zipWith zip opGroups randArgs) $+ \ (ix, opsArgs)-> do+ assertEqual "test not b0rken" (length opsArgs) opGroupSize+ + let doOpGroups pureLHS [] = return pureLHS+ doOpGroups pureLHS (((_,atomicOp,op), v) : rest) = do+ atomicOp a ix v >> doOpGroups (pureLHS `op` v) rest+ + vInitial <- readByteArray a ix+ vFinalPure <- doOpGroups vInitial opsArgs+ vFinal <- readByteArray a ix++ let nmsArgs = map (\ ((nm,_,_),v) -> (nm,v)) opsArgs+ assertEqual ("sequence on initial value "++(show vInitial)+ ++" of ops with RHS args: "++(show nmsArgs)+ ++" gives same result in both pure and atomic op"+ ) vFinal vFinalPure++ + +-- check all operations return the value before the operation was applied;+-- basic smoke test, with each op tested individually.+case_return_previous :: IO ()+case_return_previous = do+ let l = length fetchOps+ a <- newByteArray (sizeOf (undefined::Int) * l)+ let randomInts = take l . randoms <$> newStdGen :: IO [Int]+ initial <- randomInts+ forM_ (zip [0..] initial) $ \(ix, v)-> writeByteArray a ix v++ args <- randomInts+ forM_ (zip4 [0..] initial args fetchOps) $ \(ix, pre, v, (nm,atomicOp,op))-> do+ pre' <- atomicOp a ix v+ assertEqual (fetchStr nm "returned previous value") pre pre'+ let post = pre `op` v+ post' <- readByteArray a ix+ assertEqual (fetchStrArgVal nm v pre "operation was seen correctly on read") post post'++fetchStr :: String -> String -> String+fetchStr nm = (("fetch"++nm++"IntArray: ")++)+fetchStrArgVal :: (Show a, Show a1) => String -> a -> a1 -> String -> String+fetchStrArgVal nm v initial = (("fetch"++nm++"IntArray, with arg "++(show v)++" on value "++(show initial)++": ")++)++-- ----------------------------------------------------------------------------+-- Tests of atomicity:+++-- Concurrently run a sequence of AND and OR simultaneously on separate parts+-- of the bit range of an Int.+fetchAndOrTest :: Int -> IO ()+fetchAndOrTest iters = do+ out0 <- newEmptyMVar+ out1 <- newEmptyMVar+ mba <- newByteArray (sizeOf (undefined :: Int))+ let andLowersBit , orRaisesBit :: Int -> Int+ andLowersBit = clearBit (complement 0)+ orRaisesBit = setBit 0+ writeByteArray mba 0 (0 :: Int)+ -- thread 1 toggles bit 0, thread 2 toggles bit 1; then we verify results+ -- in the main thread.+ let go v b = do+ -- Avoid stack overflow on GHC 7.6:+ let replicateMrev l 0 = putMVar v l+ replicateMrev l iter = do+ low <- fetchOrIntArray mba 0 (orRaisesBit b)+ high <- fetchAndIntArray mba 0 (andLowersBit b)+ replicateMrev ((low,high):l) (iter-1)+ in replicateMrev [] iters+ void $ forkIO $ go out0 0+ void $ forkIO $ go out1 1+ res0 <- takeMVar out0+ res1 <- takeMVar out1+ let check b = all ( \(low,high)-> (not $ testBit low b) && testBit high b)++ assertBool "fetchAndOrTest not broken" $ length (res0++res1) == iters*2+ assertBool "fetchAndOrTest thread1" $ check 0 res0+ assertBool "fetchAndOrTest thread2" $ check 1 res1++-- Nand of 1 is a bit complement. Concurrently run two threads running an even+-- number of complements in this way and verify the final value is unchanged.+-- TODO think of a more clever test+fetchNandTest :: Int -> IO ()+fetchNandTest iters = do+ let nandComplements = complement 0+ dblComplement mba = replicateM_ (2 * iters) $+ fetchNandIntArray mba 0 nandComplements+ randomInts <- take 10 . randoms <$> newStdGen :: IO [Int]+ forM_ randomInts $ \ initial -> do+ final <- race initial dblComplement dblComplement + assertEqual "fetchNandTest" initial final+++-- ----------------------------------------------------------------------------+-- Code below copied with minor modifications from GHC+-- testsuite/tests/concurrent/should_run/AtomicPrimops.hs @ f293931+-- ----------------------------------------------------------------------------+++-- | Test fetchAddIntArray# by having two threads concurrenctly+-- increment a counter and then checking the sum at the end.+fetchAddSubTest :: Int -> IO ()+fetchAddSubTest iters = do+ tot <- race 0+ (\ mba -> work fetchAddIntArray mba iters 2)+ (\ mba -> work fetchSubIntArray mba iters 1)+ assertEqual "fetchAddSubTest" iters tot+ where+ work :: (MutableByteArray RealWorld -> Int -> Int -> IO Int) -> MutableByteArray RealWorld -> Int -> Int+ -> IO ()+ work _ _ 0 _ = return ()+ work op mba n val = op mba 0 val >> work op mba (n-1) val++-- | Test fetchXorIntArray# by having two threads concurrenctly XORing+-- and then checking the result at the end. Works since XOR is+-- commutative.+--+-- Covers the code paths for AND, NAND, and OR as well.+fetchXorTest :: Int -> IO ()+fetchXorTest iters = do+ res <- race n0+ (\ mba -> work mba iters t1pat)+ (\ mba -> work mba iters t2pat)+ assertEqual "fetchXorTest" expected res+ where+ work :: MutableByteArray RealWorld -> Int -> Int -> IO ()+ work _ 0 _ = 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...+ (n0, t1pat, t2pat)+ -- TODO: If we want to silence warnings from here, use CPP conditional+ -- on arch x86_64+ | sizeOf (undefined :: Int) == 8 =+ (0x00000000ffffffff, 0x5555555555555555, 0x9999999999999999)+ | otherwise = (0x0000ffff, 0x55555555, 0x99999999)+ expected+ | sizeOf (undefined :: Int) == 8 = 4294967295+ | otherwise = 65535++-- | Create two threads that mutate the byte array passed to them+-- concurrently. The array is one word large.+race :: Int -- ^ Initial value of array element+ -> (MutableByteArray RealWorld -> IO ()) -- ^ Thread 1 action+ -> (MutableByteArray RealWorld -> IO ()) -- ^ Thread 2 action+ -> IO Int -- ^ Final value of array element+race n0 thread1 thread2 = do+ done1 <- newEmptyMVar+ done2 <- newEmptyMVar+ mba <- newByteArray (sizeOf (undefined :: Int))+ writeByteArray mba 0 n0+ void $ forkIO $ thread1 mba >> putMVar done1 ()+ void $ forkIO $ thread2 mba >> putMVar done2 ()+ mapM_ takeMVar [done1, done2]+ readByteArray mba 0
testing/Issue28.hs view
@@ -1,11 +1,12 @@ module Issue28 (main) where -import Control.Monad+-- import Control.Monad import Data.IORef import Data.Atomics -- import Data.Atomics.Internal (ptrEq) +main :: IO () main = do putStrLn "Issue28: Conducting the simplest possible read-then-CAS test." r <- newIORef "hi"@@ -18,4 +19,3 @@ -- unless (b1 == True) $ error "Test failed" putStrLn$ "Issue28: test passed "++show t1- return ()
testing/Test.hs view
@@ -9,7 +9,7 @@ import Control.Monad -- import Control.Monad.ST (stToIO) import Control.Exception (evaluate)-import Data.IORef (modifyIORef')+import Data.IORef import Data.Int import Data.Primitive.Array import Data.Word@@ -18,32 +18,41 @@ import Text.Printf import GHC.Conc import GHC.STRef-import GHC.IORef+import GHC.IORef (IORef(..))+#if MIN_VERSION_base(4,10,0)+import GHC.Stats (getRTSStats, RTSStats(..))+#else import GHC.Stats (getGCStats, GCStats(..))+#endif import System.Random (randomIO, randomRIO) import Test.HUnit (Assertion, assertEqual, assertBool)-import Test.Framework (defaultMain)+import Test.Framework (defaultMain,testGroup,mutuallyExclusive) import Test.Framework.Providers.HUnit (testCase) import System.Mem (performGC) ---------------------------------------- import Data.Atomics as A-import Data.Atomics (casArrayElem, readArrayElem) import qualified Issue28 -import CommonTesting +import CommonTesting import qualified Counter+import qualified Fetch ------------------------------------------------------------------------ expect_false_positive_on_GC :: Bool expect_false_positive_on_GC = False -getGCCount :: IO Int64 -getGCCount | expect_false_positive_on_GC = +getGCCount :: IO Int64+getGCCount | expect_false_positive_on_GC =+#if MIN_VERSION_base(4,10,0)+ do RTSStats{gcs} <- getRTSStats+ return (fromIntegral gcs)+#else do GCStats{numGcs} <- getGCStats return numGcs+#endif | otherwise = return 0 main :: IO ()@@ -53,8 +62,12 @@ -- numcap <- getNumProcessors let numcap = 4 when (numCapabilities /= numcap) $ setNumCapabilities numcap- - defaultMain $ ++ defaultMain $+ -- Make these run sequentially (hopefully), so we don't interfere with+ -- concurrent tests. TODO I guess: figure out how to run tests that+ -- don't fork in parallel, but forking tests sequentially+ return $ mutuallyExclusive $ testGroup "All tests" $ [ testCase "casTicket1" case_casTicket1 , testCase "issue28_standalone" case_issue28_standalone , testCase "issue28_copied " case_issue28_copied@@ -89,6 +102,7 @@ , iters <- [10000]] ++ Counter.tests+ ++ Fetch.tests setify :: [Int] -> [Int] setify = S.toList . S.fromList@@ -98,7 +112,7 @@ mynum :: Int mynum = 33 --- Expected output: +-- Expected output: {--------------------------------------- Perform a CAS within a MutableArray# 1st try should succeed: (True,33)@@ -108,24 +122,24 @@ Done. -} case_casmutarray1 :: IO ()-case_casmutarray1 = do +case_casmutarray1 = do putStrLn "Perform a CAS within a MutableArray#" arr <- newArray 5 mynum writeArray arr 4 33 putStrLn "Wrote array elements..."- - tick <- readArrayElem arr 4++ tick <- A.readArrayElem arr 4 putStrLn$ "(Peeking at array gave: "++show (peekTicket tick)++")" - (res1,tick2) <- casArrayElem arr 4 tick 44- (res2,_) <- casArrayElem arr 4 tick 44+ (res1,_tick2) <- A.casArrayElem arr 4 tick 44+ (res2,_) <- A.casArrayElem arr 4 tick 44 -- res <- stToIO$ casArrayST arr 4 mynum 44--- res2 <- stToIO$ casArrayST arr 4 mynum 44 +-- res2 <- stToIO$ casArrayST arr 4 mynum 44 putStrLn "Printing array:" forM_ [0..4] $ \ i -> do- x <- readArray arr i + x <- readArray arr i putStr (" "++show x) assertBool "1st try should succeed: " res1@@ -133,82 +147,75 @@ -- case_casbytearray1 :: IO ()--- case_casbytearray1 = do +-- case_casbytearray1 = do -- putStrLn "Perform a CAS within a MutableByteArray#" -- | This test uses a number of producer and consumer threads which push and pop -- elements from random positions in an array. test_random_array_comm :: Int -> Int -> Int -> IO ()-test_random_array_comm threads size iters = do +test_random_array_comm threads size iters = do arr <- newArray size Nothing- tick0 <- readArrayElem arr 0+ tick0 <- A.readArrayElem arr 0 for_ 1 size $ \ i -> do- t2 <- readArrayElem arr i+ t2 <- A.readArrayElem arr i assertEqual "All initial Nothings in the array should be ticket-equal:" tick0 t2 - ls <- forkJoin threads $ \tid -> do + ls <- forkJoin threads $ \_tid -> do localAcc <- newIORef 0 for_ 0 iters $ \iter -> do -- Randomly pick a position: ix <- randomRIO (0,size-1) :: IO Int -- Randomly either produce or consume: b <- randomIO :: IO Bool- if b then do - (b,newtick) <- casArrayElem arr ix tick0 (Just iter)- return ()+ if b then do+ void $ A.casArrayElem arr ix tick0 (Just iter) else do -- Consume:- tick <- readArrayElem arr ix+ tick <- A.readArrayElem arr ix case peekTicket tick of- Just _ -> do (b,x) <- casArrayElem arr ix tick (peekTicket tick0) -- Set back to Nothing.- when b $ modifyIORef' localAcc (+1)+ Just _ -> do (success,_) <- A.casArrayElem arr ix tick (peekTicket tick0) -- Set back to Nothing.+ when success $ modifyIORef' localAcc (+1) -- print (peekTicket x) Nothing -> return () return () readIORef localAcc- + let successes = sum ls -- Pidgeonhole principle. -- min_success =- printf "Communication through random array positions (threads/size/iters %s).\n" (show (threads,size,iters))- printf "Successes: %d (expected 1/4 of total iterations on all threads)\n" successes- printf "Per-thread successes: %s\n" (show ls)+ _ <- printf "Communication through random array positions (threads/size/iters %s).\n" (show (threads,size,iters))+ _ <- printf "Successes: %d (expected 1/4 of total iterations on all threads)\n" successes+ _ <- printf "Per-thread successes: %s\n" (show ls) assertBool "Number of successes: " (successes <= (threads * iters) `quot` 2 && successes >= 0) for_ 0 size $ \ i -> do- x <- readArray arr i--- putStr (show x ++ " ")+ _x <- readArray arr i+-- putStr (show _x ++ " ") return () putStrLn "" return ()- - ++ ---------------------------------------------------------------------------------------------------- -- Simple, non-parameterized tests ---------------------------------------------------------------------------------------------------- -{-# NOINLINE zer #-}-zer :: Int-zer = 0-default_iters :: Int-default_iters = 100000- case_casTicket1 :: IO () case_casTicket1 = do dbgPrint 1 "\nUsing new 'ticket' based compare and swap:" - IORef (STRef mutvar) <- newIORef (3::Int) + IORef (STRef mutvar) <- newIORef (3::Int) tick <- A.readMutVarForCAS mutvar dbgPrint 1$"YAY, read the IORef, ticket "++show tick dbgPrint 1$" and the value was: "++show (peekTicket tick) - (True,tick2) <- A.casMutVar mutvar tick 99 + (True,tick2) <- A.casMutVar mutvar tick 99 dbgPrint 1$"Hoorah! Attempted compare and swap..." -- dbgPrint 1$" Result was: "++show (True,tick2) dbgPrint 1$"Ok, next take a look at a SECOND CAS attempt, to see if the ticket from the first works..." res2 <- A.casMutVar mutvar tick2 12345678 dbgPrint 1$"Result was: "++show res2- --- res <- A.casMutVar mutvar tick 99 ++-- res <- A.casMutVar mutvar tick 99 res3 <- A.readMutVarForCAS mutvar dbgPrint 1$"To check contents, did a SECOND read: "++show res3 @@ -218,10 +225,10 @@ case_issue28_standalone = Issue28.main case_issue28_copied :: Assertion-case_issue28_copied = do +case_issue28_copied = do r <- newIORef "hi" t0 <- readForCAS r- (True,t1) <- casIORef r t0 "bye"+ (True,_t1) <- casIORef r t0 "bye" return () ---- toddaaro's tests -----@@ -249,9 +256,9 @@ dbgPrint 1$ " Creating a single 'ticket' based variable to mutate twice." x <- newIORef (0::Int) tick1 <- A.readForCAS(x)- res1 <- A.casIORef x tick1 5+ void $ A.casIORef x tick1 5 tick2 <- A.readForCAS(x)- res2 <- A.casIORef x tick2 120+ void $ A.casIORef x tick2 120 valf <- readIORef x assertBool "Does the value after the first mutate equal 5?" (peekTicket tick2 == 5) assertBool "Does the value after the second mutate equal 120?" (valf == 120)@@ -264,23 +271,23 @@ dbgPrint 1$ " Creating 120 threads and having each increment a counter value." counter <- newIORef (0::Int) -- let work :: Int -> IORef Int -> IO (Int,StableName Int,Int,StableName Int,Int)- let work :: Int -> IORef Int -> IO (Int,Int,Int,Int,Int)- work ix counter = do+ let work :: Int -> IO (Int,Int,Int,Int,Int)+ work ix = do tick <- A.readForCAS(counter) let nxt = peekTicket tick + 1 (b,was) <- A.casIORef counter tick nxt- if b then do + if b then do putStr $ show (peekTicket was) ++ "_" assertEqual "Check that the value written was the one we put in." nxt (peekTicket was) return (ix, unsafeName tick, unsafeName was, peekTicket tick, nxt)- else do - when (peekTicket was == peekTicket tick) $ + else do+ when (peekTicket was == peekTicket tick) $ putStrLn ("(Spoofed by boxing, old val was indeed "++show was++")") putStr "!" -- putStrLn $ "("++ show ix ++ ": Fail when putting "++show nxt -- ++", was already "++show (peekTicket was) ++")"- work ix counter- arr <- forkJoin 120 (\i -> work i counter) + work ix+ arr <- forkJoin 120 work ans <- readIORef counter let dups = [ n | (_,_,_,_,n) <- arr] \\ [1..120]@@ -301,18 +308,18 @@ ---------------------------------------------------------------------------------------------------- ------------------------------------------------------------------------------------------------------- Adapted Old tests from original CAS library: +-- Adapted Old tests from original CAS library: -- | First test: Run a simple CAS a small number of times. test_succeed_once :: (Show a, Num a, Eq a) => a -> Assertion-test_succeed_once n = +test_succeed_once initialVal = do performGC -- We *ASSUME* GC does not happen below. performGC -- We *ASSUME* GC does not happen below. checkGCStats- gc1 <- getGCCount - r <- newIORef n+ gc1 <- getGCCount+ r <- newIORef initialVal bitls <- newIORef [] tick1 <- A.readForCAS r let loop 0 = return ()@@ -321,24 +328,24 @@ atomicModifyIORef bitls (\x -> (res:x, ())) -- putStrLn$ " CAS result: " ++ show res loop (n-1)- loop 10+ loop (10::Int) x <- readIORef r assertEqual "Finished with loop, read cell: " 100 x- - writeIORef r 111 ++ writeIORef r 111 y <- readIORef r assertEqual "Wrote and read again read: " 111 y ls <- readIORef bitls let rev = (reverse ls)- tickets = map snd rev+ -- tickets = map snd rev (hd:tl) = map fst rev gc2 <- getGCCount if gc1 /= gc2 then putStrLn " [skipped] test couldn't be assessed properly due to GC."- else do + else do -- print scrubbed assertBool "Only first succeeds" (all (/= hd) tl) assertBool "All but first fail" (all (== head tl) (tail tl))@@ -355,18 +362,18 @@ -- time. Adding a second thread can only foil the K attempts of the first thread by -- itself succeeding (leaving the total at or above K). Likewise for the third -- thread and so on.--- +-- -- Conversely, for N threads each aiming to complete K operations, -- there should be at most N*N*K total operations required. test_all_hammer_one :: (Show a, Num a, Eq a) => Int -> Int -> a -> Assertion test_all_hammer_one threads iters seed = do ref <- newIORef seed- logs::[[Bool]] <- forkJoin threads $ \_ -> + logs::[[Bool]] <- forkJoin threads $ \_ -> do checkGCStats let loop 0 _ _ !acc = return (reverse acc) loop n !ticket !expected !acc = do -- This line will result in boxing/unboxing and using extra memory locations:--- let bumped = expected + 1 +-- let bumped = expected + 1 bumped <- evaluate$ expected + 1 (res,tick) <- casIORef ref ticket bumped case res of@@ -377,10 +384,10 @@ False -> do let v = peekTicket tick when (iters < 30) $- dbgPrint 1 $ + dbgPrint 1 $ " Fizzled CAS with ticket: "++show ticket ++" containing "++show v++ ", expected: "++ show expected ++- " (#"++show (unsafeName expected)++"): " + " (#"++show (unsafeName expected)++"): " ++ " found " ++ show v ++ " (#"++show (unsafeName v)++", ticket "++show tick++")" loop (n-1) tick v (False:acc) @@ -402,6 +409,149 @@ (total_success >= expected_success) ++------------------------------------------------------------------------+-- Reads and Writes with full barriers:+{-+ - WIP++import Data.Atomics (atomicReadIntArray, atomicWriteIntArray)+import Data.Primitive+import Control.Concurrent+import Data.List(sort)++-- TODO DEBUGGING: for required NoBuffering+import System.IO+++test_atomic_read_write_sanity :: IO ()+test_atomic_read_write_sanity = do+ mba <- newByteArray (sizeOf (undefined :: Int))+ atomicWriteIntArray mba 0 0+ x <- atomicReadIntArray mba 0+ atomicWriteIntArray mba 0 1+ y <- atomicReadIntArray mba 0+ assertEqual "test_atomic_read_write_sanity x" x 0+ assertEqual "test_atomic_read_write_sanity y" y 1++-- These don't really adequately test that we have a *full* barrier, but only+-- store/store and load/load I think. TODO something better+test_atomic_read_write_barriers1, test_atomic_read_write_barriers2 :: Int -> IO ()++-- NOTE: We don't observe failure here on x86 with non-atomic reads/writes, but+-- maybe it will for other architectures. Otherwise this can be removed.+test_atomic_read_write_barriers1 iters = do+ let theWrite mba = atomicWriteIntArray mba 0+ theRead mba = atomicReadIntArray mba 0+ {- NOTE: We would like this to fail (but it seems to work on x86)+ let theWrite mba = writeByteArray mba 0+ theRead mba = readByteArray mba 0+ -}+ -- For kicks, a bunch of padding to ensure these are on different cache-lines:+ mba0 <- newByteArray (sizeOf (undefined :: Int) * 32)+ mba1 <- newByteArray (sizeOf (undefined :: Int) * 32)+ writeByteArray mba0 0 (0 :: Int)+ writeByteArray mba1 0 (1 :: Int)+ -- One thread increments mba0, then mba1 and repeats. The other repeatedly+ -- loops reading mba0 and mba1, checking that the value from the first is+ -- always <= the second:+ readerWait <- newEmptyMVar+ void $ forkIO $+ let go :: Int -> IO ()+ go n = unless (n > iters) $ do+ theWrite mba0 n+ theWrite mba1 (n+1)+ go (n+1)+ in go 1+ void $ forkIO $+ let go = do x <- theRead mba0+ y <- theRead mba1+ assertBool "test_atomic_read_write_barriers" $+ (x <= y)+ when (x < iters) go+ in go+-- Peterson's lock: http://en.wikipedia.org/wiki/Peterson%27s_algorithm+--+-- TODO DEBUGGING see https://github.com/rrnewton/haskell-lockfree/issues/43#issuecomment-71294801+-- for a discussion of issues to be resolved here.+test_atomic_read_write_barriers2 iters = do++ hSetBuffering stdout NoBuffering -- TODO DEBUGGING (THIS APPEARS NECESSARY FOR PUTSTR TRICK BELOW TO WORK, TOO)++ let theWrite mba = atomicWriteIntArray mba 0+ theRead mba = atomicReadIntArray mba 0+ {- NOTE: WE WANT TO MAKE SURE THESE FAIL, BUT THEY DON'T !!+ let theWrite mba (v::Int) = writeByteArray mba 0 v+ theRead mba = readByteArray mba 0 :: IO Int+ -}+ let true = 1 :: Int+ false = 0 :: Int+ -- For kicks, a bunch of padding to ensure these are on different cache-lines:+ flag0 <- newByteArray (sizeOf (undefined :: Int) * 32)+ flag1 <- newByteArray (sizeOf (undefined :: Int) * 32)+ turn <- newByteArray (sizeOf (undefined :: Int) * 32)+ writeByteArray flag0 0 false+ writeByteArray flag1 0 false++ -- We use our lock to get an atomic counter:+ counter <- newByteArray (sizeOf (undefined :: Int) * 32)+ writeByteArray counter 0 (0::Int)++ let petersonIncr flagA flagB turnVal = do+ theWrite flagA true+ theWrite turn turnVal+ let busyWait = do+ flagBVal <- theRead flagB+ turnVal' <- theRead turn+ if turnVal == 1 then putStr "x" else putStr "+" -- TODO DEBUGGING (THIS APPEARS NECESSARY, AND MUST HAPPEN HERE)+ -- putStrLn "" -- TODO DEBUGGING this works too (BUT NOT FOR 1MIL?)+ -- void $ newEmptyMVar -- TODO DEBUGGING does some heap alloc help? NOPE+ -- yield -- TODO DEBUGGING neither this nor -fno-omit-yields seem to help+ when (flagBVal == true && turnVal' == 1) busyWait+ busyWait+ -- start critical section --+ old <- theRead counter+ theWrite counter (old+1)+ -- exit critical section --+ theWrite flagA false+ return old++ out1 <- newEmptyMVar+ out2 <- newEmptyMVar+ void $ forkIO $+ (replicateM iters $ petersonIncr flag0 flag1 1)+ >>= putMVar out1+ void $ forkIO $+ (replicateM iters $ petersonIncr flag1 flag0 0)+ >>= putMVar out2++ -- make sure we got some interleaving, and that output was correct:+ res1 <- takeMVar out1+ res2 <- takeMVar out2++ let numGaps gaps _ [] = gaps+ numGaps gaps prev (x:xs)+ | prev+1 == x = numGaps gaps x xs+ | otherwise = numGaps (gaps+1) x xs+ -- TODO DEBUGGING FYI:+ print $ numGaps (0::Int) (-1::Int) res1+ print $ numGaps (0::Int) (-1::Int) res2+ -- ------------------++ -- if this fails, fix the test or call with more iters+ assertBool "test_atomic_read_write_barriers2 had enough interleaving to be legit" $+ numGaps (0::Int) (-1::Int) res1 > 10000+ && numGaps (0::Int) (-1::Int) res2 > 10000++ -- braindead merge check:+ let ok = sort res1 == res1+ && sort res2 == res2+ && sort (res1++res2) == [0..iters*2-1]++ assertBool "test_atomic_read_write_barriers2" ok++ -}+ ---------------------------------------------------------------------------------------------------- {- @@ -409,9 +559,9 @@ -- This tests repeated atomicModifyIORefCAS operations. testCAS3 :: Int -> IORef ElemTy -> IO [()]-testCAS3 iters ref = +testCAS3 iters ref = forkJoin numCapabilities (loop iters)- where + where loop 0 = return () loop n = do -- let bumped = expected+1 -- Must do this only once, should be NOINLINE@@ -427,7 +577,7 @@ #endif loop (n-1) ----------------------------------------------------------------------------------------------------- +---------------------------------------------------------------------------------------------------- -- This version uses a non-scalar type for CAS. It instead -- manipulates the tail pointers of a simple linked-list. @@ -440,7 +590,7 @@ -- testCAS4 :: CASable ref Int => List ref -> IO [Bool] testCAS4 :: CASable ref Int => Int -> ref (List ref) -> IO ()-testCAS4 iters ref = do +testCAS4 iters ref = do forkJoin numCapabilities $ do -- From each thread, attempt to extend the list 'iters' times: ref' <- readCASable ref@@ -449,11 +599,11 @@ return () return ()- where + where loop 0 _ _ = return () loop n new (Cons _ tl) = do tl' <- readCASable tl- case tl' of + case tl' of Null -> do (b,v) <- cas tl tl' new if b then loop (n-1) v else loop v@@ -471,14 +621,14 @@ else error$ "Test "++ msg ++ " failed to have the right CAS success pattern: " ++ show ls checkOutput2 :: String -> Int -> [[Bool]] -> ElemTy -> IO ()-checkOutput2 msg iters ls fin = do +checkOutput2 msg iters ls fin = do let totalAttempts = sum $ map length ls putStrLn$ "Final value "++show fin++", Total successes "++ show (length $ filter id $ concat ls) when (fin < fromIntegral iters) $- error$ "ERROR in "++ show msg ++ " expected at least "++show iters++" successful CAS's.." + error$ "ERROR in "++ show msg ++ " expected at least "++show iters++" successful CAS's.." checkOutput3 :: String -> Int -> [[Bool]] -> ElemTy -> IO ()-checkOutput3 msg iters ls fin = do +checkOutput3 msg iters ls fin = do return () @@ -489,12 +639,12 @@ -- test x = do--- a <- newStablePtr x --- b <- newStablePtr x --- printf "First call, word %d IntPtr %d\n" +-- a <- newStablePtr x+-- b <- newStablePtr x+-- printf "First call, word %d IntPtr %d\n" -- (unsafeCoerce a :: Word) -- ((fromIntegral$ ptrToIntPtr $ castStablePtrToPtr a) :: Int)--- printf "Second call, word %d IntPtr %d\n" +-- printf "Second call, word %d IntPtr %d\n" -- (unsafeCoerce b :: Word) -- ((fromIntegral$ ptrToIntPtr $ castStablePtrToPtr b) :: Int)
testing/test-atomic-primops.cabal view
@@ -4,9 +4,10 @@ Name: test-atomic-primops Version: 0.6.0.5 Build-type: Simple-Cabal-version: >=1.8-+Cabal-version: >=1.18 -- This is generally controled by the continuous integration script at a more granular level:+tested-with: GHC == 8.4.3, GHC == 8.2.2, GHC == 8.0.2, GHC == 7.10.3+ Flag opt Description: Enable GHC optimization. Default: False@@ -19,66 +20,88 @@ Test-Suite test-atomic-primops type: exitcode-stdio-1.0 main-is: Test.hs- ghc-options: -rtsopts -main-is Test.main+ other-modules:+ CommonTesting+ Counter+ Fetch+ Issue28+ ghc-options: -rtsopts -main-is Test.main -Wall if flag(opt) ghc-options: -O2 -funbox-strict-fields if flag(threaded)- ghc-options: -threaded + ghc-options: -threaded ghc-options: -rtsopts -with-rtsopts=-N4 -- Set it to always run with some parallelism.- build-depends: base, ghc-prim, primitive, containers, random, atomic-primops >= 0.6.0.5,+ build-depends: base >= 4.8 && < 5+ , ghc-prim+ , primitive+ , containers+ , random+ , atomic-primops >= 0.6.0.5 -- For Testing:- time, HUnit, test-framework, test-framework-hunit+ , time+ , HUnit+ , test-framework+ , test-framework-hunit -- Optional: Debugging generated code: -- ghc-options: -keep-tmp-files -dsuppress-module-prefixes -ddump-to-file -ddump-core-stats -ddump-simpl-stats -dcore-lint -dcmm-lint -- ghc-options: -ddump-ds -ddump-simpl -ddump-stg -ddump-asm -ddump-bcos -ddump-cmm -ddump-opt-cmm -ddump-inlinings+ default-language: Haskell2010 -- Cabal can get confused if there is no executable or library... so here's a dummy executable. -- Also it provides a good test of compile/link issues, apart from everything else. Executable hello-world-atomic-primops main-is: hello.hs- build-depends: base >= 4.5, atomic-primops+ build-depends: base >= 4.8 && < 5+ , atomic-primops+ default-language: Haskell2010 -- This is separated out, because a bug in GHC 7.6 make this fail on Linux. Test-suite template-haskell-atomic-primops type: exitcode-stdio-1.0 main-is: ghci-test.hs- if impl(ghc >= 7.8) {- Buildable: True- build-depends: base >= 4.5, atomic-primops >= 0.6.0.5, template-haskell,- -- For Testing:- test-framework, test-framework-hunit- } else {- Buildable: False- }-+ other-modules: TemplateHaskellSplices+ Buildable: True+ build-depends: base >= 4.8 && < 5+ , atomic-primops >= 0.6.0.5+ , template-haskell+ , test-framework+ , test-framework-hunit+ default-language: Haskell2010 -- A very simple test of one primop included in GHC 7.8: Test-suite raw_CAS type: exitcode-stdio-1.0- build-depends: base, ghc-prim, atomic-primops >= 0.6.0.5+ build-depends: base >= 4.8 && < 5+ , ghc-prim+ , atomic-primops >= 0.6.0.5 -- ghc-prim, primitive, containers, random, atomic-primops >= 0.5.0.2, main-is: Raw781_test.hs- if impl(ghc < 7.7) {- Buildable: False - }-+ default-language: Haskell2010 Test-suite Issue28 type: exitcode-stdio-1.0- build-depends: base, ghc-prim, atomic-primops >= 0.6.0.5+ build-depends: base >= 4.8 && < 5+ , ghc-prim+ , atomic-primops >= 0.6.0.5 main-is: Issue28.hs ghc-options: -main-is Issue28.main- -- if impl(ghc < 7.7) {- -- Buildable: False - -- }+ default-language: Haskell2010 Benchmark atomic-primops-MicroBench type: exitcode-stdio-1.0- build-depends: base, ghc-prim, primitive, containers, random,- atomic-primops >= 0.6.0.5, - deepseq >= 1.3, - time, HUnit, test-framework, test-framework-hunit- build-depends: criterion >= 1.0+ build-depends: base >= 4.8 && < 5+ , ghc-prim+ , primitive+ , containers+ , random+ , atomic-primops >= 0.6.0.5+ , deepseq >= 1.3+ , time+ , HUnit+ , test-framework+ , test-framework-hunit+ , criterion >= 1.2.1 main-is: MicroBench.hs+ default-language: Haskell2010