[Git][ghc/ghc][master] Fix interaction between fork and kqueue (#24672)

[Marge Bot (@marge-bot)]

Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC


Commits:
e7a26d7a by Sylvain Henry at 2024-09-25T17:11:00-04:00
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

- - - - -


4 changed files:

- libraries/ghc-internal/src/GHC/Internal/Event/KQueue.hsc
- + testsuite/tests/lib/base/T24672.hs
- + testsuite/tests/lib/base/T24672.stdout
- testsuite/tests/lib/base/all.T


Changes:

=====================================
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
=====================================
@@ -0,0 +1,13 @@
+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
=====================================
@@ -0,0 +1,2 @@
+"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, [''])



View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/e7a26d7a6faf1ea534e036c5085a0a027dbb6f5f

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/e7a26d7a6faf1ea534e036c5085a0a027dbb6f5f
You're receiving this email because of your account on gitlab.haskell.org.


-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20240925/4f031470/attachment-0001.html>