Commit 8a5960ad authored by Sylvain HENRY's avatar Sylvain HENRY Committed by Ben Gamari
Browse files

Uninstall signal handlers

GHC installs signal handlers in runGhc/runGhcT to handle ^C but it
never uninstalls them.
It can be an issue, especially when using GHC as a library.

Test Plan: validate

Reviewers: bgamari, erikd, austin, simonmar

Reviewed By: bgamari, simonmar

Subscribers: thomie

Differential Revision: https://phabricator.haskell.org/D2633

GHC Trac Issues: #4162
parent 623b8e44
......@@ -13,7 +13,7 @@ module GHC (
defaultErrorHandler,
defaultCleanupHandler,
prettyPrintGhcErrors,
installSignalHandlers,
withSignalHandlers,
withCleanupSession,
-- * GHC Monad
......@@ -438,13 +438,10 @@ 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 $ do
liftIO installSignalHandlers -- catch ^C
flip unGhc session $ withSignalHandlers $ do -- catch ^C
initGhcMonad mb_top_dir
withCleanupSession ghc
-- XXX: unregister interrupt handlers here?
-- | Run function for 'GhcT' monad transformer.
--
-- It initialises the GHC session and warnings via 'initGhcMonad'. Each call
......@@ -458,8 +455,7 @@ runGhcT :: ExceptionMonad m =>
runGhcT mb_top_dir ghct = do
ref <- liftIO $ newIORef (panic "empty session")
let session = Session ref
flip unGhcT session $ do
liftIO installSignalHandlers -- catch ^C
flip unGhcT session $ withSignalHandlers $ do -- catch ^C
initGhcMonad mb_top_dir
withCleanupSession ghct
......
......@@ -8,7 +8,7 @@ It's hard to put these functions anywhere else without causing
some unnecessary loops in the module dependency graph.
-}
{-# LANGUAGE CPP, ScopedTypeVariables #-}
{-# LANGUAGE CPP, ScopedTypeVariables, LambdaCase #-}
module Panic (
GhcException(..), showGhcException,
......@@ -23,7 +23,7 @@ module Panic (
Exception.Exception(..), showException, safeShowException,
try, tryMost, throwTo,
installSignalHandlers,
withSignalHandlers,
) where
#include "HsVersions.h"
......@@ -32,17 +32,18 @@ import {-# SOURCE #-} Outputable (SDoc, showSDocUnsafe)
import Config
import Exception
import Control.Monad.IO.Class
import Control.Concurrent
import Debug.Trace ( trace )
import System.IO.Unsafe
import System.Environment
#ifndef mingw32_HOST_OS
import System.Posix.Signals
import System.Posix.Signals as S
#endif
#if defined(mingw32_HOST_OS)
import GHC.ConsoleHandler
import GHC.ConsoleHandler as S
#endif
import GHC.Stack
......@@ -222,15 +223,23 @@ tryMost action = do r <- try action
Nothing -> throwIO se
Right v -> return (Right v)
-- | We use reference counting for signal handlers
{-# NOINLINE signalHandlersRefCount #-}
#if !defined(mingw32_HOST_OS)
signalHandlersRefCount :: MVar (Word, Maybe (S.Handler,S.Handler
,S.Handler,S.Handler))
#else
signalHandlersRefCount :: MVar (Word, Maybe S.Handler)
#endif
signalHandlersRefCount = unsafePerformIO $ newMVar (0,Nothing)
-- | Install standard signal handlers for catching ^C, which just throw an
-- exception in the target thread. The current target thread is the
-- thread at the head of the list in the MVar passed to
-- installSignalHandlers.
installSignalHandlers :: IO ()
installSignalHandlers = do
main_thread <- myThreadId
wtid <- mkWeakThreadId main_thread
-- | Temporarily install standard signal handlers for catching ^C, which just
-- throw an exception in the current thread.
withSignalHandlers :: (ExceptionMonad m, MonadIO m) => m a -> m a
withSignalHandlers act = do
main_thread <- liftIO myThreadId
wtid <- liftIO (mkWeakThreadId main_thread)
let
interrupt = do
......@@ -240,14 +249,23 @@ installSignalHandlers = do
Just t -> throwTo t UserInterrupt
#if !defined(mingw32_HOST_OS)
_ <- installHandler sigQUIT (Catch interrupt) Nothing
_ <- installHandler sigINT (Catch interrupt) Nothing
-- see #3656; in the future we should install these automatically for
-- all Haskell programs in the same way that we install a ^C handler.
let fatal_signal n = throwTo main_thread (Signal (fromIntegral n))
_ <- installHandler sigHUP (Catch (fatal_signal sigHUP)) Nothing
_ <- installHandler sigTERM (Catch (fatal_signal sigTERM)) Nothing
return ()
let installHandlers = do
let installHandler' a b = installHandler a b Nothing
hdlQUIT <- installHandler' sigQUIT (Catch interrupt)
hdlINT <- installHandler' sigINT (Catch interrupt)
-- see #3656; in the future we should install these automatically for
-- all Haskell programs in the same way that we install a ^C handler.
let fatal_signal n = throwTo main_thread (Signal (fromIntegral n))
hdlHUP <- installHandler' sigHUP (Catch (fatal_signal sigHUP))
hdlTERM <- installHandler' sigTERM (Catch (fatal_signal sigTERM))
return (hdlQUIT,hdlINT,hdlHUP,hdlTERM)
let uninstallHandlers (hdlQUIT,hdlINT,hdlHUP,hdlTERM) = do
_ <- installHandler sigQUIT hdlQUIT Nothing
_ <- installHandler sigINT hdlINT Nothing
_ <- installHandler sigHUP hdlHUP Nothing
_ <- installHandler sigTERM hdlTERM Nothing
return ()
#else
-- GHC 6.3+ has support for console events on Windows
-- NOTE: running GHCi under a bash shell for some reason requires
......@@ -258,6 +276,23 @@ installSignalHandlers = do
sig_handler Break = interrupt
sig_handler _ = return ()
_ <- installHandler (Catch sig_handler)
return ()
let installHandlers = installHandler (Catch sig_handler)
let uninstallHandlers = installHandler -- directly install the old handler
#endif
-- install signal handlers if necessary
let mayInstallHandlers = liftIO $ modifyMVar_ signalHandlersRefCount $ \case
(0,Nothing) -> do
hdls <- installHandlers
return (1,Just hdls)
(c,oldHandlers) -> return (c+1,oldHandlers)
-- uninstall handlers if necessary
let mayUninstallHandlers = liftIO $ modifyMVar_ signalHandlersRefCount $ \case
(1,Just hdls) -> do
uninstallHandlers hdls
return (0,Nothing)
(c,oldHandlers) -> return (c-1,oldHandlers)
mayInstallHandlers
act `gfinally` mayUninstallHandlers
......@@ -1139,9 +1139,9 @@ afterRunStmt step_here run_result = do
afterRunStmt step_here >> return ()
flushInterpBuffers
liftIO installSignalHandlers
b <- isOptionSet RevertCAFs
when b revertCAFs
withSignalHandlers $ do
b <- isOptionSet RevertCAFs
when b revertCAFs
return run_result
......@@ -3626,8 +3626,8 @@ handler :: SomeException -> GHCi Bool
handler exception = do
flushInterpBuffers
liftIO installSignalHandlers
ghciHandle handler (showException exception >> return False)
withSignalHandlers $
ghciHandle handler (showException exception >> return False)
showException :: SomeException -> GHCi ()
showException se =
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment