diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,6 @@ +## 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 diff --git a/atomic-primops.cabal b/atomic-primops.cabal --- a/atomic-primops.cabal +++ b/atomic-primops.cabal @@ -1,5 +1,5 @@ Name: atomic-primops -Version: 0.8.1 +Version: 0.8.1.1 License: BSD3 License-file: LICENSE Author: Ryan Newton @@ -30,7 +30,7 @@ Extra-Source-Files: CHANGELOG.md, 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/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 diff --git a/testing/Fetch.hs b/testing/Fetch.hs new file mode 100644 --- /dev/null +++ b/testing/Fetch.hs @@ -0,0 +1,219 @@ +module Fetch (tests) where + +-- tests for our fetch-and-* family of functions. +import Control.Monad +import Control.Applicative +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 diff --git a/testing/test-atomic-primops.cabal b/testing/test-atomic-primops.cabal --- a/testing/test-atomic-primops.cabal +++ b/testing/test-atomic-primops.cabal @@ -19,12 +19,17 @@ Test-Suite test-atomic-primops type: exitcode-stdio-1.0 main-is: Test.hs + 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. @@ -45,6 +50,7 @@ Test-suite template-haskell-atomic-primops type: exitcode-stdio-1.0 main-is: ghci-test.hs + other-modules: TemplateHaskellSplices if impl(ghc >= 7.8) { Buildable: True build-depends: base >= 4.5, atomic-primops >= 0.6.0.5, template-haskell, @@ -61,7 +67,7 @@ -- ghc-prim, primitive, containers, random, atomic-primops >= 0.5.0.2, main-is: Raw781_test.hs if impl(ghc < 7.7) { - Buildable: False + Buildable: False } @@ -71,14 +77,14 @@ main-is: Issue28.hs ghc-options: -main-is Issue28.main -- if impl(ghc < 7.7) { - -- Buildable: False + -- Buildable: False -- } 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, + atomic-primops >= 0.6.0.5, + deepseq >= 1.3, time, HUnit, test-framework, test-framework-hunit build-depends: criterion >= 1.0 main-is: MicroBench.hs