make the test fail if the sleep doesn't get interrupted (#5471)
authorSimon Marlow <marlowsd@gmail.com>
Fri, 7 Oct 2011 13:56:46 +0000 (14:56 +0100)
committerSimon Marlow <marlowsd@gmail.com>
Mon, 10 Oct 2011 09:46:56 +0000 (10:46 +0100)
testsuite/tests/concurrent/should_run/foreignInterruptible.hs

index 06e96cd..ca59fbd 100644 (file)
@@ -20,10 +20,17 @@ main :: IO ()
 main = do
   newStablePtr stdout -- prevent stdout being finalized
   th <- newEmptyMVar
+
   tid <- forkIO $ do
      putStrLn "newThread started"
      (sleep 2 >> putStrLn "fail") `catch` (\ThreadKilled -> putStrLn "pass")
      putMVar th "child"
+
+  -- if the killThread below gets blocked for more than a second, then
+  -- this thread will kill the main thread and the test will fail.
+  main <- myThreadId
+  forkIO $ do threadDelay 1000000; throwTo main (ErrorCall "still waiting")
+
   yield
   threadDelay 500000
   killThread tid