X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=Control%2FConcurrent.hs;h=79b8352f5002174e12372de73dcf2f8c23fc72c4;hb=7a1ac0c9d1cb81043b3e8f45c7451ad34336ddc5;hp=bd05cdc081b529d52ab6191881c15457d9774e88;hpb=015f7b630e7c970b0cf311d06d9472e4dfa417b6;p=ghc-base.git

diff --git a/Control/Concurrent.hs b/Control/Concurrent.hs
index bd05cdc..79b8352 100644
--- a/Control/Concurrent.hs
+++ b/Control/Concurrent.hs
@@ -422,18 +422,24 @@ performance loss due to the use of bound threads. A program that
 doesn't need it's main thread to be bound and makes /heavy/ use of concurrency
 (e.g. a web server), might want to wrap it's @main@ action in
 @runInUnboundThread@.
+
+Note that exceptions which are thrown to the current thread are thrown in turn
+to the thread that is executing the given computation. This ensures there's
+always a way of killing the forked thread.
 -}
 runInUnboundThread :: IO a -> IO a
 
 runInUnboundThread action = do
-    bound <- isCurrentThreadBound
-    if bound
-        then do
-            mv <- newEmptyMVar
-            _ <- mask $ \restore -> forkIO $
-              Exception.try (restore action) >>= putMVar mv
-            takeMVar mv >>= unsafeResult
-        else action
+  bound <- isCurrentThreadBound
+  if bound
+    then do
+      mv <- newEmptyMVar
+      mask $ \restore -> do
+        tid <- forkIO $ Exception.try (restore action) >>= putMVar mv
+        let wait = takeMVar mv `Exception.catch` \(e :: SomeException) ->
+                     Exception.throwTo tid e >> wait
+        wait >>= unsafeResult
+    else action
 
 unsafeResult :: Either SomeException a -> IO a
 unsafeResult = either Exception.throwIO return