closeFdWith invokes callbacks only after the fd is closed.

Move callback invocation to after close. close must be run after the all backends are updated. Therefore the sequence is to update the backends, in the process getting the callbacks to invoke (actually just getting an IO action which when executed will execute the callbacks), call close, and finally update the Managers' callback tables for the fd and execute the callbacks.

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