[commit: ghc] master: Uninstall signal handlers (8a5960a)
git at git.haskell.org
git at git.haskell.org
Wed Nov 2 20:14:52 UTC 2016
Repository : ssh://git@git.haskell.org/ghc
On branch : master
Link : http://ghc.haskell.org/trac/ghc/changeset/8a5960ad874d31fcf631b4d427ccd9fae571745c/ghc
>---------------------------------------------------------------
commit 8a5960ad874d31fcf631b4d427ccd9fae571745c
Author: Sylvain HENRY <hsyl20 at gmail.com>
Date: Wed Nov 2 14:55:06 2016 -0400
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
>---------------------------------------------------------------
8a5960ad874d31fcf631b4d427ccd9fae571745c
compiler/main/GHC.hs | 10 ++-----
compiler/utils/Panic.hs | 79 +++++++++++++++++++++++++++++++++++--------------
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 5122329..8eb77ef 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 721198e..6a7e96a 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 3cc3f5c..a3cb955 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 =
More information about the ghc-commits
mailing list