Thread instrumentation test.

2 files changed, 26 insertions, 0 deletions

diff --git a/lifted-concurrent/lifted-concurrent.cabal b/lifted-concurrent/lifted-concurrent.cabal
index 8fe4b6a9..26e9df68 100644
--- a/lifted-concurrent/lifted-concurrent.cabal
+++ b/lifted-concurrent/lifted-concurrent.cabal
@@ -35,3 +35,8 @@ library
   hs-source-dirs:      src
   default-language:    Haskell2010
   cpp-options: -DTHREAD_DEBUG
+
+executable testhr
+    build-depends: base,lifted-concurrent
+    main-is: TestThreads.hs
+    hs-source-dirs: test
diff --git a/lifted-concurrent/test/TestThreads.hs b/lifted-concurrent/test/TestThreads.hs
new file mode 100644
index 00000000..8360badb
--- /dev/null
+++ b/lifted-concurrent/test/TestThreads.hs
@@ -0,0 +1,21 @@
+import Control.Monad
+import Control.Exception (throwIO)
+
+import Control.Concurrent.ThreadUtil
+import DebugUtil
+
+main = do
+    mvars <- sequence $ replicate 200 $ newEmptyMVar
+    threads <- forM mvars $ forkIO . join . takeMVar
+    let (normalquits,mvars1) = splitAt 20 mvars
+    mapM_ (`putMVar` return ()) normalquits
+    let (exceptionquits,mvars2) = splitAt 20 mvars1
+    mapM_ (`putMVar` throwIO (userError "oops")) exceptionquits
+    let (throwtoexceptions,threads1) = splitAt 20 $ drop 40 threads
+    mapM_ (`throwTo` userError "throwTo-oops") throwtoexceptions
+    let (killed,threads2) = splitAt 20 threads1
+    mapM_ killThread killed
+    threadDelay 1000000
+    report <- threadReport True
+    sequence_ $ zipWith (\n s -> putStrLn $ unwords [show n,s]) [1..] $ lines report
+    return ()