{-# LANGUAGE MagicHash, UnboxedTuples, BangPatterns, ScopedTypeVariables, NamedFieldPuns, CPP #-}
-- {-# LANGUAGE TemplateHaskell #-}
-- | 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 Control.Concurrent.MVar
import GHC.Conc
import Data.IORef (modifyIORef')
import Data.Int
import Data.Time.Clock
-- import System.Mem.StableName
-- import GHC.IO (unsafePerformIO)
import Text.Printf
-- import qualified GHC.Prim as P
-- import GHC.ST
import GHC.STRef
import GHC.IORef
import GHC.Stats (getGCStats, GCStats(..))
import Data.Primitive.Array
-- import Control.Monad
import Data.Word
import qualified Data.Set as S
import System.Random (randomIO, randomRIO)
import Data.Atomics as A
import Data.Atomics (casArrayElem, readArrayElem)
import Test.HUnit (Assertion, assertEqual, assertBool)
import Test.Framework (Test, defaultMain, testGroup)
import Test.Framework.Providers.HUnit (testCase)
-- import Text.Printf(fprintf)
import GHC.IO (unsafePerformIO)
import System.Mem (performGC)
import System.Mem.StableName (makeStableName, hashStableName)
import System.Environment (getEnvironment)
import System.IO (stdout, stderr, hPutStrLn, hFlush)
import Debug.Trace (trace)
-- import Test.Framework.TH (defaultMainGenerator)
import CommonTesting
import CounterTests (counterTests)
------------------------------------------------------------------------
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
#if 1
-- main = $(defaultMainGenerator)
main :: IO ()
main =
defaultMain $
[ testCase "casTicket1" case_casTicket1
, 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*numCapabilities]
, 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, numCapabilities `quot` 2, numCapabilities, 2*numCapabilities]
, size <- [1, 10, 100]
, iters <- [10000]]
++ counterTests
setify :: [Int] -> [Int]
setify = S.toList . S.fromList
#else
main = do
test_all_hammer_one 1 10000 (0::Int)
putStrLn "Test Done!"
#endif
------------------------------------------------------------------------
{-# 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)
-- | 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 ()
---- 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)
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 :: IORef Int -> IO ()
work = (\counter -> do
tick <- A.readForCAS(counter)
(b,_) <- A.casIORef counter tick (peekTicket tick + 1)
unless b $ work counter)
arr <- forkJoin 120 (\_ -> work counter)
ans <- readIORef counter
assertBool "Did the sum end up equal to 120?" (ans == 120)
-- | 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
-}