From: Bas van Dijk <v.dijk.bas@gmail.com>
Date: Mon, 29 Mar 2010 13:15:49 +0000 (+0000)
Subject: runInUnboundThread: block asynchronous exceptions before installing exception handler
X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=5a888827c14dcbf279c986531cf8a6e8ee19eef1;p=ghc-base.git

runInUnboundThread: block asynchronous exceptions before installing exception handler
---

diff --git a/Control/Concurrent.hs b/Control/Concurrent.hs
index 75ee52e..ce668fb 100644
--- a/Control/Concurrent.hs
+++ b/Control/Concurrent.hs
@@ -430,7 +430,10 @@ runInUnboundThread action = do
     if bound
         then do
             mv <- newEmptyMVar
-            _ <- forkIO (Exception.try action >>= putMVar mv)
+            b <- blocked
+            _ <- block $ forkIO $
+              Exception.try (if b then action else unblock action) >>=
+              putMVar mv
             takeMVar mv >>= \ei -> case ei of
                 Left exception -> Exception.throw (exception :: SomeException)
                 Right result -> return result