{-# 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 -}