% (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, tryUser, throwTo,
+ 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.IO.Error hiding ( try )
-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:
--
+-- @
-- <location>: <error>
---
--- If the location is on the command line, or in GHC itself, then
--- <location>="ghc". All of the error types below correspond to
--- a <location> 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
+-- <location>="ghc". All of the error types below correspond to
+-- a <location> 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 "<command line>: " . 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 "<command line>: " . 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
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)
Nothing -> throwIO se
Right v -> return (Right v)
--- | 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 IOException a)
-tryUser io =
- do ei <- try io
- case ei of
- Right v -> return (Right v)
- Left se ->
- case fromException se of
- Just ioe
- | isUserError ioe ->
- return (Left ioe)
- _ -> throw se
-\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
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}
projects / ghc-hetmet.git / blobdiff