[project @ 2001-07-06 14:18:53 by simonmar]

Add test for broken takeMVar/putMVar in 5.00.2.

Bug reported by Greg Mildenhall <gregm@pc-121.cs.uwa.edu.au> on
comp.lang.functional..

diff --git a/ghc/tests/concurrent/should_run/conc032.hs b/ghc/tests/concurrent/should_run/conc032.hs
new file mode 100644 (file)
index 0000000..af4be51
--- /dev/null
+++ b/ghc/tests/concurrent/should_run/conc032.hs
@@ -0,0 +1,74 @@
+-- !!! this test exposed a bug in the take/putMVar implementation in
+-- !!! GHC 5.00.  It involves multiple blocking takes & puts on the
+-- !!! same MVar.
+
+import Concurrent
+import IOExts
+
+awk True  True  z     = 1
+awk False y     True  = 2
+awk x     False False = 3
+
+awk'1 True  True  z     = 1
+awk'2 False y     True  = 2
+awk'3 x     False False = 3
+
+awk' x y z | ppm [a1'1,a1'2,a1'3] (x,y,z) = awk'1 x y z
+           | ppm [a2'1,a2'2,a2'3] (x,y,z) = awk'2 x y z
+           | ppm [a3'1,a3'2,a3'3] (x,y,z) = awk'3 x y z
+           | otherwise                      = 0
+
+a1'1 (True,y,z)  s = s True
+a1'1 (x,y,z)     s = s False
+
+a1'2 (x,True,z)  s = s True
+a1'2 (x,y,z)     s = s False
+
+a1'3 (x,y,z)     s = s True
+
+a2'1 (False,y,z) s = s True
+a2'1 (x,y,z)     s = s False
+
+a2'2 (x,y,z)     s = s True
+
+a2'3 (x,y,True)  s = s True
+a2'3 (x,y,z)     s = s False
+
+a3'1 (x,y,z)     s = s True
+
+a3'2 (x,False,z) s = s True
+a3'2 (x,y,z)     s = s False
+
+a3'3 (x,y,False) s = s True
+a3'3 (x,y,z)     s = s False
+
+ppm fs as = unsafePerformIO (ppm' fs as)
+
+ppm' fs as = do m <- newEmptyMVar
+                let s = putMVar m
+                hs <- sequence [forkIO (f as s)|f <- fs]
+                result <- assess (length fs) m
+                sequence (map killThread hs)
+                return result
+                  where assess 0 m = return True
+                        assess n m = do h <- takeMVar m
+                                        if h then (assess (n-1) m)
+                                             else return False
+
+main = do sequence [putStrLn (show (awk' x y z))|(x,y,z) <- args]
+            where args = [
+                          (t,t,t),
+                          (t,t,f),
+                          (t,f,t),
+                          (t,f,f),
+                          (f,t,t),
+                          (f,t,f),
+                          (f,f,t),
+                          (f,f,f),
+                          (t,t,n)
+                          --(f,n,t),
+                          --(n,f,f),
+                         ]
+                  t    = True
+                  f    = False
+                  n    = odd (last [1..])

diff --git a/ghc/tests/concurrent/should_run/conc032.stdout b/ghc/tests/concurrent/should_run/conc032.stdout
new file mode 100644 (file)
index 0000000..a357bc8
--- /dev/null
+++ b/ghc/tests/concurrent/should_run/conc032.stdout
@@ -0,0 +1,9 @@
+1
+1
+0
+3
+2
+0
+2
+3
+1