X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=Control%2FConcurrent.hs;h=514e2e9adf6b01f9faadf1804910b9260d0eeb8b;hb=41e8fba828acbae1751628af50849f5352b27873;hp=f509bc05f5c789c0a1c6ebfc70c2664a12fc01df;hpb=9a8f1fdce99283c725112fb1f5fba3632c7836dd;p=ghc-base.git

diff --git a/Control/Concurrent.hs b/Control/Concurrent.hs
index f509bc0..514e2e9 100644
--- a/Control/Concurrent.hs
+++ b/Control/Concurrent.hs
@@ -1,4 +1,11 @@
+{-# LANGUAGE CPP
+           , ForeignFunctionInterface
+           , MagicHash
+           , UnboxedTuples
+           , ScopedTypeVariables
+  #-}
 {-# OPTIONS_GHC -fno-warn-unused-imports #-}
+
 -----------------------------------------------------------------------------
 -- |
 -- Module      :  Control.Concurrent
@@ -422,20 +429,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
-            b <- blocked
-            _ <- mask $ \restore -> forkIO $
-              Exception.try (if b then action else 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
@@ -447,6 +458,11 @@ unsafeResult = either Exception.throwIO return
 
 -- | Block the current thread until data is available to read on the
 -- given file descriptor (GHC only).
+--
+-- This will throw an 'IOError' if the file descriptor was closed
+-- while this thread was blocked.  To safely close a file descriptor
+-- that has been used with 'threadWaitRead', use
+-- 'GHC.Conc.closeFdWith'.
 threadWaitRead :: Fd -> IO ()
 threadWaitRead fd
 #ifdef mingw32_HOST_OS
@@ -467,6 +483,11 @@ threadWaitRead fd
 
 -- | Block the current thread until data can be written to the
 -- given file descriptor (GHC only).
+--
+-- This will throw an 'IOError' if the file descriptor was closed
+-- while this thread was blocked.  To safely close a file descriptor
+-- that has been used with 'threadWaitWrite', use
+-- 'GHC.Conc.closeFdWith'.
 threadWaitWrite :: Fd -> IO ()
 threadWaitWrite fd
 #ifdef mingw32_HOST_OS
@@ -491,7 +512,7 @@ withThread io = do
 waitFd :: Fd -> CInt -> IO ()
 waitFd fd write = do
    throwErrnoIfMinus1_ "fdReady" $
-        fdReady (fromIntegral fd) write (fromIntegral iNFINITE) 0
+        fdReady (fromIntegral fd) write iNFINITE 0
 
 iNFINITE :: CInt
 iNFINITE = 0xFFFFFFFF -- urgh