{-# LANGUAGE MagicHash, UnboxedTuples, BangPatterns, ScopedTypeVariables, NamedFieldPuns, CPP #-}
module Test ( main,
test_all_hammer_one ) where
-- | This test has three different modes which can be toggled via the
-- C preprocessor. Any subset of the three may be activated.
import Control.Monad
-- import Control.Monad.ST (stToIO)
import Control.Exception (evaluate)
import Data.IORef (modifyIORef')
import Data.Int
import Data.Primitive.Array
import Data.Word
import qualified Data.Set as S
import Data.List ((\\))
import Text.Printf
import GHC.Conc
import GHC.STRef
import GHC.IORef
import GHC.Stats (getGCStats, GCStats(..))
import System.Random (randomIO, randomRIO)
import Test.HUnit (Assertion, assertEqual, assertBool)
import Test.Framework (defaultMain,testGroup,mutuallyExclusive)
import Test.Framework.Providers.HUnit (testCase)
import System.Mem (performGC)
----------------------------------------
import Data.Atomics as A
import qualified Issue28
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 =
do GCStats{numGcs} <- getGCStats
return numGcs
| otherwise = return 0
main :: IO ()
main = do
-- TEMP: Fixing this at four processors because it takes a REALLY long time at larger numbers:
-- It does 248 test cases and takes 55s at -N16...
-- 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
, testCase "create_and_read" case_create_and_read
, testCase "create_and_mutate" case_create_and_mutate
, testCase "create_and_mutate_twice" case_create_and_mutate_twice
, testCase "n_threads_mutate" case_n_threads_mutate
, testCase "run_barriers" case_run_barriers
, testCase "test_succeed_once Int" (test_succeed_once (0::Int))
, testCase "test_succeed_once Int64" (test_succeed_once (0::Int64))
, testCase "test_succeed_once Word32" (test_succeed_once (0::Word32))
, testCase "test_succeed_once Word16" (test_succeed_once (0::Word16))
, testCase "test_succeed_once Word8" (test_succeed_once (0::Word8))
]
++
-- all_hammerConfigs (0::Int64)
-- Test several configurations of this one:
[ testCase ("test_all_hammer_one_"++show threads++"_"++show iters ++":")
(test_all_hammer_one threads iters (0::Int))
| threads <- [1 .. 2*numcap]
, iters <- [1, 10, 100, 1000, 10000, 100000, 500000]] ++
[ testCase ("test_hammer_many_threads_1000_10000:")
(test_all_hammer_one 1000 10000 (0::Int)) ] ++
[ testCase "casmutarray1" case_casmutarray1] ++
[ testCase ("test_random_array_comm_"++show threads++"_"++show size++"_"++show iters ++":")
(test_random_array_comm threads size iters)
| threads <- filter (>0) $ setify $
[1, numcap `quot` 2, numcap, 2*numcap]
, size <- [1, 10, 100]
, iters <- [10000]]
++ Counter.tests
++ Fetch.tests
setify :: [Int] -> [Int]
setify = S.toList . S.fromList
------------------------------------------------------------------------
{-# NOINLINE mynum #-}
mynum :: Int
mynum = 33
-- Expected output:
{---------------------------------------
Perform a CAS within a MutableArray#
1st try should succeed: (True,33)
2nd should fail: (False,44)
Printing array:
33 33 33 44 33
Done.
-}
case_casmutarray1 :: IO ()
case_casmutarray1 = do
putStrLn "Perform a CAS within a MutableArray#"
arr <- newArray 5 mynum
writeArray arr 4 33
putStrLn "Wrote array elements..."
tick <- A.readArrayElem arr 4
putStrLn$ "(Peeking at array gave: "++show (peekTicket tick)++")"
(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
putStrLn "Printing array:"
forM_ [0..4] $ \ i -> do
x <- readArray arr i
putStr (" "++show x)
assertBool "1st try should succeed: " res1
assertBool "2nd should fail: " (not res2)
-- case_casbytearray1 :: IO ()
-- 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
arr <- newArray size Nothing
tick0 <- A.readArrayElem arr 0
for_ 1 size $ \ i -> do
t2 <- A.readArrayElem arr i
assertEqual "All initial Nothings in the array should be ticket-equal:" tick0 t2
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
void $ A.casArrayElem arr ix tick0 (Just iter)
else do -- Consume:
tick <- A.readArrayElem arr ix
case peekTicket tick of
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)
assertBool "Number of successes: " (successes <= (threads * iters) `quot` 2 && successes >= 0)
for_ 0 size $ \ i -> do
_x <- readArray arr i
-- putStr (show _x ++ " ")
return ()
putStrLn ""
return ()
----------------------------------------------------------------------------------------------------
-- Simple, non-parameterized tests
----------------------------------------------------------------------------------------------------
case_casTicket1 :: IO ()
case_casTicket1 = do
dbgPrint 1 "\nUsing new 'ticket' based compare and swap:"
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
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
res3 <- A.readMutVarForCAS mutvar
dbgPrint 1$"To check contents, did a SECOND read: "++show res3
return ()
case_issue28_standalone :: Assertion
case_issue28_standalone = Issue28.main
case_issue28_copied :: Assertion
case_issue28_copied = do
r <- newIORef "hi"
t0 <- readForCAS r
(True,_t1) <- casIORef r t0 "bye"
return ()
---- toddaaro's tests -----
case_create_and_read :: Assertion
case_create_and_read = do
dbgPrint 1$ " Creating a single value and trying to read it."
x <- newIORef (120::Int)
valf <- readIORef x
assertBool " Does x equal 120?" (valf == 120)
case_create_and_mutate :: Assertion
case_create_and_mutate = do
dbgPrint 1$ " Creating a single 'ticket' based variable to use and mutating it once."
x <- newIORef (5::Int)
tick <- A.readForCAS(x)
res <- A.casIORef x tick 120
dbgPrint 1$ " Did setting it to 120 work?"
dbgPrint 1$ " Result was: " ++ show res
valf <- readIORef x
assertBool "Does our x equal 120?" (valf == 120)
case_create_and_mutate_twice :: Assertion
case_create_and_mutate_twice = do
dbgPrint 1$ " Creating a single 'ticket' based variable to mutate twice."
x <- newIORef (0::Int)
tick1 <- A.readForCAS(x)
void $ A.casIORef x tick1 5
tick2 <- A.readForCAS(x)
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)
-- [2013.07.19] I just saw an isolated failure of this one:
-- [2014.01.31] I saw another failure of this on -N1 (0e0d64c3d7), observing 118 sum.
case_n_threads_mutate :: Assertion
case_n_threads_mutate = do
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 -> 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
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) $
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
arr <- forkJoin 120 work
ans <- readIORef counter
let dups = [ n | (_,_,_,_,n) <- arr] \\ [1..120]
putStrLn $ "\n Duplicates were "++show dups++", Array:"
print arr
-- assertBool "Did the 120 threads CASing yield a valid sum" (1 <= ans && ans <= 120)
-- The retry loop should ensure that each thread increments ONCE:
assertEqual "Did the 120 threads CASing all succeed?" 120 ans
-- | Just make sure these link and run properly:
case_run_barriers :: Assertion
case_run_barriers = do
A.storeLoadBarrier
A.loadLoadBarrier
A.writeBarrier
----------------------------------------------------------------------------------------------------
----------------------------------------------------------------------------------------------------
-- 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 initialVal =
do
performGC -- We *ASSUME* GC does not happen below.
performGC -- We *ASSUME* GC does not happen below.
checkGCStats
gc1 <- getGCCount
r <- newIORef initialVal
bitls <- newIORef []
tick1 <- A.readForCAS r
let loop 0 = return ()
loop n = do
res <- A.casIORef r tick1 100
atomicModifyIORef bitls (\x -> (res:x, ()))
-- putStrLn$ " CAS result: " ++ show res
loop (n-1)
loop (10::Int)
x <- readIORef r
assertEqual "Finished with loop, read cell: " 100 x
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
(hd:tl) = map fst rev
gc2 <- getGCCount
if gc1 /= gc2
then putStrLn " [skipped] test couldn't be assessed properly due to GC."
else do
-- print scrubbed
assertBool "Only first succeeds" (all (/= hd) tl)
assertBool "All but first fail" (all (== head tl) (tail tl))
assertEqual "First should succeed, rest fail"
(hd : tl)
(True : replicate 9 False)
-- | This version hammers on CASref from all threads, then checks to see
-- if enough threads succeeded enough of the time.
--
-- If each thread tries K attempts, there should be at least K total successes. To
-- establish this consider the inductive argument. One thread should succeed all the
-- 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 $ \_ ->
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
bumped <- evaluate$ expected + 1
(res,tick) <- casIORef ref ticket bumped
case res of
True -> do
when (iters < 30) $
dbgPrint 1$ " Succeed CAS, old tick "++show ticket++" new "++show tick++", wrote "++show bumped
loop (n-1) tick bumped (True:acc)
False -> do
let v = peekTicket tick
when (iters < 30) $
dbgPrint 1 $
" Fizzled CAS with ticket: "++show ticket ++" containing "++show v++
", expected: "++ show expected ++
" (#"++show (unsafeName expected)++"): "
++ " found " ++ show v ++ " (#"++show (unsafeName v)++", ticket "++show tick++")"
loop (n-1) tick v (False:acc)
tick0 <- readForCAS ref
loop iters tick0 (peekTicket tick0) []
numGcs <- getGCCount
let successes = map (length . filter id) logs
total_success = sum successes
bool2char True = '1'
bool2char False = '0'
-- EACH thread may fail on a single GC (in theory)
expected_success = iters - (threads * fromIntegral numGcs)
msg = ("Runs "++show (map length logs)++" (GCs "++show numGcs++"), had enough successes?: "
++show successes++" >= "++ show expected_success ++"\n"
++(unlines $ map (dotdot 80 . (" "++) . map bool2char) logs) )
dbgPrint 1 msg
assertBool msg
(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
-}
----------------------------------------------------------------------------------------------------
{-
-- UNFINISHED
-- This tests repeated atomicModifyIORefCAS operations.
testCAS3 :: Int -> IORef ElemTy -> IO [()]
testCAS3 iters ref =
forkJoin numCapabilities (loop iters)
where
loop 0 = return ()
loop n = do
-- let bumped = expected+1 -- Must do this only once, should be NOINLINE
-- let bump !x !y = x+y
#ifdef T1
A.atomicModifyIORefCAS_ ref (+1)
#endif
#ifdef T2
-- B.atomicModifyIORefCAS_ ref (+1)
-- B.atomicModifyIORefCAS_ ref (bump 1)
x <- atomicModifyIORef ref (\x -> (x+1,x))
evaluate x -- Avoid stack leak.
#endif
loop (n-1)
----------------------------------------------------------------------------------------------------
-- This version uses a non-scalar type for CAS. It instead
-- manipulates the tail pointers of a simple linked-list.
#if 0
data List k = Null | Cons Int (k (List k))
type ListA = List A.CASRef
type ListB = List B.CASRef
type ListC = List C.CASRef
-- testCAS4 :: CASable ref Int => List ref -> IO [Bool]
testCAS4 :: CASable ref Int => Int -> ref (List ref) -> IO ()
testCAS4 iters ref = do
forkJoin numCapabilities $ do
-- From each thread, attempt to extend the list 'iters' times:
ref' <- readCASable ref
nl <- newIORef Null
loop iters (Cons (-1) nl) ref'
return ()
return ()
where
loop 0 _ _ = return ()
loop n new (Cons _ tl) = do
tl' <- readCASable tl
case tl' of
Null -> do (b,v) <- cas tl tl' new
if b then loop (n-1) v
else loop v
cons -> loop cons tl'
loop n _ Null = error "too short"
#endif
----------------------------------------------------------------------------------------------------
-- Test Oracles
checkOutput1 msg ls =
if ls == True : replicate (9) False
then return ()
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
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.."
checkOutput3 :: String -> Int -> [[Bool]] -> ElemTy -> IO ()
checkOutput3 msg iters ls fin = do
return ()
----------------------------------------------------------------------------------------------------
-- test x = do
-- 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"
-- (unsafeCoerce b :: Word)
-- ((fromIntegral$ ptrToIntPtr $ castStablePtrToPtr b) :: Int)
-- main = test 3
-}