No subject

---
 tests/ghc-regress/lib/Concurrent/QSemN002.hs       |   63
++++++++++++++++++++
 tests/ghc-regress/lib/Concurrent/QSemN002.stdout   |   13 ++++
 tests/ghc-regress/lib/Concurrent/SampleVar002.hs   |   47 +++++++++++++++
 .../ghc-regress/lib/Concurrent/SampleVar002.stdout |    8 +++
 tests/ghc-regress/lib/Concurrent/all.T             |    4 +-
 5 files changed, 134 insertions(+), 1 deletions(-)
 create mode 100644 tests/ghc-regress/lib/Concurrent/QSemN002.hs
 create mode 100644 tests/ghc-regress/lib/Concurrent/QSemN002.stdout
 create mode 100644 tests/ghc-regress/lib/Concurrent/SampleVar002.hs
 create mode 100644 tests/ghc-regress/lib/Concurrent/SampleVar002.stdout

diff --git a/tests/ghc-regress/lib/Concurrent/QSemN002.hs
b/tests/ghc-regress/lib/Concurrent/QSemN002.hs
new file mode 100644
index 0000000..e853be9
--- /dev/null
+++ b/tests/ghc-regress/lib/Concurrent/QSemN002.hs
@@ -0,0 +1,63 @@
+-- Check for fix for #3160, http://hackage.haskell.org/trac/ghc/ticket/3160
+module Main where
+
+import Prelude hiding (read)
+import Control.Concurrent
+import Control.Concurrent.MVar
+import Control.Concurrent.QSemN
+import Control.Exception
+import System.Exit
+
+-- delay = threadDelay (1000*100)
+delay = yield
+
+fork x = do m <- newEmptyMVar
+            t <- forkIO (finally x (putMVar m ()))
+            delay
+            return (t,m)
+
+stop (t,m) = do killThread t
+                delay
+                takeMVar m
+
+-- True if test passed, False if test failed
+testSem :: Integral n
+        => String
+        -> (n -> IO a)
+        -> (a->IO ())
+        -> (a -> IO ())
+        -> IO Bool
+testSem name new wait signal = do
+  putStrLn ("\nTest "++ name)
+  q <- new 0
+  putStrLn "0: forkIO wait thread 1"
+  (t1,m1) <- fork $ do
+    wait q `onException` (putStrLn "1: wait interrupted")
+    putStrLn "1: wait done UNEXPECTED"
+  putStrLn "0: stop thread 1"
+  stop (t1,m1)
+  putStrLn "0: signal q #1"
+  signal q
+  delay
+  putStrLn "0: forkIO wait thread 2"
+  (t2,m2) <- fork $ do
+    wait q `onException` (putStrLn "2: wait interrupted UNEXPECTED")
+    putStrLn "2: wait done"
+  putStrLn "0: forkIO wait thread 3"
+  result <- newEmptyMVar
+  (t3,m3) <- fork $ do
+    wait q `onException` (putStrLn "3: wait interrupted (QUANTITY LOST)
FAIL" >> putMVar result False)
+    putStrLn "3: wait done (QUANTITY CONSERVED) PASS"
+    putMVar result True
+  putStrLn "0: signal q #2"
+  signal q
+  delay
+  putStrLn "0: stop thread 2"
+  stop (t2,m2)
+  putStrLn "0: stop thread 3"
+  stop (t3,m3)
+  takeMVar result
+
+main = do
+  _ <- testSem "QSemN" newQSemN (flip waitQSemN 1) (flip signalQSemN 1)
+  return ()
diff --git a/tests/ghc-regress/lib/Concurrent/QSemN002.stdout
b/tests/ghc-regress/lib/Concurrent/QSemN002.stdout
new file mode 100644
index 0000000..def667d
--- /dev/null
+++ b/tests/ghc-regress/lib/Concurrent/QSemN002.stdout
@@ -0,0 +1,13 @@
+
+Test QSemN
+0: forkIO wait thread 1
+0: stop thread 1
+1: wait interrupted
+0: signal q #1
+0: forkIO wait thread 2
+2: wait done
+0: forkIO wait thread 3
+0: signal q #2
+3: wait done (QUANTITY CONSERVED) PASS
+0: stop thread 2
+0: stop thread 3
diff --git a/tests/ghc-regress/lib/Concurrent/SampleVar002.hs
b/tests/ghc-regress/lib/Concurrent/SampleVar002.hs
new file mode 100644
index 0000000..a33d182
--- /dev/null
+++ b/tests/ghc-regress/lib/Concurrent/SampleVar002.hs
@@ -0,0 +1,47 @@
+module Main where
+
+import Prelude hiding (read)
+import Control.Concurrent
+import Control.Exception
+import Control.Concurrent.MVar
+import Control.Concurrent.SampleVar
+import System.Timeout
+
+delay = yield
+
+fork x = do m <- newEmptyMVar
+            t <- forkIO (finally x (putMVar m ()))
+            delay
+            return (t,m)
+
+stop (t,m) = do killThread t
+                delay
+                takeMVar m
+
+testSV name newEmpty read write = do
+  putStrLn ("\nTest "++ name)
+  sv <- newEmpty
+  putStrLn "0: forkIO read thread 1"
+  (t1,m1) <- fork $ do
+    read sv `onException` (putStrLn "1: read interrupted")
+    putStrLn "1: read done UNEXPECTED"
+  putStrLn "0: stop thread 1"
+  stop (t1,m1)
+  putStrLn "0: write sv #1"
+  write sv 1
+  putStrLn "0: write sv #2 with timeout"
+  m <- timeout (1000*100) (write sv 2)
+  case m of
+    Nothing -> do
+      putStrLn "0: timeout triggered, write sv #2 blocked, FAIL"
+      return False
+    Just () -> do
+      putStrLn "0: write sv #2 returned, PASS"
+      return True
+
+main = do
+  _ <- testSV "SampleVar" newEmptySampleVar readSampleVar writeSampleVar
+  return ()
+
+
+
diff --git a/tests/ghc-regress/lib/Concurrent/SampleVar002.stdout
b/tests/ghc-regress/lib/Concurrent/SampleVar002.stdout
new file mode 100644
index 0000000..cd5853a
--- /dev/null
+++ b/tests/ghc-regress/lib/Concurrent/SampleVar002.stdout
@@ -0,0 +1,8 @@
+
+Test SampleVar
+0: forkIO read thread 1
+0: stop thread 1
+1: read interrupted
+0: write sv #1
+0: write sv #2 with timeout
+0: write sv #2 returned, SUCCESS
diff --git a/tests/ghc-regress/lib/Concurrent/all.T
b/tests/ghc-regress/lib/Concurrent/all.T
index 5ba43d0..a63f23c 100644
--- a/tests/ghc-regress/lib/Concurrent/all.T
+++ b/tests/ghc-regress/lib/Concurrent/all.T
@@ -7,5 +7,7 @@ test('Chan001',      reqlib('QuickCheck'),
compile_and_run, ['-package QuickChec
 test('MVar001',      reqlib('QuickCheck'), compile_and_run, ['-package
QuickCheck'])
 test('QSemN001',     reqlib('QuickCheck'), compile_and_run, ['-package
QuickCheck'])
 test('QSem001',      reqlib('QuickCheck'), compile_and_run, ['-package
QuickCheck'])
-test('ThreadDelay001', normal, compile_and_run, [''])
 test('QSem002', normal, compile_and_run, [''])
+test('QSemN002', normal, compile_and_run, [''])
+test('SampleVar002', normal, compile_and_run, [''])
+test('ThreadDelay001', normal, compile_and_run, [''])
-- 
1.7.2