diff options
| -rw-r--r-- | libraries/base/GHC/Event/Manager.hs | 15 | ||||
| -rw-r--r-- | libraries/base/GHC/Event/Thread.hs | 17 |
2 files changed, 19 insertions, 13 deletions
diff --git a/libraries/base/GHC/Event/Manager.hs b/libraries/base/GHC/Event/Manager.hs index 32dfc6d4b0..1f956a16c3 100644 --- a/libraries/base/GHC/Event/Manager.hs +++ b/libraries/base/GHC/Event/Manager.hs @@ -362,18 +362,23 @@ closeFd mgr close fd = do -- | Close a file descriptor in a race-safe way. -- It assumes the caller will update the callback tables and that the caller --- holds the callback table lock for the fd. -closeFd_ :: EventManager -> IM.IntMap [FdData] -> Fd -> IO (IM.IntMap [FdData]) +-- holds the callback table lock for the fd. It must hold this lock because +-- this command executes a backend command on the fd. +closeFd_ :: EventManager + -> IM.IntMap [FdData] + -> Fd + -> IO (IM.IntMap [FdData], IO ()) closeFd_ mgr oldMap fd = do case IM.delete (fromIntegral fd) oldMap of - (Nothing, _) -> return oldMap + (Nothing, _) -> return (oldMap, return ()) (Just fds, !newMap) -> do let oldEvs = eventsOf fds when (oldEvs /= mempty) $ do I.modifyFd (emBackend mgr) fd oldEvs mempty wakeManager mgr - forM_ fds $ \(FdData reg ev cb) -> cb reg (ev `mappend` evtClose) - return newMap + let runCbs = + forM_ fds $ \(FdData reg ev cb) -> cb reg (ev `mappend` evtClose) + return (newMap, runCbs) ------------------------------------------------------------------------ -- Utilities diff --git a/libraries/base/GHC/Event/Thread.hs b/libraries/base/GHC/Event/Thread.hs index 578e591d20..b0d55a636b 100644 --- a/libraries/base/GHC/Event/Thread.hs +++ b/libraries/base/GHC/Event/Thread.hs @@ -100,15 +100,16 @@ closeFdWith close fd = do return mgr mask_ $ do tables <- forM mgrs $ \mgr -> takeMVar $ M.callbackTableVar mgr fd - tables' <- zipWithM - (\mgr table -> M.closeFd_ mgr table fd) - mgrs - tables + tableAndCbApps <- zipWithM + (\mgr table -> M.closeFd_ mgr table fd) + mgrs + tables close fd - zipWithM_ - (\mgr table' -> putMVar (M.callbackTableVar mgr fd) table') - mgrs - tables' + zipWithM_ finish mgrs tableAndCbApps + where + finish mgr (table', cbApp) = do + putMVar (M.callbackTableVar mgr fd) table' + cbApp threadWait :: Event -> Fd -> IO () threadWait evt fd = mask_ $ do |