Fix interaction between fork and kqueue (#24672)

A kqueue file descriptor isn't inherited by a child created with fork.
As such we mustn't try to close this file descriptor as we would close a
random one, e.g. the one used by timerfd.

Fix #24672

(cherry picked from commit e7a26d7a)

libraries/ghc-internal/src/GHC/Internal/Event/KQueue.hsc

@@ -44,8 +44,8 @@ import GHC.Internal.Num (Num(..))
 import GHC.Internal.Real (quotRem, fromIntegral)
 import GHC.Internal.Show (Show(show))
 import GHC.Internal.Event.Internal (Timeout(..))
-import GHC.Internal.System.Posix.Internals (c_close)
-import GHC.Internal.System.Posix.Types (Fd(..))
+import GHC.Internal.System.Posix.Internals (c_close,c_getpid)
+import GHC.Internal.System.Posix.Types (Fd(..), CPid)
 import qualified GHC.Internal.Event.Array as A
 
 #if defined(netbsd_HOST_OS)
@@ -73,19 +73,26 @@ available = True
 data KQueue = KQueue {
       kqueueFd     :: {-# UNPACK #-} !KQueueFd
     , kqueueEvents :: {-# UNPACK #-} !(A.Array Event)
+    , kqueuePid    :: {-# UNPACK #-} !CPid -- ^ pid, used to detect forks
     }
 
 new :: IO E.Backend
 new = do
   kqfd <- kqueue
   events <- A.new 64
-  let !be = E.backend poll modifyFd modifyFdOnce delete (KQueue kqfd events)
+  pid <- c_getpid
+  let !be = E.backend poll modifyFd modifyFdOnce delete (KQueue kqfd events pid)
   return be
 
 delete :: KQueue -> IO ()
 delete kq = do
-  _ <- c_close . fromKQueueFd . kqueueFd $ kq
-  return ()
+  -- detect forks: the queue isn't inherited by a child process created with
+  -- fork. Hence we mustn't try to close the old fd or we might close a random
+  -- one (e.g. the one used by timerfd, cf #24672).
+  pid <- c_getpid
+  when (pid == kqueuePid kq) $ do
+    _ <- c_close . fromKQueueFd . kqueueFd $ kq
+    return ()
 
 modifyFd :: KQueue -> Fd -> E.Event -> E.Event -> IO Bool
 modifyFd kq fd oevt nevt = do

testsuite/tests/lib/base/T24672.hs

+module Main where
+
+import Control.Concurrent
+import qualified System.Posix.Process as SPP
+import System.IO
+
+main = do
+  print "before SPP.forkProcess"
+  hFlush stdout
+  threadDelay (2*1000*1000)
+  SPP.forkProcess $ pure ()
+  threadDelay (2*1000*1000)
+  print "after SPP.forkProcess"

testsuite/tests/lib/base/T24672.stdout

+"before SPP.forkProcess"
+"after SPP.forkProcess"

testsuite/tests/lib/base/all.T

@@ -2,6 +2,7 @@ test('DataTypeOrd', normal, compile_and_run, [''])
 test('T16586', normal, compile_and_run, ['-O2'])
 # Event-manager not supported on Windows
 test('T16916', [when(opsys('mingw32'), skip), js_broken(22261), fragile(16966), req_ghc_with_threaded_rts], compile_and_run, ['-O2 -threaded -with-rtsopts="-I0" -rtsopts'])
+test('T24672', [when(opsys('mingw32'), skip), js_broken(22261),req_process], compile_and_run, [''])
 test('T17310', normal, compile, [''])
 test('T19691', normal, compile, [''])
 test('executablePath', [extra_run_opts(config.os), js_broken(22261), when(arch('wasm32'), fragile(23248)), omit_ghci], compile_and_run, [''])