%
% (c) The University of Glasgow 2006
% (c) The GRASP Project, Glasgow University, 19922000
%
Defines basic funtions 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
(
GhcException(..), showGhcException, throwGhcException, handleGhcException,
ghcError, progName,
pgmError,
panic, panicFastInt, assertPanic, trace,
Exception.Exception(..), showException, try, tryMost, throwTo,
installSignalHandlers, interruptTargetThread
) where
#include "HsVersions.h"
import Config
import FastTypes
#ifndef mingw32_HOST_OS
import System.Posix.Signals
#endif /* mingw32_HOST_OS */
#if defined(mingw32_HOST_OS)
import GHC.ConsoleHandler
#endif
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
\end{code}
GHC's own exception type.
\begin{code}
ghcError :: GhcException -> a
ghcError e = Exception.throw e
data GhcException
= PhaseFailed String
ExitCode
| Signal Int
| UsageError String
| CmdLineError String
| Panic String
| InstallationError String
| ProgramError String
deriving Eq
instance Exception GhcException
progName :: String
progName = unsafePerformIO (getProgName)
short_usage :: String
short_usage = "Usage: For basic information, try the `--help' option."
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
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 (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")
throwGhcException :: GhcException -> a
throwGhcException = Exception.throw
handleGhcException :: ExceptionMonad m => (GhcException -> m a) -> m a -> m a
handleGhcException = ghandle
ghcExceptionTc :: TyCon
ghcExceptionTc = mkTyCon "GhcException"
instance Typeable GhcException where
typeOf _ = mkTyConApp ghcExceptionTc []
\end{code}
Panics and asserts.
\begin{code}
panic, pgmError :: String -> a
panic x = throwGhcException (Panic x)
pgmError x = throwGhcException (ProgramError x)
panicFastInt :: String -> FastInt
panicFastInt s = case (panic s) of () -> _ILIT(0)
assertPanic :: String -> Int -> a
assertPanic file line =
Exception.throw (Exception.AssertionFailed
("ASSERT failed! file " ++ file ++ ", line " ++ show line))
\end{code}
\begin{code}
tryMost :: IO a -> IO (Either SomeException a)
tryMost action = do r <- try action
case r of
Left se ->
case fromException se of
Just (Signal _) -> throwIO se
Just (Panic _) -> throwIO se
Just _ -> return (Left se)
Nothing ->
case fromException se of
Just (_ :: IOException) ->
return (Left se)
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}
installSignalHandlers :: IO ()
installSignalHandlers = do
main_thread <- myThreadId
modifyMVar_ interruptTargetThread (return . (main_thread :))
let
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
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
let sig_handler ControlC = interrupt
sig_handler Break = interrupt
sig_handler _ = return ()
_ <- installHandler (Catch sig_handler)
return ()
#endif
interruptTargetThread :: MVar [ThreadId]
interruptTargetThread = unsafePerformIO (newMVar [])
\end{code}