Fix dropped event registrations

D347 introduced a bug wherein the event manager would drop registrations that
should be retained during processing. This occurs when an fd has multiple
registrations, not all of which fire, as well as the case of multi-shot
registrations.

I also do some general house-keeping, try to better document things, and fix a
bug which could result in unnecessary calls to `epoll_ctl`

Reviewed By: austin

Differential Revision: https://phabricator.haskell.org/D849

GHC Trac Issues: #10317

2 files changed, 33 insertions, 14 deletions

diff --git a/libraries/base/GHC/Event/Internal.hs b/libraries/base/GHC/Event/Internal.hs
index 3b75c8bb40..a093352ba9 100644
--- a/libraries/base/GHC/Event/Internal.hs
+++ b/libraries/base/GHC/Event/Internal.hs
@@ -83,10 +83,12 @@ evtConcat :: [Event] -> Event
 evtConcat = foldl' evtCombine evtNothing
 {-# INLINE evtConcat #-}
 
--- | The lifetime of a registration.
+-- | The lifetime of an event registration.
 --
 -- @since 4.8.1.0
-data Lifetime = OneShot | MultiShot
+data Lifetime = OneShot   -- ^ the registration will be active for only one
+                          -- event
+              | MultiShot -- ^ the registration will trigger multiple times
               deriving (Show, Eq)
 
 -- | The longer of two lifetimes.
@@ -95,6 +97,7 @@ elSupremum OneShot OneShot = OneShot
 elSupremum _       _       = MultiShot
 {-# INLINE elSupremum #-}
 
+-- | @mappend@ == @elSupremum@
 instance Monoid Lifetime where
     mempty = OneShot
     mappend = elSupremum
diff --git a/libraries/base/GHC/Event/Manager.hs b/libraries/base/GHC/Event/Manager.hs
index 11b01ade36..b674866ad8 100644
--- a/libraries/base/GHC/Event/Manager.hs
+++ b/libraries/base/GHC/Event/Manager.hs
@@ -456,20 +456,35 @@ onFdEvent mgr fd evs
 
   | otherwise = do
     fdds <- withMVar (callbackTableVar mgr fd) $ \tbl ->
-        IT.delete (fromIntegral fd) tbl >>= maybe (return []) selectCallbacks
+        IT.delete (fromIntegral fd) tbl >>= maybe (return []) (selectCallbacks tbl)
     forM_ fdds $ \(FdData reg _ cb) -> cb reg evs
   where
     -- | Here we look through the list of registrations for the fd of interest
-    -- and sort out which match the events that were triggered. We re-arm
-    -- the fd as appropriate and return this subset.
-    selectCallbacks :: [FdData] -> IO [FdData]
-    selectCallbacks fdds = do
-        let matches :: FdData -> Bool
+    -- and sort out which match the events that were triggered. We,
+    --
+    --   1. re-arm the fd as appropriate
+    --   2. reinsert registrations that weren't triggered and multishot
+    --      registrations
+    --   3. return a list containing the callbacks that should be invoked.
+    selectCallbacks :: IntTable [FdData] -> [FdData] -> IO [FdData]
+    selectCallbacks tbl fdds = do
+        let -- figure out which registrations have been triggered
+            matches :: FdData -> Bool
             matches fd' = evs `I.eventIs` I.elEvent (fdEvents fd')
-            (triggered, saved) = partition matches fdds
+            (triggered, notTriggered) = partition matches fdds
+
+            -- sort out which registrations we need to retain
+            isMultishot :: FdData -> Bool
+            isMultishot fd' = I.elLifetime (fdEvents fd') == MultiShot
+            saved = notTriggered ++ filter isMultishot triggered
+
             savedEls = eventsOf saved
             allEls = eventsOf fdds
 
+        -- Reinsert multishot registrations.
+        -- We deleted the table entry for this fd above so we there isn't a preexisting entry
+        _ <- IT.insertWith (\_ _ -> saved) (fromIntegral fd) saved tbl
+
         case I.elLifetime allEls of
           -- we previously armed the fd for multiple shots, no need to rearm
           MultiShot | allEls == savedEls ->
@@ -477,17 +492,18 @@ onFdEvent mgr fd evs
 
           -- either we previously registered for one shot or the
           -- events of interest have changed, we must re-arm
-          _ -> do
+          _ ->
             case I.elLifetime savedEls of
               OneShot | haveOneShot ->
-                -- if there are no saved events there is no need to re-arm
-                unless (OneShot == I.elLifetime (eventsOf triggered)
-                        && mempty == savedEls) $
+                -- if there are no saved events and we registered with one-shot
+                -- semantics then there is no need to re-arm
+                unless (OneShot == I.elLifetime allEls
+                        && mempty == I.elEvent savedEls) $ do
                   void $ I.modifyFdOnce (emBackend mgr) fd (I.elEvent savedEls)
               _ ->
+                -- we need to re-arm with multi-shot semantics
                 void $ I.modifyFd (emBackend mgr) fd
                                   (I.elEvent allEls) (I.elEvent savedEls)
-            return ()
 
         return triggered