[commit: ghc] master: Fix dropped event registrations (1c38325)

[git at git.haskell.org]

Repository : ssh://git@git.haskell.org/ghc

On branch  : master
Link       : http://ghc.haskell.org/trac/ghc/changeset/1c3832597b3e75456fc61628c4cd289d211c733b/ghc

>---------------------------------------------------------------

commit 1c3832597b3e75456fc61628c4cd289d211c733b
Author: Ben Gamari <ben at smart-cactus.org>
Date:   Mon Jun 1 02:27:30 2015 -0500

    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


>---------------------------------------------------------------

1c3832597b3e75456fc61628c4cd289d211c733b
 libraries/base/GHC/Event/Internal.hs |  7 +++++--
 libraries/base/GHC/Event/Manager.hs  | 40 +++++++++++++++++++++++++-----------
 2 files changed, 33 insertions(+), 14 deletions(-)

diff --git a/libraries/base/GHC/Event/Internal.hs b/libraries/base/GHC/Event/Internal.hs
index 3b75c8b..a093352 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 11b01ad..b674866 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