Do not ignore events deletion when events to be added are provided (#16916)

Kqueue/kevent implementation used to ignore events to be unsubscribed
from when events to be subscribed to were provided. This resulted in a
lost notification subscription, when GHC runtime didn't listen for any
events, yet the kernel considered otherwise and kept waking up the IO
manager thread.

This commit fixes this issue by always adding and removing all of the
provided subscriptions.

4 files changed, 51 insertions, 4 deletions

diff --git a/libraries/base/GHC/Event/KQueue.hsc b/libraries/base/GHC/Event/KQueue.hsc
index 49cf82db14..05bdd63bae 100644
--- a/libraries/base/GHC/Event/KQueue.hsc
+++ b/libraries/base/GHC/Event/KQueue.hsc
@@ -87,11 +87,11 @@ delete kq = do
   return ()
 
 modifyFd :: KQueue -> Fd -> E.Event -> E.Event -> IO Bool
-modifyFd kq fd oevt nevt = kqueueControl (kqueueFd kq) evs
+modifyFd kq fd oevt nevt = do
+  kqueueControl (kqueueFd kq) evs
   where
-    evs
-      | nevt == mempty = toEvents fd (toFilter oevt) flagDelete noteEOF
-      | otherwise      = toEvents fd (toFilter nevt) flagAdd noteEOF
+    evs = toEvents fd (toFilter oevt) flagDelete noteEOF
+       <> toEvents fd (toFilter nevt) flagAdd noteEOF
 
 toFilter :: E.Event -> [Filter]
 toFilter e = catMaybes [ check E.evtRead filterRead, check E.evtWrite filterWrite ]
diff --git a/testsuite/tests/lib/base/T16916.hs b/testsuite/tests/lib/base/T16916.hs
new file mode 100644
index 0000000000..a5dafa515b
--- /dev/null
+++ b/testsuite/tests/lib/base/T16916.hs
@@ -0,0 +1,45 @@
+module Main where
+
+import Control.Concurrent
+import Foreign.C
+import GHC.Event
+import System.CPUTime
+import System.Posix.Types
+
+foreign import ccall unsafe "socket" c_socket ::
+               CInt -> CInt -> CInt -> IO CInt
+
+makeTestSocketFd :: IO Fd
+makeTestSocketFd = do
+    sockNum <-
+        c_socket
+            1 -- PF_LOCAL
+            2 -- SOCK_DGRAM
+            0
+    return $ (fromIntegral sockNum :: Fd)
+
+callback :: FdKey -> Event -> IO ()
+callback _ _ = return ()
+
+idleCpuUsage :: IO Integer
+idleCpuUsage = do
+  startCPUTime <- getCPUTime
+  threadDelay 500000
+  endCPUTime <- getCPUTime
+  return $ endCPUTime - startCPUTime
+
+main :: IO ()
+main = do
+  (Just eventMgr) <- getSystemEventManager
+  fd <- makeTestSocketFd
+
+  noEventUsage <- idleCpuUsage
+
+  registerFd eventMgr callback fd evtRead OneShot
+  registerFd eventMgr callback fd evtWrite OneShot
+
+  eventTriggeredUsage <- idleCpuUsage
+
+  -- CPU consumption should roughly be the same when just idling vs
+  -- when idling after the event been triggered
+  print $ (fromIntegral eventTriggeredUsage / fromIntegral noEventUsage) < 2.0
diff --git a/testsuite/tests/lib/base/T16916.stdout b/testsuite/tests/lib/base/T16916.stdout
new file mode 100644
index 0000000000..0ca95142bb
--- /dev/null
+++ b/testsuite/tests/lib/base/T16916.stdout
@@ -0,0 +1 @@
+True
diff --git a/testsuite/tests/lib/base/all.T b/testsuite/tests/lib/base/all.T
index ff0c9f963f..8a97c0f907 100644
--- a/testsuite/tests/lib/base/all.T
+++ b/testsuite/tests/lib/base/all.T
@@ -1 +1,2 @@
 test('T16586', normal, compile_and_run, ['-O2'])
+test('T16916', normal, compile_and_run, ['-O2 -threaded'])