X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=System%2FEvent%2FThread.hs;h=9c58a5a7fd01684dfa353463abb58e2268046bea;hb=efeb2b2c641ddac89566f5fbb1507d905ac79403;hp=66174cd3b109eab1fab7c4a27f0fe65d73279a39;hpb=71d2bbf7bca2d446fd6b0d2af97b6d1833314f7f;p=ghc-base.git

diff --git a/System/Event/Thread.hs b/System/Event/Thread.hs
index 66174cd..9c58a5a 100644
--- a/System/Event/Thread.hs
+++ b/System/Event/Thread.hs
@@ -5,12 +5,11 @@ module System.Event.Thread
       ensureIOManagerIsRunning
     , threadWaitRead
     , threadWaitWrite
-    , closeFd
+    , closeFdWith
     , threadDelay
     , registerDelay
     ) where
 
-import Control.Exception (SomeException, catch, throw)
 import Data.IORef (IORef, newIORef, readIORef, writeIORef)
 import Data.Maybe (Maybe(..))
 import Foreign.C.Error (eBADF, errnoToIOError)
@@ -19,9 +18,9 @@ import GHC.Base
 import GHC.Conc.Sync (TVar, ThreadId, ThreadStatus(..), atomically, forkIO,
                       labelThread, modifyMVar_, newTVar, sharedCAF,
                       threadStatus, writeTVar)
+import GHC.IO (mask_, onException)
 import GHC.IO.Exception (ioError)
 import GHC.MVar (MVar, newEmptyMVar, newMVar, putMVar, takeMVar)
-import GHC.Real (fromIntegral)
 import System.Event.Internal (eventIs, evtClose)
 import System.Event.Manager (Event, EventManager, evtRead, evtWrite, loop,
                              new, registerFd, unregisterFd_, registerTimeout)
@@ -36,12 +35,11 @@ import System.Posix.Types (Fd)
 -- when the delay has expired, but the thread will never continue to
 -- run /earlier/ than specified.
 threadDelay :: Int -> IO ()
-threadDelay usecs = do
+threadDelay usecs = mask_ $ do
   Just mgr <- readIORef eventManager
   m <- newEmptyMVar
   reg <- registerTimeout mgr usecs (putMVar m ())
-  takeMVar m `catch` \(e::SomeException) ->
-    M.unregisterTimeout mgr reg >> throw e
+  takeMVar m `onException` M.unregisterTimeout mgr reg
 
 -- | Set the value of returned TVar to True after a given number of
 -- microseconds. The caveats associated with threadDelay also apply.
@@ -57,7 +55,8 @@ registerDelay usecs = do
 -- given file descriptor.
 --
 -- This will throw an 'IOError' if the file descriptor was closed
--- while this thread is blocked.
+-- while this thread was blocked.  To safely close a file descriptor
+-- that has been used with 'threadWaitRead', use 'closeFdWith'.
 threadWaitRead :: Fd -> IO ()
 threadWaitRead = threadWait evtRead
 {-# INLINE threadWaitRead #-}
@@ -66,7 +65,8 @@ threadWaitRead = threadWait evtRead
 -- accept data to write.
 --
 -- This will throw an 'IOError' if the file descriptor was closed
--- while this thread is blocked.
+-- while this thread was blocked.  To safely close a file descriptor
+-- that has been used with 'threadWaitWrite', use 'closeFdWith'.
 threadWaitWrite :: Fd -> IO ()
 threadWaitWrite = threadWait evtWrite
 {-# INLINE threadWaitWrite #-}
@@ -76,20 +76,19 @@ threadWaitWrite = threadWait evtWrite
 -- Any threads that are blocked on the file descriptor via
 -- 'threadWaitRead' or 'threadWaitWrite' will be unblocked by having
 -- IO exceptions thrown.
-closeFd :: (Fd -> IO ())        -- ^ Action that performs the close.
-        -> Fd                   -- ^ File descriptor to close.
-        -> IO ()
-closeFd close fd = do
+closeFdWith :: (Fd -> IO ())        -- ^ Action that performs the close.
+            -> Fd                   -- ^ File descriptor to close.
+            -> IO ()
+closeFdWith close fd = do
   Just mgr <- readIORef eventManager
   M.closeFd mgr close fd
 
 threadWait :: Event -> Fd -> IO ()
-threadWait evt fd = do
+threadWait evt fd = mask_ $ do
   m <- newEmptyMVar
   Just mgr <- readIORef eventManager
   reg <- registerFd mgr (\reg e -> unregisterFd_ mgr reg >> putMVar m e) fd evt
-  evt' <- takeMVar m `catch` \(e::SomeException) ->
-            unregisterFd_ mgr reg >> throw e
+  evt' <- takeMVar m `onException` unregisterFd_ mgr reg
   if evt' `eventIs` evtClose
     then ioError $ errnoToIOError "threadWait" eBADF Nothing Nothing
     else return ()
@@ -128,7 +127,17 @@ ensureIOManagerIsRunning
       s <- threadStatus t
       case s of
         ThreadFinished -> create
-        ThreadDied     -> create
+        ThreadDied     -> do 
+          -- Sanity check: if the thread has died, there is a chance
+          -- that event manager is still alive. This could happend during
+          -- the fork, for example. In this case we should clean up
+          -- open pipes and everything else related to the event manager.
+          -- See #4449
+          mem <- readIORef eventManager
+          _ <- case mem of
+                 Nothing -> return ()
+                 Just em -> M.cleanup em
+          create
         _other         -> return st
 
 foreign import ccall unsafe "rtsSupportsBoundThreads" threaded :: Bool