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