Andrea Vezzosi pushed to branch wip/andrea/with-signal-handlers at Glasgow Haskell Compiler / GHC Commits: 63815bd0 by Andrea Vezzosi at 2026-10-09T09:34:25+02: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. - - - - - 11 changed files: - + changelog.d/T4162 - compiler/GHC.hs - compiler/GHC/Utils/Panic.hs - ghc/Main.hs - linters/lint-codes/LintCodes/Static.hs - 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 ===================================== 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/63815bd06f019a18a4b0d4073a7b8bf2... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/63815bd06f019a18a4b0d4073a7b8bf2... 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