Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Browse files

add test from #1283

  • Loading branch information...
commit 7ccd425a182e204977eac0d696f175f7bc48aca9 1 parent 49a969d
Simon Marlow authored
Showing with 44 additions and 0 deletions.
  1. +7 −0 tests/Makefile
  2. +1 −0  tests/all.T
  3. +36 −0 tests/random1283.hs
View
7 tests/Makefile
@@ -0,0 +1,7 @@
+# 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.
+
+TOP=../../../testsuite
+include $(TOP)/mk/boilerplate.mk
+include $(TOP)/mk/test.mk
View
1  tests/all.T
@@ -0,0 +1 @@
+test('random1283', reqlib('containers'), compile_and_run, ['-package containers'])
View
36 tests/random1283.hs
@@ -0,0 +1,36 @@
+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
Please sign in to comment.
Something went wrong with that request. Please try again.