GitLab

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

Commits:

7df3ba2f

by Andrea Vezzosi at 2026-10-14T06:15:48-04:00

add runGhcWithSignalHandlers and remove handling from runGhc[T]

it only ever makes sense to call `withSignalHandlers` from `main`, otherwise
signals can be too easily swallowed without notification to the rest of your
process.

This commit takes withSignalHandlers out of `runGhc/runGhcT` and provides
`runGhcWithSignalHandlers` for the old behaviour.

14 changed files:

+ changelog.d/T4162
compiler/GHC.hs
compiler/GHC/Utils/Panic.hs
ghc/Main.hs
linters/lint-codes/LintCodes/Static.hs
+ testsuite/tests/ghc-api/T4162.hs
+ testsuite/tests/ghc-api/T4162.stdout
testsuite/tests/ghc-api/all.T
utils/check-exact/Parsers.hs
utils/check-ppr/Main.hs
utils/count-deps/Main.hs
utils/dump-decls/Main.hs
utils/haddock/haddock-api/src/Haddock.hs
utils/haddock/haddock-api/test/Haddock/Backends/Hyperlinker/ParserSpec.hs

Changes:

changelog.d/T4162

 +section: compiler
 +issues: #4162
 +mrs: !16774
 +synopsis:
 +  `runGhc/runGhcT` no longer hijack process signals, old behaviour provided by
 +  `runGhcWithSignalHandlers`.
 +description:
 +  Functions `runGhc/runGhcT` no longer go out of their way to redirect process
 +  signals as exceptions to them.
++
 +  The installed handlers make it so other threads are unaware of any signals,
 +  which can cause the process to become unresponsive whenever a crash of the GHC
 +  session(s) does not cascade into a shutdown of the process itself.
++
 +  The old behaviour is available through `runGhcWithSignalHandlers` or by
 +  calling `withSignalHandlers`. Only intended to be used from the main thread of
 +  your process, see the documentation.

compiler/GHC.hs

@@ -23,6 +23,7 @@ module GHC (
          -- * GHC Monad
          Ghc, GhcT, GhcMonad(..), HscEnv,
          runGhc, runGhcT, initGhcMonad,
 +        runGhcWithSignalHandlers,
          printException,
          handleSourceError,
@@ -555,10 +556,26 @@ runGhc :: Maybe FilePath  -- ^ See argument to 'initGhcMonad'.
  runGhc mb_top_dir ghc = do
    ref <- newIORef (panic "empty session")
    let session = Session ref
 -  flip unGhc session $ withSignalHandlers $ do -- catch ^C
 +  flip unGhc session $ do
      initGhcMonad mb_top_dir
      withCleanupSession ghc
 +-- | Like 'runGhc' but uses 'withSignalHandlers' to redirect selected signals to
 +-- this thread to trigger 'withCleanupSession', and so that interactive
 +-- evaluation receives 'UserInterrupt' exceptions.
 +--
 +-- __WARNING__: Only intended to be called from the __main thread__ of your
 +-- process, see 'withSignalHandlers' documentation for more details.
 +--
 +-- More complex multi-threaded programs are recommended to use 'runGhc' or
 +-- 'runGhcT', and handle signals as appropriate for their control flow.
++
 +runGhcWithSignalHandlers :: Maybe FilePath  -- ^ See argument to 'initGhcMonad'.
 +                         -> Ghc a           -- ^ The action to perform.
 +                         -> IO a
 +runGhcWithSignalHandlers mb_top_dir ghc = runGhc mb_top_dir $
 +  withSignalHandlers $ ghc
++
  -- | Run function for 'GhcT' monad transformer.
  --
  -- It initialises the GHC session and warnings via 'initGhcMonad'.  Each call
@@ -572,7 +589,7 @@ runGhcT :: ExceptionMonad m =>
  runGhcT mb_top_dir ghct = do
    ref <- liftIO $ newIORef (panic "empty session")
    let session = Session ref
 -  flip unGhcT session $ withSignalHandlers $ do -- catch ^C
 +  flip unGhcT session $ do
      initGhcMonad mb_top_dir
      withCleanupSession ghct

compiler/GHC/Utils/Panic.hs

@@ -234,8 +234,21 @@ signalHandlersRefCount :: MVar (Word, Maybe S.Handler)
  signalHandlersRefCount = unsafePerformIO $ newMVar (0,Nothing)
 --- | Temporarily install standard signal handlers for catching ^C, which just
 --- throw an exception in the current thread.
 +-- | Temporarily install signal handlers to redirect the following signals to
 +-- the calling thread as async exceptions: @INT@, @QUIT@, @HUP@, @TERM@ on unix, and
 +-- @CtrlC@, @Break@ on windows. The original signal handlers are restored when all
 +-- concurrent calls of this function are exited.
 +--
 +-- @INT@, @QUIT@, @CtrlC@, and @Break@ are thrown as @'UserInterrupt'@.
 +--
 +-- @HUP@, and @TERM@ are thrown as @'Panic' <signal number>@.
 +--
 +-- __WARNING__: Only intended to be called from the __main thread__ of your
 +-- process, as otherwise it can swallow signals the process should react to in
 +-- other ways. Nested calls from a single thread are fine, but concurrent calls
 +-- from different threads will have the exceptions delivered to only one of
 +-- them. If that thread is not @main@, extra care is needed to e.g. actually
 +-- terminate the process when it receives @TERM@.
  withSignalHandlers :: ExceptionMonad m => m a -> m a
  #if !defined(HAVE_SIGNAL_H)
  -- No signal functionality exist on the host platform (e.g. on

ghc/Main.hs

@@ -141,7 +141,7 @@ main = do
                     ShowOptions isInteractive -> showOptions isInteractive
          Right postStartupMode ->
              -- start our GHC session
 -            GHC.runGhc mbMinusB $ do
 +            GHC.runGhcWithSignalHandlers mbMinusB $ do
              dflags <- GHC.getSessionDynFlags

linters/lint-codes/LintCodes/Static.hs

@@ -31,7 +31,7 @@ import GHC.Types.Error.Codes
  -- ghc (API usage)
  import GHC
 -  ( runGhc, parseDynamicFlags
 +  ( runGhcWithSignalHandlers, parseDynamicFlags
    , getSessionDynFlags, setSessionDynFlags
    , getSession, getLogger
    , noLoc
@@ -145,7 +145,7 @@ newtype LibDir = LibDir { libDir :: FilePath }
  -- | Look up the 'GhcDiagnosticCode' type family using the GHC API.
  ghcDiagnosticCodeTyCon :: Maybe LibDir -> IO TyCon
  ghcDiagnosticCodeTyCon mb_libDir =
 -  runGhc (libDir <$> mb_libDir)
 +  runGhcWithSignalHandlers (libDir <$> mb_libDir)
    -- STEP 1: start a GHC API session with "-package ghc"
    do { dflags1 <- getSessionDynFlags

testsuite/tests/ghc-api/T4162.hs

 +{-# LANGUAGE CPP #-}
 +{-# LANGUAGE LambdaCase #-}
++
 +-- | Test for #4162: 'runGhc' must not install signal handlers on behalf of its
 +-- caller.
 +--
 +-- 'withSignalHandlers' redirects signals to the thread that called it. While
 +-- 'runGhc' did that implicitly, a GHC session running in a 'forkIO' thread
 +-- would capture signals aimed at the process as a whole and deliver them to a
 +-- thread that may not be in a position to act on them. Here that thread sits
 +-- under 'uninterruptibleMask', so the exception can never be delivered and the
 +-- signal is swallowed outright.
 +--
 +-- The worker process parks a 'forkIO' thread inside 'runGhc' under
 +-- 'uninterruptibleMask' and blocks its main thread waiting for that thread to
 +-- finish. The driver process waits for the worker to report that the thread is
 +-- inside 'runGhc', signals it, and checks that it dies promptly:
 +--
 +--   * on unix, SIGTERM has no handler, so the kernel kills the process;
 +--   * on Windows, CTRL_BREAK is handled by GHC.TopHandler, which throws
 +--     UserInterrupt at the main thread, which exits with 252.
 +--
 +-- Before #4162 both were swallowed by the masked 'forkIO' thread and the worker
 +-- carried on running.
 +module Main (main) where
++
 +import Control.Concurrent
 +import Control.Exception
 +import Control.Monad
 +import Control.Monad.IO.Class (liftIO)
 +import GHC (runGhc)
 +import System.Environment
 +import System.Exit
 +import System.IO
 +import System.Process
 +import System.Timeout (timeout)
++
 +#if !defined(mingw32_HOST_OS)
 +import System.Posix.Signals (sigKILL, sigTERM, signalProcess)
 +#endif
++
 +main :: IO ()
 +main = getArgs >>= \case
 +  [libdir]             -> driver libdir
 +  [libdir, "--worker"] -> worker libdir
 +  args                 -> die ("FAILED: unexpected arguments: " ++ show args)
++
 +-- | The process under test: a GHC session pinned in a 'forkIO' thread, with the
 +-- main thread waiting on it.
 +worker :: FilePath -> IO ()
 +worker libdir = do
 +  hSetBuffering stdout LineBuffering
 +  done <- newEmptyMVar
 +  _ <- forkIO $
 +         flip finally (putMVar done ()) $
 +           uninterruptibleMask_ $
 +             runGhc (Just libdir) $ liftIO $ do
 +               putStrLn ready
 +               forever (threadDelay oneSecond)
 +  takeMVar done
 +  -- Only reachable if the session thread died on its own; the signal was
 +  -- supposed to take the whole process down first.
 +  putStrLn "worker: session thread finished"
++
 +-- | Wait for the worker to reach 'runGhc', signal it, and require a prompt exit.
 +driver :: FilePath -> IO ()
 +driver libdir = do
 +  self <- getExecutablePath
 +  let cp = (proc self [libdir, "--worker"])
 +             { std_out = CreatePipe
 +#if defined(mingw32_HOST_OS)
 +             -- GenerateConsoleCtrlEvent can only target a process group, so the
 +             -- worker needs one of its own.
 +             , create_group = True
 +#endif
 +             }
 +  bracket (createProcess cp) kill $ \(_, Just out, _, ph) -> do
 +    handshake <- timeout handshakeTimeout
 +                   (try (hGetLine out) :: IO (Either IOException String))
 +    case handshake of
 +      Just (Right l) | l == ready -> return ()
 +      _ -> die ("FAILED: worker never reached runGhc: " ++ show handshake)
 +    interruptWorker ph
 +    waitForExit ph >>= \case
 +      Just code | code == expectedExit -> putStrLn "worker terminated promptly"
 +      other -> die ("FAILED: expected " ++ show expectedExit
 +                     ++ " from the worker, got " ++ show other)
++
 +-- | Deliver the signal that the worker must not be able to swallow.
 +interruptWorker :: ProcessHandle -> IO ()
 +#if defined(mingw32_HOST_OS)
 +-- CTRL_BREAK_EVENT rather than CTRL_C_EVENT: GenerateConsoleCtrlEvent cannot
 +-- deliver CTRL+C to a specific process group. Both reach the same handler, in
 +-- GHC.TopHandler now and in withSignalHandlers before #4162.
 +interruptWorker = interruptProcessGroupOf
 +#else
 +interruptWorker ph = getPid ph >>= \case
 +  Just pid -> signalProcess sigTERM pid
 +  Nothing  -> die "FAILED: worker exited before it could be signalled"
 +#endif
++
 +-- | How the worker is expected to die once signalled.
 +expectedExit :: ExitCode
 +#if defined(mingw32_HOST_OS)
 +-- UserInterrupt reaches the top handler, which calls exitInterrupted.
 +expectedExit = ExitFailure 252
 +#else
 +expectedExit = ExitFailure (negate (fromIntegral sigTERM))
 +#endif
++
 +-- | Poll for the worker's exit, giving up after 'terminationTimeout'. Polling
 +-- rather than 'waitForProcess' so that a worker that ignored the signal fails
 +-- the test quickly instead of hanging it until the testsuite timeout.
 +waitForExit :: ProcessHandle -> IO (Maybe ExitCode)
 +waitForExit ph = go (terminationTimeout `div` pollInterval)
 +  where
 +    go :: Int -> IO (Maybe ExitCode)
 +    go n
 +      | n <= 0 = return Nothing
 +      | otherwise = getProcessExitCode ph >>= \case
 +          Just code -> return (Just code)
 +          Nothing   -> threadDelay pollInterval >> go (n - 1)
++
 +-- | Keep a worker that ignored the signal from outliving the test and holding
 +-- the inherited stderr open. Note that 'terminateProcess' is only SIGTERM on
 +-- unix, which is precisely what such a worker swallows.
 +kill :: (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) -> IO ()
 +kill (_, _, _, ph) = do
 +#if defined(mingw32_HOST_OS)
 +  terminateProcess ph
 +#else
 +  getPid ph >>= mapM_ (signalProcess sigKILL)
 +#endif
 +  void (waitForProcess ph)
++
 +-- | Printed by the worker from inside 'runGhc', so that by the time the driver
 +-- sees it any handlers 'runGhc' might install are already in place.
 +ready :: String
 +ready = "ready"
++
 +oneSecond, pollInterval, handshakeTimeout, terminationTimeout :: Int
 +oneSecond          = 1000000
 +pollInterval       = 100000            -- 0.1s
 +handshakeTimeout   = 60 * oneSecond    -- starting a GHC session can be slow
 +terminationTimeout = 10 * oneSecond

testsuite/tests/ghc-api/T4162.stdout

+worker terminated promptly

testsuite/tests/ghc-api/all.T

@@ -91,3 +91,13 @@ test('T27240', [extra_run_opts(f'"{config.libdir}"')], compile_and_run, ['-packa
  test('T27273', [extra_run_opts(f'"{config.libdir}"')],
                 compile_and_run,
                 ['-package ghc'])
++
 +# runGhc must not install signal handlers on behalf of its caller, or a session
 +# running off the main thread makes the process unresponsive to signals.
 +test('T4162', [ extra_run_opts(f'"{config.libdir}"')
 +              # the test re-executes itself, so it has to be a real executable
 +              , only_ways(['normal'])
 +              , req_process
 +              # no subprocesses or signals
 +              , when(arch('wasm32') or arch('javascript'), skip)
 +              ], compile_and_run, ['-package ghc'])

utils/check-exact/Parsers.hs

@@ -231,7 +231,7 @@ parseModuleEpAnnsWithCpp libdir cppOptions file = ghcWrapper libdir $ do
  ghcWrapper :: LibDir -> GHC.Ghc a -> IO a
  ghcWrapper libdir a =
    GHC.defaultErrorHandler GHC.defaultFatalMessager GHC.defaultFlushOut
 -    $ GHC.runGhc (Just libdir) a
 +    $ GHC.runGhcWithSignalHandlers (Just libdir) a
  -- | Internal function. Exposed if you want to muck with DynFlags
  -- before parsing.

utils/check-ppr/Main.hs

@@ -81,7 +81,7 @@ testOneFile libdir fileName = do
  parseOneFile :: FilePath -> FilePath -> IO ParsedModule
  parseOneFile libdir fileName = do
 -       runGhc (Just libdir) $ do
 +       runGhcWithSignalHandlers (Just libdir) $ do
           dflags <- getSessionDynFlags
           let dflags2 = dflags `gopt_set` Opt_KeepRawTokenStream
           _ <- setSessionDynFlags dflags2

utils/count-deps/Main.hs

@@ -51,7 +51,7 @@ printDeps libdir modName dot = do
  calcDeps :: String -> FilePath -> IO (Map.Map ModuleName [ModuleName])
  calcDeps modName libdir =
    defaultErrorHandler defaultFatalMessager defaultFlushOut $ do
 -    runGhc (Just libdir) $ do
 +    runGhcWithSignalHandlers (Just libdir) $ do
          df <- getSessionDynFlags
          logger <- getLogger
          (df, _, _) <- parseDynamicFlags logger df [noLoc "-package=ghc"]

utils/dump-decls/Main.hs

@@ -32,7 +32,7 @@ main = do
      mapM_ (run ghcRoot) pkg_names
  run :: FilePath -> String -> IO ()
 -run root pkg_nm = runGhc (Just root) $ do
 +run root pkg_nm = runGhcWithSignalHandlers (Just root) $ do
      let args = map noLoc
              [ "-package=" ++ pkg_nm
              , "-dppr-cols=1000"

utils/haddock/haddock-api/src/Haddock.hs

@@ -196,7 +196,7 @@ handleGhcExceptions =
  --
  -- > main = getArgs >>= haddock
  haddock :: [String] -> IO ()
 -haddock args = haddockWithGhc withGhc args
 +haddock args = withSignalHandlers $ haddockWithGhc withGhc args
  haddockWithGhc :: (forall a. [Flag] -> Ghc a -> IO a) -> [String] -> IO ()
  haddockWithGhc ghc args = handleTopExceptions $ do

utils/haddock/haddock-api/test/Haddock/Backends/Hyperlinker/ParserSpec.hs

@@ -20,7 +20,7 @@ import Haddock.Backends.Hyperlinker.Types
  withDynFlags :: (DynFlags -> IO ()) -> IO ()
  withDynFlags cont = do
    libDir <- fmap snd (getGhcDirs [])
 -  runGhc libDir $ do
 +  runGhcWithSignalHandlers libDir $ do
      dflags <- getSessionDynFlags
      liftIO $ cont dflags