diff options
| -rw-r--r-- | compiler/main/GHC.hs | 10 | ||||
| -rw-r--r-- | compiler/utils/Panic.hs | 79 | ||||
| -rw-r--r-- | ghc/GHCi/UI.hs | 10 |
3 files changed, 65 insertions, 34 deletions
diff --git a/compiler/main/GHC.hs b/compiler/main/GHC.hs index 5122329acf..8eb77efe2d 100644 --- a/compiler/main/GHC.hs +++ b/compiler/main/GHC.hs @@ -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 diff --git a/compiler/utils/Panic.hs b/compiler/utils/Panic.hs index 721198e211..6a7e96af47 100644 --- a/compiler/utils/Panic.hs +++ b/compiler/utils/Panic.hs @@ -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 diff --git a/ghc/GHCi/UI.hs b/ghc/GHCi/UI.hs index 3cc3f5c575..a3cb955bbe 100644 --- a/ghc/GHCi/UI.hs +++ b/ghc/GHCi/UI.hs @@ -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 = |