X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Futils%2FPanic.lhs;h=0e1b59dead6441c109ea17e0d776f288eb67ef86;hb=3a7e2b3ad24b08dd68c96421d1ef94baa9b00c92;hp=97648b72de17c3cb8c0e5cf008976d20c847d76e;hpb=268377f59589e6afec1048458c350011ebb74afe;p=ghc-hetmet.git diff --git a/compiler/utils/Panic.lhs b/compiler/utils/Panic.lhs index 97648b7..0e1b59d 100644 --- a/compiler/utils/Panic.lhs +++ b/compiler/utils/Panic.lhs @@ -11,13 +11,13 @@ some unnecessary loops in the module dependency graph. \begin{code} module Panic ( - GhcException(..), showGhcException, ghcError, progName, + GhcException(..), showGhcException, throwGhcException, handleGhcException, + ghcError, progName, pgmError, - panic, panicFastInt, assertPanic, trace, + panic, sorry, panicFastInt, assertPanic, trace, - Exception.Exception(..), showException, try, tryJust, tryMost, tryUser, - catchJust, ioErrors, throwTo, + Exception.Exception(..), showException, try, tryMost, throwTo, installSignalHandlers, interruptTargetThread ) where @@ -35,13 +35,12 @@ import System.Posix.Signals import GHC.ConsoleHandler #endif -import Control.Exception -import Control.Concurrent ( MVar, ThreadId, withMVar, newMVar ) +import Exception +import Control.Concurrent ( MVar, ThreadId, withMVar, newMVar, modifyMVar_, + myThreadId ) import Data.Dynamic -import qualified Control.Exception as Exception import Debug.Trace ( trace ) import System.IO.Unsafe ( unsafePerformIO ) -import System.IO.Error ( isUserError ) import System.Exit import System.Environment \end{code} @@ -50,7 +49,7 @@ GHC's own exception type. \begin{code} ghcError :: GhcException -> a -ghcError e = Exception.throwDyn e +ghcError e = Exception.throw e -- error messages all take the form -- @@ -62,28 +61,29 @@ ghcError e = Exception.throwDyn e -- assumed to contain a location already, so we don't print one). data GhcException - = PhaseFailed String -- name of phase - ExitCode -- an external phase (eg. cpp) failed - | Interrupted -- someone pressed ^C - | UsageError String -- prints the short usage msg after the error + = PhaseFailed String -- name of phase + ExitCode -- an external phase (eg. cpp) failed + | 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 + | Panic String -- the `impossible' happened + | Sorry String -- the user tickled something that's known not to work yet, + -- and we're not counting it as a bug. | InstallationError String -- an installation problem | ProgramError String -- error in the user's code, probably deriving Eq +instance Exception GhcException + progName :: String progName = unsafePerformIO (getProgName) {-# NOINLINE progName #-} short_usage :: String short_usage = "Usage: For basic information, try the `--help' option." - -showException :: Exception.Exception -> String --- Show expected dynamic exceptions specially -showException (Exception.DynException d) | Just e <- fromDynamic d - = show (e::GhcException) -showException other_exn = show other_exn + +showException :: Exception e => e -> String +showException = show instance Show GhcException where showsPrec _ e@(ProgramError _) = showGhcException e @@ -108,13 +108,24 @@ showGhcException (ProgramError str) = showString str 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" ++ s ++ "\n\n" ++ "Please report this as a GHC bug: http://www.haskell.org/ghc/reportabug\n") +showGhcException (Sorry s) + = showString ("sorry! (this is work in progress)\n" + ++ " (GHC version " ++ cProjectVersion ++ " for " ++ TargetPlatform_NAME ++ "):\n\t" + ++ s ++ "\n") + + +throwGhcException :: GhcException -> a +throwGhcException = Exception.throw + +handleGhcException :: ExceptionMonad m => (GhcException -> m a) -> m a -> m a +handleGhcException = ghandle ghcExceptionTc :: TyCon ghcExceptionTc = mkTyCon "GhcException" @@ -126,9 +137,10 @@ instance Typeable GhcException where Panics and asserts. \begin{code} -panic, pgmError :: String -> a -panic x = Exception.throwDyn (Panic x) -pgmError x = Exception.throwDyn (ProgramError x) +panic, sorry, pgmError :: String -> a +panic x = throwGhcException (Panic x) +sorry x = throwGhcException (Sorry x) +pgmError x = throwGhcException (ProgramError x) -- #-versions because panic can't return an unboxed int, and that's -- what TAG_ is with GHC at the moment. Ugh. (Simon) @@ -144,30 +156,29 @@ assertPanic file line = \end{code} \begin{code} --- | tryMost is like try, but passes through Interrupted and Panic +-- | tryMost is like try, but passes through UserInterrupt and Panic -- exceptions. Used when we want soft failures when reading interface -- files, for example. -tryMost :: IO a -> IO (Either Exception.Exception a) -tryMost action = do r <- try action; filter r - where - filter (Left e@(Exception.DynException d)) - | Just ghc_ex <- fromDynamic d - = case ghc_ex of - Interrupted -> Exception.throw e - Panic _ -> Exception.throw e - _other -> return (Left e) - filter other - = return other - --- | tryUser is like try, but catches only UserErrors. --- These are the ones that are thrown by the TcRn monad --- to signal an error in the program being compiled -tryUser :: IO a -> IO (Either Exception.Exception a) -tryUser action = tryJust tc_errors action - where - tc_errors e@(Exception.IOException ioe) | isUserError ioe = Just e - tc_errors _other = Nothing +-- XXX I'm not entirely sure if this is catching what we really want to catch +tryMost :: IO a -> IO (Either SomeException a) +tryMost action = do r <- try action + case r of + Left se -> + case fromException se of + -- Some GhcException's we rethrow, + Just (Signal _) -> throwIO se + Just (Panic _) -> throwIO se + -- others we return + Just _ -> return (Left se) + Nothing -> + case fromException se of + -- All IOExceptions are returned + Just (_ :: IOException) -> + return (Left se) + -- Anything else is rethrown + Nothing -> throwIO se + Right v -> return (Right v) \end{code} Standard signal handlers for catching ^C, which just throw an @@ -178,18 +189,27 @@ installSignalHandlers. \begin{code} installSignalHandlers :: IO () installSignalHandlers = do + main_thread <- myThreadId + modifyMVar_ interruptTargetThread (return . (main_thread :)) + let - interrupt_exn = Exception.DynException (toDyn Interrupted) + interrupt_exn = (toException UserInterrupt) interrupt = do withMVar interruptTargetThread $ \targets -> case targets of [] -> return () (thread:_) -> throwTo thread interrupt_exn + -- #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. + 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 () #else -- GHC 6.3+ has support for console events on Windows @@ -201,7 +221,7 @@ installSignalHandlers = do sig_handler Break = interrupt sig_handler _ = return () - installHandler (Catch sig_handler) + _ <- installHandler (Catch sig_handler) return () #endif