Commit 7ccd425a authored by Simon Marlow's avatar Simon Marlow
Browse files

add test from #1283

parent 49a969da
# This Makefile runs the tests using GHC's testsuite framework. It
# assumes the package is part of a GHC build tree with the testsuite
# installed in ../../../testsuite.
include $(TOP)/mk/
include $(TOP)/mk/
test('random1283', reqlib('containers'), compile_and_run, ['-package containers'])
import Control.Concurrent
import Control.Monad
import Data.Sequence hiding (take)
import System.Random
threads = 4
samples = 5000
main = loopTest threads samples
loopTest t s = do
isClean <- testRace t s
when (not isClean) $ putStrLn "race condition!"
testRace t s = do
ref <- liftM (take (t*s) . randoms) getStdGen
iss <- threadRandoms t s
return (isInterleavingOf (ref::[Int]) iss)
threadRandoms t s = do
vs <- sequence $ replicate t $ do
v <- newEmptyMVar
forkIO (sequence (replicate s randomIO) >>= putMVar v)
return v
mapM takeMVar vs
isInterleavingOf xs yss = iio xs (viewl $ fromList yss) EmptyL where
iio (x:xs) ((y:ys) :< yss) zss
| x /= y = iio (x:xs) (viewl yss) (viewl (fromViewL zss |> (y:ys)))
| x == y = iio xs (viewl ((ys <| yss) >< fromViewL zss)) EmptyL
iio xs ([] :< yss) zss = iio xs (viewl yss) zss
iio [] EmptyL EmptyL = True
iio _ _ _ = False
fromViewL (EmptyL) = empty
fromViewL (x :< xs) = x <| xs
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment