compiler/utils/Panic.lhs

   1 %
   2 % (c) The University of Glasgow 2006
   3 % (c) The GRASP Project, Glasgow University, 1992-2000
   4 %
   5 Defines basic functions for printing error messages.
   6
   7 It's hard to put these functions anywhere else without causing
   8 some unnecessary loops in the module dependency graph.
   9
  10 \begin{code}
  11 module Panic (
  12      GhcException(..), showGhcException, throwGhcException, handleGhcException,
  13      ghcError, progName,
  14      pgmError,
  15
  16      panic, sorry, panicFastInt, assertPanic, trace,
  17
  18      Exception.Exception(..), showException, try, tryMost, throwTo,
  19
  20      installSignalHandlers, interruptTargetThread
  21 ) where
  22 #include "HsVersions.h"
  23
  24 import Config
  25 import FastTypes
  26 import Exception
  27 import Control.Concurrent ( MVar, ThreadId, withMVar, newMVar, modifyMVar_,
  28                             myThreadId )
  29 import Data.Dynamic
  30 import Debug.Trace        ( trace )
  31 import System.IO.Unsafe   ( unsafePerformIO )
  32 import System.Exit
  33 import System.Environment
  34
  35 #ifndef mingw32_HOST_OS
  36 import System.Posix.Signals
  37 #endif
  38
  39 #if defined(mingw32_HOST_OS)
  40 import GHC.ConsoleHandler
  41 #endif
  42
  43
  44 -- | GHC's own exception type
  45 --   error messages all take the form:
  46 --
  47 --  @
  48 --      <location>: <error>
  49 --  @
  50 --
  51 --   If the location is on the command line, or in GHC itself, then
  52 --   <location>="ghc".  All of the error types below correspond to
  53 --   a <location> of "ghc", except for ProgramError (where the string is
  54 --  assumed to contain a location already, so we don't print one).
  55
  56 data GhcException
  57   = PhaseFailed  String         -- name of phase
  58                  ExitCode       -- an external phase (eg. cpp) failed
  59
  60   -- | Some other fatal signal (SIGHUP,SIGTERM)
  61   | Signal Int
  62
  63   -- | Prints the short usage msg after the error
  64   | UsageError   String
  65
  66   -- | A problem with the command line arguments, but don't print usage.
  67   | CmdLineError String
  68
  69   -- | The 'impossible' happened.
  70   | Panic        String
  71
  72   -- | The user tickled something that's known not to work yet,
  73   --   but we're not counting it as a bug.
  74   | Sorry        String
  75
  76   -- | An installation problem.
  77   | InstallationError String
  78
  79   -- | An error in the user's code, probably.
  80   | ProgramError String
  81   deriving Eq
  82
  83 instance Exception GhcException
  84
  85 instance Show GhcException where
  86   showsPrec _ e@(ProgramError _) = showGhcException e
  87   showsPrec _ e@(CmdLineError _) = showString "<command line>: " . showGhcException e
  88   showsPrec _ e = showString progName . showString ": " . showGhcException e
  89
  90 instance Typeable GhcException where
  91   typeOf _ = mkTyConApp ghcExceptionTc []
  92
  93
  94 -- | The name of this GHC.
  95 progName :: String
  96 progName = unsafePerformIO (getProgName)
  97 {-# NOINLINE progName #-}
  98
  99
 100 -- | Short usage information to display when we are given the wrong cmd line arguments.
 101 short_usage :: String
 102 short_usage = "Usage: For basic information, try the `--help' option."
 103
 104
 105 -- | Show an exception as a string.
 106 showException :: Exception e => e -> String
 107 showException = show
 108
 109
 110 -- | Append a description of the given exception to this string.
 111 showGhcException :: GhcException -> String -> String
 112 showGhcException exception
 113  = case exception of
 114         UsageError str
 115          -> showString str . showChar '\n' . showString short_usage
 116
 117         PhaseFailed phase code
 118          -> showString "phase `" . showString phase .
 119             showString "' failed (exitcode = " . shows (int_code code) .
 120             showString ")"
 121
 122         CmdLineError str        -> showString str
 123         ProgramError str        -> showString str
 124         InstallationError str   -> showString str
 125         Signal n                -> showString "signal: " . shows n
 126
 127         Panic s
 128          -> showString $
 129                 "panic! (the 'impossible' happened)\n"
 130                 ++ "  (GHC version " ++ cProjectVersion ++ " for " ++ TargetPlatform_NAME ++ "):\n\t"
 131                 ++ s ++ "\n\n"
 132                 ++ "Please report this as a GHC bug:  http://www.haskell.org/ghc/reportabug\n"
 133
 134         Sorry s
 135          -> showString $
 136                 "sorry! (unimplemented feature or known bug)\n"
 137                  ++ "  (GHC version " ++ cProjectVersion ++ " for " ++ TargetPlatform_NAME ++ "):\n\t"
 138                  ++ s ++ "\n"
 139
 140   where int_code code =
 141           case code of
 142                 ExitSuccess   -> (0::Int)
 143                 ExitFailure x -> x
 144
 145
 146 -- | Alias for `throwGhcException`
 147 ghcError :: GhcException -> a
 148 ghcError e = Exception.throw e
 149
 150 throwGhcException :: GhcException -> a
 151 throwGhcException = Exception.throw
 152
 153 handleGhcException :: ExceptionMonad m => (GhcException -> m a) -> m a -> m a
 154 handleGhcException = ghandle
 155
 156
 157 ghcExceptionTc :: TyCon
 158 ghcExceptionTc = mkTyCon "GhcException"
 159 {-# NOINLINE ghcExceptionTc #-}
 160
 161
 162 -- | Panics and asserts.
 163 panic, sorry, pgmError :: String -> a
 164 panic    x = throwGhcException (Panic x)
 165 sorry    x = throwGhcException (Sorry x)
 166 pgmError x = throwGhcException (ProgramError x)
 167
 168
 169 -- | Panic while pretending to return an unboxed int.
 170 --   You can't use the regular panic functions in expressions
 171 --   producing unboxed ints because they have the wrong kind.
 172 panicFastInt :: String -> FastInt
 173 panicFastInt s = case (panic s) of () -> _ILIT(0)
 174
 175
 176 -- | Throw an failed assertion exception for a given filename and line number.
 177 assertPanic :: String -> Int -> a
 178 assertPanic file line =
 179   Exception.throw (Exception.AssertionFailed
 180            ("ASSERT failed! file " ++ file ++ ", line " ++ show line))
 181
 182
 183 -- | Like try, but pass through UserInterrupt and Panic exceptions.
 184 --   Used when we want soft failures when reading interface files, for example.
 185 --   TODO: I'm not entirely sure if this is catching what we really want to catch
 186 tryMost :: IO a -> IO (Either SomeException a)
 187 tryMost action = do r <- try action
 188                     case r of
 189                         Left se ->
 190                             case fromException se of
 191                                 -- Some GhcException's we rethrow,
 192                                 Just (Signal _)  -> throwIO se
 193                                 Just (Panic _)   -> throwIO se
 194                                 -- others we return
 195                                 Just _           -> return (Left se)
 196                                 Nothing ->
 197                                     case fromException se of
 198                                         -- All IOExceptions are returned
 199                                         Just (_ :: IOException) ->
 200                                             return (Left se)
 201                                         -- Anything else is rethrown
 202                                         Nothing -> throwIO se
 203                         Right v -> return (Right v)
 204
 205
 206 -- | Install standard signal handlers for catching ^C, which just throw an
 207 --   exception in the target thread.  The current target thread is the
 208 --   thread at the head of the list in the MVar passed to
 209 --   installSignalHandlers.
 210 installSignalHandlers :: IO ()
 211 installSignalHandlers = do
 212   main_thread <- myThreadId
 213   modifyMVar_ interruptTargetThread (return . (main_thread :))
 214
 215   let
 216       interrupt_exn = (toException UserInterrupt)
 217
 218       interrupt = do
 219         withMVar interruptTargetThread $ \targets ->
 220           case targets of
 221            [] -> return ()
 222            (thread:_) -> throwTo thread interrupt_exn
 223
 224   --
 225 #if !defined(mingw32_HOST_OS)
 226   _ <- installHandler sigQUIT  (Catch interrupt) Nothing
 227   _ <- installHandler sigINT   (Catch interrupt) Nothing
 228   -- see #3656; in the future we should install these automatically for
 229   -- all Haskell programs in the same way that we install a ^C handler.
 230   let fatal_signal n = throwTo main_thread (Signal (fromIntegral n))
 231   _ <- installHandler sigHUP   (Catch (fatal_signal sigHUP))  Nothing
 232   _ <- installHandler sigTERM  (Catch (fatal_signal sigTERM)) Nothing
 233   return ()
 234 #else
 235   -- GHC 6.3+ has support for console events on Windows
 236   -- NOTE: running GHCi under a bash shell for some reason requires
 237   -- you to press Ctrl-Break rather than Ctrl-C to provoke
 238   -- an interrupt.  Ctrl-C is getting blocked somewhere, I don't know
 239   -- why --SDM 17/12/2004
 240   let sig_handler ControlC = interrupt
 241       sig_handler Break    = interrupt
 242       sig_handler _        = return ()
 243
 244   _ <- installHandler (Catch sig_handler)
 245   return ()
 246 #endif
 247
 248 {-# NOINLINE interruptTargetThread #-}
 249 interruptTargetThread :: MVar [ThreadId]
 250 interruptTargetThread = unsafePerformIO (newMVar [])
 251
 252 \end{code}