{-# 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) import Test.Framework.Providers.HUnit (testCase) import System.Mem (performGC) ---------------------------------------- import Data.Atomics as A import Data.Atomics (casArrayElem, readArrayElem) import qualified Issue28 import CommonTesting import qualified CounterReference import qualified CounterUnboxed import qualified CounterIORef ------------------------------------------------------------------------ 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 $ [ 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]] ++ CounterReference.tests ++ CounterUnboxed.tests ++ CounterIORef.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 <- readArrayElem arr 4 putStrLn$ "(Peeking at array gave: "++show (peekTicket tick)++")" (res1,tick2) <- casArrayElem arr 3 tick 44 (res2,_) <- casArrayElem arr 3 tick 44 -- res <- stToIO$ casArrayST arr 3 mynum 44 -- res2 <- stToIO$ casArrayST arr 3 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 <- readArrayElem arr 0 for_ 1 size $ \ i -> do t2 <- 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 (b,newtick) <- casArrayElem arr ix tick0 (Just iter) return () else do -- Consume: tick <- readArrayElem arr ix case peekTicket tick of Just _ -> do (b,x) <- casArrayElem arr ix tick (peekTicket tick0) -- Set back to Nothing. when b $ 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 ---------------------------------------------------------------------------------------------------- {-# NOINLINE zer #-} zer :: Int zer = 0 default_iters :: Int default_iters = 100000 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) res1 <- A.casIORef x tick1 5 tick2 <- A.readForCAS(x) res2 <- 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 -> IORef Int -> IO (Int,Int,Int,Int,Int) work ix counter = 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 counter arr <- forkJoin 120 (\i -> work i counter) 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 n = do performGC -- We *ASSUME* GC does not happen below. performGC -- We *ASSUME* GC does not happen below. checkGCStats gc1 <- getGCCount r <- newIORef n 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 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) ---------------------------------------------------------------------------------------------------- {- -- 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 -}