X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Futils%2FPanic.lhs;h=d430df695e4c168cf2f4e98dc6b7b90a580b6244;hp=a49a68d6235edc49ee576f5756294ae76dcf3fad;hb=c5b178be60a5a44abd2f4ddf8c399857678326e2;hpb=f4ce543cff19b797d54d435dc7c804acdefca9c8 diff --git a/compiler/utils/Panic.lhs b/compiler/utils/Panic.lhs index a49a68d..d430df6 100644 --- a/compiler/utils/Panic.lhs +++ b/compiler/utils/Panic.lhs @@ -2,116 +2,150 @@ % (c) The University of Glasgow 2006 % (c) The GRASP Project, Glasgow University, 1992-2000 % - -Defines basic funtions for printing error messages. +Defines basic functions for printing error messages. It's hard to put these functions anywhere else without causing some unnecessary loops in the module dependency graph. \begin{code} -module Panic - ( +module Panic ( GhcException(..), showGhcException, throwGhcException, handleGhcException, ghcError, progName, pgmError, - panic, panicFastInt, assertPanic, trace, + panic, sorry, panicFastInt, assertPanic, trace, Exception.Exception(..), showException, try, tryMost, throwTo, installSignalHandlers, interruptTargetThread - ) where - +) where #include "HsVersions.h" import Config import FastTypes +import Exception +import Control.Concurrent ( MVar, ThreadId, withMVar, newMVar, modifyMVar_, + myThreadId ) +import Data.Dynamic +import Debug.Trace ( trace ) +import System.IO.Unsafe ( unsafePerformIO ) +import System.Exit +import System.Environment #ifndef mingw32_HOST_OS import System.Posix.Signals -#endif /* mingw32_HOST_OS */ +#endif #if defined(mingw32_HOST_OS) import GHC.ConsoleHandler #endif -import Exception -import Control.Concurrent ( MVar, ThreadId, withMVar, newMVar ) -import Data.Dynamic -import Debug.Trace ( trace ) -import System.IO.Unsafe ( unsafePerformIO ) -import System.Exit -import System.Environment -\end{code} -GHC's own exception type. - -\begin{code} -ghcError :: GhcException -> a -ghcError e = Exception.throw e - --- error messages all take the form +-- | GHC's own exception type +-- error messages all take the form: -- +-- @ -- : --- --- If the location is on the command line, or in GHC itself, then --- ="ghc". All of the error types below correspond to --- a of "ghc", except for ProgramError (where the string is --- assumed to contain a location already, so we don't print one). +-- @ +-- +-- If the location is on the command line, or in GHC itself, then +-- ="ghc". All of the error types below correspond to +-- a of "ghc", except for ProgramError (where the string is +-- 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 - | CmdLineError String -- cmdline prob, but doesn't print usage - | Panic String -- the `impossible' happened - | InstallationError String -- an installation problem - | ProgramError String -- error in the user's code, probably + = PhaseFailed String -- name of phase + ExitCode -- an external phase (eg. cpp) failed + + -- | Some other fatal signal (SIGHUP,SIGTERM) + | Signal Int + + -- | Prints the short usage msg after the error + | UsageError String + + -- | A problem with the command line arguments, but don't print usage. + | CmdLineError String + + -- | The 'impossible' happened. + | Panic String + + -- | The user tickled something that's known not to work yet, + -- but we're not counting it as a bug. + | Sorry String + + -- | An installation problem. + | InstallationError String + + -- | An error in the user's code, probably. + | ProgramError String deriving Eq instance Exception GhcException +instance Show GhcException where + showsPrec _ e@(ProgramError _) = showGhcException e + showsPrec _ e@(CmdLineError _) = showString ": " . showGhcException e + showsPrec _ e = showString progName . showString ": " . showGhcException e + +instance Typeable GhcException where + typeOf _ = mkTyConApp ghcExceptionTc [] + + +-- | The name of this GHC. progName :: String progName = unsafePerformIO (getProgName) {-# NOINLINE progName #-} + +-- | Short usage information to display when we are given the wrong cmd line arguments. short_usage :: String short_usage = "Usage: For basic information, try the `--help' option." + +-- | Show an exception as a string. showException :: Exception e => e -> String showException = show -instance Show GhcException where - showsPrec _ e@(ProgramError _) = showGhcException e - showsPrec _ e@(CmdLineError _) = showString ": " . showGhcException e - showsPrec _ e = showString progName . showString ": " . showGhcException e +-- | Append a description of the given exception to this string. showGhcException :: GhcException -> String -> String -showGhcException (UsageError str) - = showString str . showChar '\n' . showString short_usage -showGhcException (PhaseFailed phase code) - = showString "phase `" . showString phase . - showString "' failed (exitcode = " . shows int_code . - showString ")" - where - int_code = - case code of - ExitSuccess -> (0::Int) - ExitFailure x -> x -showGhcException (CmdLineError str) - = showString str -showGhcException (ProgramError str) - = showString str -showGhcException (InstallationError str) - = showString str -showGhcException (Interrupted) - = showString "interrupted" -showGhcException (Panic s) - = showString ("panic! (the 'impossible' happened)\n" +showGhcException exception + = case exception of + UsageError str + -> showString str . showChar '\n' . showString short_usage + + PhaseFailed phase code + -> showString "phase `" . showString phase . + showString "' failed (exitcode = " . shows (int_code code) . + showString ")" + + CmdLineError str -> showString str + ProgramError str -> showString str + InstallationError str -> showString str + Signal n -> showString "signal: " . shows n + + 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" + + Sorry s + -> showString $ + "sorry! (unimplemented feature or known bug)\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") + ++ s ++ "\n" + + where int_code code = + case code of + ExitSuccess -> (0::Int) + ExitFailure x -> x + + +-- | Alias for `throwGhcException` +ghcError :: GhcException -> a +ghcError e = Exception.throw e throwGhcException :: GhcException -> a throwGhcException = Exception.throw @@ -119,46 +153,43 @@ throwGhcException = Exception.throw handleGhcException :: ExceptionMonad m => (GhcException -> m a) -> m a -> m a handleGhcException = ghandle + ghcExceptionTc :: TyCon ghcExceptionTc = mkTyCon "GhcException" {-# NOINLINE ghcExceptionTc #-} -instance Typeable GhcException where - typeOf _ = mkTyConApp ghcExceptionTc [] -\end{code} -Panics and asserts. -\begin{code} -panic, pgmError :: String -> a +-- | Panics and asserts. +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) --- No, man -- Too Beautiful! (Will) +-- | Panic while pretending to return an unboxed int. +-- You can't use the regular panic functions in expressions +-- producing unboxed ints because they have the wrong kind. panicFastInt :: String -> FastInt panicFastInt s = case (panic s) of () -> _ILIT(0) + +-- | Throw an failed assertion exception for a given filename and line number. assertPanic :: String -> Int -> a assertPanic file line = Exception.throw (Exception.AssertionFailed ("ASSERT failed! file " ++ file ++ ", line " ++ show line)) -\end{code} -\begin{code} --- | tryMost is like try, but passes through Interrupted and Panic --- exceptions. Used when we want soft failures when reading interface --- files, for example. --- XXX I'm not entirely sure if this is catching what we really want to catch +-- | Like try, but pass through UserInterrupt and Panic exceptions. +-- Used when we want soft failures when reading interface files, for example. +-- TODO: 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 Interrupted -> throwIO se + Just (Signal _) -> throwIO se Just (Panic _) -> throwIO se -- others we return Just _ -> return (Left se) @@ -170,28 +201,35 @@ tryMost action = do r <- try action -- Anything else is rethrown Nothing -> throwIO se Right v -> return (Right v) -\end{code} -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. -\begin{code} +-- | 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 + modifyMVar_ interruptTargetThread (return . (main_thread :)) + let - interrupt_exn = (toException 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 @@ -203,11 +241,12 @@ installSignalHandlers = do sig_handler Break = interrupt sig_handler _ = return () - installHandler (Catch sig_handler) + _ <- installHandler (Catch sig_handler) return () #endif {-# NOINLINE interruptTargetThread #-} interruptTargetThread :: MVar [ThreadId] interruptTargetThread = unsafePerformIO (newMVar []) + \end{code}