Generalise the type of onException

[ghc-base.git] / Control / Concurrent.hs

diff --git a/Control/Concurrent.hs b/Control/Concurrent.hs
index aa40b81..6268311 100644 (file)
--- a/Control/Concurrent.hs
+++ b/Control/Concurrent.hs
@@ -95,6 +95,7 @@ import Prelude
 import Control.Exception as Exception
 
 #ifdef __GLASGOW_HASKELL__
+import GHC.Exception
 import GHC.Conc         ( ThreadId(..), myThreadId, killThread, yield,
                           threadDelay, forkIO, childHandler )
 import qualified GHC.Conc
@@ -342,10 +343,19 @@ foreign import ccall forkOS_createThread
 failNonThreaded = fail $ "RTS doesn't support multiple OS threads "
                        ++"(use ghc -threaded when linking)"
 
-forkOS action
+forkOS action0
     | rtsSupportsBoundThreads = do
         mv <- newEmptyMVar
-        let action_plus = Exception.catch action childHandler
+        b <- Exception.blocked
+        let
+            -- async exceptions are blocked in the child if they are blocked
+            -- in the parent, as for forkIO (see #1048). forkOS_createThread
+            -- creates a thread with exceptions blocked by default.
+            action1 | b = action0
+                    | otherwise = unblock action0
+
+            action_plus = Exception.catch action1 childHandler
+
         entry <- newStablePtr (myThreadId >>= putMVar mv >> action_plus)
         err <- forkOS_createThread entry
         when (err /= 0) $ fail "Cannot create OS thread."
@@ -387,7 +397,7 @@ runInBoundThread action
                             freeStablePtr
                             (\cEntry -> forkOS_entry_reimported cEntry >> readIORef ref)
                 case resultOrException of
-                    Left exception -> Exception.throw exception
+                    Left exception -> Exception.throw (exception :: SomeException)
                     Right result -> return result
     | otherwise = failNonThreaded
 
@@ -411,7 +421,7 @@ runInUnboundThread action = do
             mv <- newEmptyMVar
             forkIO (Exception.try action >>= putMVar mv)
             takeMVar mv >>= \either -> case either of
-                Left exception -> Exception.throw exception
+                Left exception -> Exception.throw (exception :: SomeException)
                 Right result -> return result
         else action