atomic-primops 0.7 → 0.8
raw patch · 10 files changed
+574/−216 lines, 10 filesnew-uploaderPVP ok
version bump matches the API change (PVP)
API changes (from Hackage documentation)
+ Data.Atomics: fetchAddIntArray :: MutableByteArray RealWorld -> Int -> Int -> IO Int
+ Data.Atomics: fetchAndIntArray :: MutableByteArray RealWorld -> Int -> Int -> IO Int
+ Data.Atomics: fetchNandIntArray :: MutableByteArray RealWorld -> Int -> Int -> IO Int
+ Data.Atomics: fetchOrIntArray :: MutableByteArray RealWorld -> Int -> Int -> IO Int
+ Data.Atomics: fetchSubIntArray :: MutableByteArray RealWorld -> Int -> Int -> IO Int
+ Data.Atomics: fetchXorIntArray :: MutableByteArray RealWorld -> Int -> Int -> IO Int
Files
- Data/Atomics.hs +211/−13
- Data/Atomics/Counter.hs +12/−15
- Data/Atomics/Internal.hs +3/−4
- atomic-primops.cabal +8/−3
- testing/CommonTesting.hs +4/−4
- testing/Counter.hs +4/−138
- testing/CounterCommon.hs +152/−0
- testing/Issue28.hs +2/−2
- testing/Test.hs +177/−36
- testing/test-atomic-primops.cabal +1/−1
Data/Atomics.hs view
@@ -23,39 +23,53 @@ 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 GHC.IORef hiding (atomicModifyIORef) import GHC.STRef-import GHC.ST #if MIN_VERSION_base(4,7,0) import GHC.Prim 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#)) ++#if MIN_VERSION_base(4,8,0)+#else+import Data.Bits+import Data.Primitive.ByteArray (readByteArray)+#endif+ #ifdef DEBUG_ATOMICS #warning "Activating DEBUG_ATOMICS... NOINLINE's and more" {-# NOINLINE seal #-}@@ -69,6 +83,13 @@ {-# 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 #-} @@ -79,6 +100,12 @@ {-# INLINE readMutVarForCAS #-} {-# INLINE casMutVar #-} {-# INLINE casMutVar2 #-}+{-# INLINE fetchAddIntArray #-}+{-# INLINE fetchSubIntArray #-}+{-# INLINE fetchAndIntArray #-}+{-# INLINE fetchNandIntArray #-}+{-# INLINE fetchOrIntArray #-}+{-# INLINE fetchXorIntArray #-} #endif @@ -122,6 +149,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,6 +165,126 @@ (# 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+-- fetchAddIntArray# changed behavior in 7.10 to return the OLD value, so we+-- need this to maintain backwards compatibility:+#if MIN_VERSION_base(4,8,0)+ (# s2#, (I# res) #)+#else+ (# s2#, (I# (res -# incr#)) #)+#endif+++-- | 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 +#if MIN_VERSION_base(4,8,0)+ fetchSubIntArray# +#else+ (-)+#endif++-- | 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 +#if MIN_VERSION_base(4,8,0)+ fetchAndIntArray# +#else+ (.&.)+#endif++-- | 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 +#if MIN_VERSION_base(4,8,0)+ fetchNandIntArray# +#else+ nand+ where nand x y = complement (x .&. y)+#endif++-- | 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 +#if MIN_VERSION_base(4,8,0)+ fetchOrIntArray# +#else+ (.|.)+#endif++-- | 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 +#if MIN_VERSION_base(4,8,0)+ fetchXorIntArray# +#else+ xor+#endif+++-- Internals for our fetch* family of functions, with CAS loop fallbacks for+-- GHC < 7.10:+{-# INLINE doAtomicRMW #-}+#if MIN_VERSION_base(4,8,0)+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) #)+#else+doAtomicRMW :: (Int -> Int -> Int) -- fallback op for CAS loop+ -> MutableByteArray RealWorld -> Int -> Int -> IO Int -- exported function+doAtomicRMW op =+ \mba offset val ->+ let loop = do+ old <- readByteArray mba offset+ let !new = old `op` val+ actualOld <- casByteArrayInt mba offset old new+ if old == actualOld+ then return actualOld+ else loop+ in loop+{-# WARNING fetchSubIntArray "fetchSubIntArray is implemented with a CAS loop on GHC <7.10" #-}+{-# WARNING fetchAndIntArray "fetchAndIntArray is implemented with a CAS loop on GHC <7.10" #-}+{-# WARNING fetchNandIntArray "fetchNandIntArray is implemented with a CAS loop on GHC <7.10" #-}+{-# WARNING fetchOrIntArray "fetchOrIntArray is implemented with a CAS loop on GHC <7.10" #-}+{-# WARNING fetchXorIntArray "fetchXorIntArray is implemented with a CAS loop on GHC <7.10" #-}+#endif++ {-# DEPRECATED fetchAddByteArrayInt "Replaced by fetchAddIntArray which returns the OLD value" #-} -- | Atomically add to a word of memory within a `MutableByteArray`. -- @@ -153,8 +302,58 @@ (# 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 +-- imports for GHC < 7.10 conditionals below.+#if MIN_VERSION_base(4,8,0)+#else+import Control.Monad (void)+import Data.Primitive.ByteArray (writeByteArray)+#endif +++-- | 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+#if MIN_VERSION_base(4,8,0)+atomicReadIntArray (MutableByteArray mba#) (I# ix#) = IO $ \ s# ->+ case atomicReadIntArray# mba# ix# s# of+ (# s2#, n# #) -> (# s2#, I# n# #)+#else+atomicReadIntArray mba ix = do+ -- I don't think we can get a full barrier here with the three barriers we+ -- have exposed, so we use a no-op CAS, which implies a full barrier+ casByteArrayInt mba ix 0 0+{-# WARNING atomicReadIntArray "atomicReadIntArray is implemented with a CAS on GHC <7.10 and may be slower than a readByteArray + one of the barriers exposed here" #-}+#endif++-- | 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 ()+#if MIN_VERSION_base(4,8,0)+atomicWriteIntArray (MutableByteArray mba#) (I# ix#) (I# n#) = IO $ \ s# ->+ case atomicWriteIntArray# mba# ix# n# s# of+ s2# -> (# s2#, () #)+#else+atomicWriteIntArray mba ix n = do+ -- As above we use a no-op CAS to get a full barrier. This is particularly+ -- gross TODO something better if possible+ let fullBarrier = void $ casByteArrayInt mba ix 0 0+ fullBarrier+ writeByteArray mba ix n+ fullBarrier+{-# WARNING atomicWriteIntArray "atomicWriteIntArray is likely to be very slow on GHC <7.10. Consider using writeByteArray along with one of the barriers exposed here instead" #-}+#endif++-}++--------------------------------------------------------------------------------+ -- | Ordinary processor load instruction (non-atomic, not implying any memory barriers). -- -- The difference between this function and `readIORef`, is that it returns a /ticket/,@@ -229,8 +428,8 @@ 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') #)+ (# 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') #) @@ -293,7 +492,7 @@ loop tick effort where effort = 30 :: Int -- TODO: Tune this.- loop old 0 = atomicModifyIORef ref fn -- Fall back to the regular version.+ 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@@ -312,13 +511,12 @@ loop tick effort where effort = 30 :: Int -- TODO: Tune this.- loop old 0 = atomicModifyIORef_ ref fn+ loop _ 0 = atomicModifyIORef ref (\ x -> (fn x, ())) loop old tries = do new <- evaluate $ fn $ peekTicket old (b,val) <- casIORef ref old new 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,17 +32,12 @@ 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 @@ -83,23 +78,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 +122,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@@ -154,5 +149,7 @@ -- | 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+ -- NOTE: either old or new behavior of fetchAddIntArray# is fine here, since+ -- we don't inspect the return value:+ let (# s2#, _ #) = fetchAddIntArray# mba# 0# incr# s1# in (# s2#, () #)
Data/Atomics/Internal.hs view
@@ -16,18 +16,17 @@ where import GHC.Base (Int(I#))-import GHC.Word (Word(W#))-import GHC.Prim (RealWorld, Int#, Word#, State#, MutableArray#, MutVar#,- MutableByteArray#, +import GHC.Prim (RealWorld, Int#, State#, MutableArray#, MutVar#, unsafeCoerce#, reallyUnsafePtrEquality#) #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)+import GHC.Prim (readMutVar#, Any, MutableByteArray#) #else #error "Need to figure out how to emulate Any () in GHC <= 7.4 !"+-- import GHC.Prim (Word#) -- type Any a = Word# #endif
atomic-primops.cabal view
@@ -1,5 +1,5 @@ Name: atomic-primops-Version: 0.7+Version: 0.8 License: BSD3 License-file: LICENSE Author: Ryan Newton@@ -34,7 +34,7 @@ -- 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+-- 0.8 -- support for GHC 7.10 and several new primops Synopsis: A safe approach to CAS and other atomic ops in Haskell. @@ -82,11 +82,15 @@ Changes in 0.7: . * This release adds support for GHC 7.10 and its expanded library of (now inline) primops.+ .+ Changes in 0.8: + .+ * Implements additional fetch primops available in GHC 7.10 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+ testing/Makefile, testing/CommonTesting.hs, testing/Counter.hs, testing/CounterCommon.hs, testing/hello.hs testing/Issue28.hs testing/TemplateHaskellSplices.hs testing/Raw781_test.hs@@ -101,6 +105,7 @@ Data.Atomics.Internal Data.Atomics.Counter ghc-options: -O2 -funbox-strict-fields+ ghc-options: -Wall -- 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.
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/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
@@ -22,18 +22,18 @@ import GHC.Stats (getGCStats, GCStats(..)) 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 qualified Counter+import qualified Fetch ------------------------------------------------------------------------ @@ -53,8 +53,12 @@ -- numcap <- getNumProcessors let numcap = 4 when (numCapabilities /= numcap) $ setNumCapabilities numcap- + 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 +93,7 @@ , iters <- [10000]] ++ Counter.tests+ ++ Fetch.tests setify :: [Int] -> [Int] setify = S.toList . S.fromList@@ -115,11 +120,11 @@ 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 @@ -141,12 +146,12 @@ test_random_array_comm :: Int -> Int -> Int -> IO () 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:@@ -154,13 +159,12 @@ -- Randomly either produce or consume: b <- randomIO :: IO Bool if b then do - (b,newtick) <- casArrayElem arr ix tick0 (Just iter)- return ()+ 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 ()@@ -169,13 +173,13 @@ 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 ()@@ -185,12 +189,6 @@ -- 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:"@@ -221,7 +219,7 @@ 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 +247,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,8 +262,8 @@ 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@@ -279,8 +277,8 @@ 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]@@ -306,13 +304,13 @@ -- | 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+ r <- newIORef initialVal bitls <- newIORef [] tick1 <- A.readForCAS r let loop 0 = return ()@@ -321,7 +319,7 @@ 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@@ -332,7 +330,7 @@ ls <- readIORef bitls let rev = (reverse ls)- tickets = map snd rev+ -- tickets = map snd rev (hd:tl) = map fst rev gc2 <- getGCCount@@ -402,6 +400,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++ -}+ ---------------------------------------------------------------------------------------------------- {-
testing/test-atomic-primops.cabal view
@@ -19,7 +19,7 @@ Test-Suite test-atomic-primops type: exitcode-stdio-1.0 main-is: Test.hs- ghc-options: -rtsopts -main-is Test.main+ ghc-options: -rtsopts -main-is Test.main -Wall if flag(opt) ghc-options: -O2 -funbox-strict-fields