Our problem here was that if a thread blocked in threadWait or
threadDelay and was killed by an exception thrown from another thread,
its registration with the IO manager would not be cleared.
The fix is simply to install exception handlers that do the cleanup and
propagate the exception.
+import Control.Exception (SomeException, catch, throw)
import Data.IORef (IORef, newIORef, readIORef, writeIORef)
import Data.Maybe (Maybe(..))
import Foreign.C.Error (eBADF, errnoToIOError)
import Data.IORef (IORef, newIORef, readIORef, writeIORef)
import Data.Maybe (Maybe(..))
import Foreign.C.Error (eBADF, errnoToIOError)
threadDelay usecs = do
Just mgr <- readIORef eventManager
m <- newEmptyMVar
threadDelay usecs = do
Just mgr <- readIORef eventManager
m <- newEmptyMVar
- _ <- registerTimeout mgr usecs (putMVar m ())
- takeMVar m
+ reg <- registerTimeout mgr usecs (putMVar m ())
+ takeMVar m `catch` \(e::SomeException) ->
+ M.unregisterTimeout mgr reg >> throw e
-- | Set the value of returned TVar to True after a given number of
-- microseconds. The caveats associated with threadDelay also apply.
-- | Set the value of returned TVar to True after a given number of
-- microseconds. The caveats associated with threadDelay also apply.
threadWait evt fd = do
m <- newEmptyMVar
Just mgr <- readIORef eventManager
threadWait evt fd = do
m <- newEmptyMVar
Just mgr <- readIORef eventManager
- _ <- registerFd mgr (\reg e -> unregisterFd_ mgr reg >> putMVar m e) fd evt
- evt' <- takeMVar m
+ reg <- registerFd mgr (\reg e -> unregisterFd_ mgr reg >> putMVar m e) fd evt
+ evt' <- takeMVar m `catch` \(e::SomeException) ->
+ unregisterFd_ mgr reg >> throw e
if evt' `eventIs` evtClose
then ioError $ errnoToIOError "threadWait" eBADF Nothing Nothing
else return ()
if evt' `eventIs` evtClose
then ioError $ errnoToIOError "threadWait" eBADF Nothing Nothing
else return ()