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