add test from #1283 2007-09-13 ghc-6_8_branched_2007-09-03
authorSimon Marlow <simonmar@microsoft.com>
Thu, 30 Aug 2007 14:10:50 +0000 (14:10 +0000)
committerSimon Marlow <simonmar@microsoft.com>
Thu, 30 Aug 2007 14:10:50 +0000 (14:10 +0000)
tests/Makefile [new file with mode: 0644]
tests/all.T [new file with mode: 0644]
tests/random1283.hs [new file with mode: 0644]

diff --git a/tests/Makefile b/tests/Makefile
new file mode 100644 (file)
index 0000000..6a0abcf
--- /dev/null
@@ -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
diff --git a/tests/all.T b/tests/all.T
new file mode 100644 (file)
index 0000000..367fd57
--- /dev/null
@@ -0,0 +1 @@
+test('random1283', reqlib('containers'), compile_and_run, ['-package containers'])
diff --git a/tests/random1283.hs b/tests/random1283.hs
new file mode 100644 (file)
index 0000000..296b490
--- /dev/null
@@ -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