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 ===================================== @@ -0,0 +1,17 @@ +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 ===================================== @@ -0,0 +1,145 @@ +{-# 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 ===================================== @@ -0,0 +1 @@ +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 View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/7df3ba2fc251cd8f35ee9dfd8dbddec3... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/7df3ba2fc251cd8f35ee9dfd8dbddec3... You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help