diff options
author | Simon Marlow <marlowsd@gmail.com> | 2010-01-27 14:04:38 +0000 |
---|---|---|
committer | Simon Marlow <marlowsd@gmail.com> | 2010-01-27 14:04:38 +0000 |
commit | 9e7567632bc6af06d3e874d1675479e7b1991f63 (patch) | |
tree | ed1e384c78234522de3e978cc4866da020f5723d /compiler/utils/Panic.lhs | |
parent | 94f8be0021334a1258a137c0e9611d78125ac092 (diff) | |
download | haskell-9e7567632bc6af06d3e874d1675479e7b1991f63.tar.gz |
catch SIGHUP and SIGTERM and raise an exception (#3656)
Diffstat (limited to 'compiler/utils/Panic.lhs')
-rw-r--r-- | compiler/utils/Panic.lhs | 21 |
1 files changed, 18 insertions, 3 deletions
diff --git a/compiler/utils/Panic.lhs b/compiler/utils/Panic.lhs index f4ca2ab97c..0833de87ec 100644 --- a/compiler/utils/Panic.lhs +++ b/compiler/utils/Panic.lhs @@ -36,7 +36,8 @@ import GHC.ConsoleHandler #endif import Exception -import Control.Concurrent ( MVar, ThreadId, withMVar, newMVar ) +import Control.Concurrent ( MVar, ThreadId, withMVar, newMVar, modifyMVar_, + myThreadId ) import Data.Dynamic import Debug.Trace ( trace ) import System.IO.Unsafe ( unsafePerformIO ) @@ -63,6 +64,7 @@ data GhcException = PhaseFailed String -- name of phase ExitCode -- an external phase (eg. cpp) failed | Interrupted -- someone pressed ^C + | Signal Int -- some other fatal signal (SIGHUP,SIGTERM) | UsageError String -- prints the short usage msg after the error | CmdLineError String -- cmdline prob, but doesn't print usage | Panic String -- the `impossible' happened @@ -107,6 +109,8 @@ showGhcException (InstallationError str) = showString str showGhcException (Interrupted) = showString "interrupted" +showGhcException (Signal n) + = showString "signal: " . shows n showGhcException (Panic s) = showString ("panic! (the 'impossible' happened)\n" ++ " (GHC version " ++ cProjectVersion ++ " for " ++ TargetPlatform_NAME ++ "):\n\t" @@ -159,6 +163,7 @@ tryMost action = do r <- try action case fromException se of -- Some GhcException's we rethrow, Just Interrupted -> throwIO se + Just (Signal _) -> throwIO se Just (Panic _) -> throwIO se -- others we return Just _ -> return (Left se) @@ -180,6 +185,9 @@ installSignalHandlers. \begin{code} installSignalHandlers :: IO () installSignalHandlers = do + main_thread <- myThreadId + modifyMVar_ interruptTargetThread (return . (main_thread :)) + let interrupt_exn = (toException Interrupted) @@ -188,10 +196,17 @@ installSignalHandlers = do case targets of [] -> return () (thread:_) -> throwTo thread interrupt_exn + + fatal_signal n = throwTo main_thread (Signal (fromIntegral n)) + -- #if !defined(mingw32_HOST_OS) - _ <- installHandler sigQUIT (Catch interrupt) Nothing - _ <- installHandler sigINT (Catch interrupt) Nothing + _ <- 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. + _ <- installHandler sigHUP (Catch (fatal_signal sigHUP)) Nothing + _ <- installHandler sigTERM (Catch (fatal_signal sigTERM)) Nothing return () #else -- GHC 6.3+ has support for console events on Windows |