fix this test to work propertly with -threaded
authorSimon Marlow <simonmar@microsoft.com>
Wed, 14 Jun 2006 14:42:56 +0000 (14:42 +0000)
committerSimon Marlow <simonmar@microsoft.com>
Wed, 14 Jun 2006 14:42:56 +0000 (14:42 +0000)
testsuite/tests/ghc-regress/concurrent/should_run/conc035.hs

index 46fb3dd..8605b28 100644 (file)
@@ -3,34 +3,40 @@ module Main where
 import Control.Concurrent
 import qualified Control.Exception as E
 
-trapHandler :: MVar Int -> IO ()
-trapHandler inVar =
-  (do { trapMsg <- takeMVar inVar
-      ; putStrLn ("Handler got: " ++ show trapMsg)
-      ; trapHandler inVar
-      }
+trapHandler :: MVar Int -> MVar () -> IO ()
+trapHandler inVar caughtVar =
+  (do E.block $ do
+          trapMsg <- takeMVar inVar
+          putStrLn ("Handler got: " ++ show trapMsg)
+      trapHandler inVar caughtVar
   )
   `E.catch`
-  (trapExc inVar)
+  (trapExc inVar caughtVar)
 
-trapExc :: MVar Int -> E.Exception -> IO ()
-trapExc inVar e =
-  do putStrLn ("Exception: " ++ show e)
-     ; trapHandler inVar
-     }
+trapExc :: MVar Int -> MVar () -> E.Exception -> IO ()
+trapExc inVar caughtVar e =
+  do putStrLn ("Exception: " ++ show e)
+     putMVar caughtVar ()
+     trapHandler inVar caughtVar
 
 main :: IO ()
-main =
-  do { inVar <- newEmptyMVar
-     ; tid <- forkIO (trapHandler inVar)
-     ; yield
-     ; putMVar inVar 1
-     ; threadDelay 1000
-     ; throwTo tid (E.ErrorCall "1st")
-     ; threadDelay 1000
-     ; putMVar inVar 2
-     ; threadDelay 1000
-     ; throwTo tid (E.ErrorCall "2nd")
-     ; threadDelay 1000
-     ; putStrLn "All done"
-     }
+main = do
+  inVar <- newEmptyMVar
+  caughtVar <- newEmptyMVar
+  tid <- forkIO (trapHandler inVar caughtVar)
+  yield
+  putMVar inVar 1
+  threadDelay 1000
+  throwTo tid (E.ErrorCall "1st")
+  takeMVar caughtVar
+  putMVar inVar 2
+  threadDelay 1000
+  throwTo tid (E.ErrorCall "2nd")
+       -- the second time around, exceptions will be blocked, because
+       -- the trapHandler is effectively "still in the handler" from the
+       -- first exception.  I'm not sure if this is by design or by
+       -- accident.  Anyway, the trapHandler will at some point block
+       -- in takeMVar, and thereby become interruptible, at which point
+       -- it will receive the second exception.
+  takeMVar caughtVar
+  putStrLn "All done"