compiler/utils/Panic.lhs

   1 %
   2 % (c) The University of Glasgow 2006
   3 % (c) The GRASP Project, Glasgow University, 1992-2000
   4 %
   5
   6 Defines basic funtions for printing error messages.
   7
   8 It's hard to put these functions anywhere else without causing
   9 some unnecessary loops in the module dependency graph.
  10
  11 \begin{code}
  12 module Panic
  13    (
  14      GhcException(..), showGhcException, ghcError, progName,
  15      pgmError,
  16
  17      panic, panic#, assertPanic, trace,
  18
  19      Exception.Exception(..), showException, try, tryJust, tryMost, tryUser,
  20      catchJust, ioErrors, throwTo,
  21
  22      installSignalHandlers, interruptTargetThread
  23    ) where
  24
  25 #include "HsVersions.h"
  26
  27 import Config
  28 import FastTypes
  29
  30 #ifndef mingw32_HOST_OS
  31 import System.Posix.Signals
  32 #endif /* mingw32_HOST_OS */
  33
  34 #if defined(mingw32_HOST_OS) && __GLASGOW_HASKELL__ >= 603
  35 import GHC.ConsoleHandler
  36 #endif
  37
  38 import Control.Exception
  39 import Control.Concurrent ( MVar, ThreadId, withMVar, newMVar )
  40 import Data.Dynamic
  41 import qualified Control.Exception as Exception
  42 import Debug.Trace      ( trace )
  43 import System.IO.Unsafe ( unsafePerformIO )
  44 import System.IO.Error  ( isUserError )
  45 import System.Exit
  46 import System.Environment
  47 \end{code}
  48
  49 GHC's own exception type.
  50
  51 \begin{code}
  52 ghcError :: GhcException -> a
  53 ghcError e = Exception.throwDyn e
  54
  55 -- error messages all take the form
  56 --
  57 --      <location>: <error>
  58 --
  59 -- If the location is on the command line, or in GHC itself, then
  60 -- <location>="ghc".  All of the error types below correspond to
  61 -- a <location> of "ghc", except for ProgramError (where the string is
  62 -- assumed to contain a location already, so we don't print one).
  63
  64 data GhcException
  65   = PhaseFailed String          -- name of phase
  66                 ExitCode        -- an external phase (eg. cpp) failed
  67   | Interrupted                 -- someone pressed ^C
  68   | UsageError String           -- prints the short usage msg after the error
  69   | CmdLineError String         -- cmdline prob, but doesn't print usage
  70   | Panic String                -- the `impossible' happened
  71   | InstallationError String    -- an installation problem
  72   | ProgramError String         -- error in the user's code, probably
  73   deriving Eq
  74
  75 progName = unsafePerformIO (getProgName)
  76 {-# NOINLINE progName #-}
  77
  78 short_usage = "Usage: For basic information, try the `--help' option."
  79
  80 showException :: Exception.Exception -> String
  81 -- Show expected dynamic exceptions specially
  82 showException (Exception.DynException d) | Just e <- fromDynamic d
  83                                          = show (e::GhcException)
  84 showException other_exn                  = show other_exn
  85
  86 instance Show GhcException where
  87   showsPrec _ e@(ProgramError _) = showGhcException e
  88   showsPrec _ e = showString progName . showString ": " . showGhcException e
  89
  90 showGhcException (UsageError str)
  91    = showString str . showChar '\n' . showString short_usage
  92 showGhcException (PhaseFailed phase code)
  93    = showString "phase `" . showString phase .
  94      showString "' failed (exitcode = " . shows int_code .
  95      showString ")"
  96   where
  97     int_code =
  98       case code of
  99         ExitSuccess   -> (0::Int)
 100         ExitFailure x -> x
 101 showGhcException (CmdLineError str)
 102    = showString str
 103 showGhcException (ProgramError str)
 104    = showString str
 105 showGhcException (InstallationError str)
 106    = showString str
 107 showGhcException (Interrupted)
 108    = showString "interrupted"
 109 showGhcException (Panic s)
 110    = showString ("panic! (the 'impossible' happened)\n"
 111                  ++ "  (GHC version " ++ cProjectVersion ++ " for " ++ TargetPlatform_NAME ++ "):\n\t"
 112                  ++ s ++ "\n\n"
 113                  ++ "Please report this as a GHC bug:  http://www.haskell.org/ghc/reportabug\n")
 114
 115 #if __GLASGOW_HASKELL__ < 603
 116 myMkTyConApp = mkAppTy
 117 #else
 118 myMkTyConApp = mkTyConApp
 119 #endif
 120
 121 ghcExceptionTc = mkTyCon "GhcException"
 122 {-# NOINLINE ghcExceptionTc #-}
 123 instance Typeable GhcException where
 124   typeOf _ = myMkTyConApp ghcExceptionTc []
 125 \end{code}
 126
 127 Panics and asserts.
 128
 129 \begin{code}
 130 panic, pgmError :: String -> a
 131 panic    x = Exception.throwDyn (Panic x)
 132 pgmError x = Exception.throwDyn (ProgramError x)
 133
 134 --  #-versions because panic can't return an unboxed int, and that's
 135 -- what TAG_ is with GHC at the moment.  Ugh. (Simon)
 136 -- No, man -- Too Beautiful! (Will)
 137
 138 panic# :: String -> FastInt
 139 panic# s = case (panic s) of () -> _ILIT 0
 140
 141 assertPanic :: String -> Int -> a
 142 assertPanic file line =
 143   Exception.throw (Exception.AssertionFailed
 144            ("ASSERT failed! file " ++ file ++ ", line " ++ show line))
 145 \end{code}
 146
 147 \begin{code}
 148 -- | tryMost is like try, but passes through Interrupted and Panic
 149 -- exceptions.  Used when we want soft failures when reading interface
 150 -- files, for example.
 151
 152 tryMost :: IO a -> IO (Either Exception.Exception a)
 153 tryMost action = do r <- try action; filter r
 154   where
 155    filter (Left e@(Exception.DynException d))
 156             | Just ghc_ex <- fromDynamic d
 157                 = case ghc_ex of
 158                     Interrupted -> Exception.throw e
 159                     Panic _     -> Exception.throw e
 160                     _other      -> return (Left e)
 161    filter other
 162      = return other
 163
 164 -- | tryUser is like try, but catches only UserErrors.
 165 -- These are the ones that are thrown by the TcRn monad
 166 -- to signal an error in the program being compiled
 167 tryUser :: IO a -> IO (Either Exception.Exception a)
 168 tryUser action = tryJust tc_errors action
 169   where
 170         tc_errors e@(Exception.IOException ioe) | isUserError ioe = Just e
 171         tc_errors _other = Nothing
 172 \end{code}
 173
 174 Standard signal handlers for catching ^C, which just throw an
 175 exception in the target thread.  The current target thread is
 176 the thread at the head of the list in the MVar passed to
 177 installSignalHandlers.
 178
 179 \begin{code}
 180 installSignalHandlers :: IO ()
 181 installSignalHandlers = do
 182   let
 183       interrupt_exn = Exception.DynException (toDyn Interrupted)
 184
 185       interrupt = do
 186         withMVar interruptTargetThread $ \targets ->
 187           case targets of
 188            [] -> return ()
 189            (thread:_) -> throwTo thread interrupt_exn
 190   --
 191 #if !defined(mingw32_HOST_OS)
 192   installHandler sigQUIT (Catch interrupt) Nothing
 193   installHandler sigINT  (Catch interrupt) Nothing
 194   return ()
 195 #elif __GLASGOW_HASKELL__ >= 603
 196   -- GHC 6.3+ has support for console events on Windows
 197   -- NOTE: running GHCi under a bash shell for some reason requires
 198   -- you to press Ctrl-Break rather than Ctrl-C to provoke
 199   -- an interrupt.  Ctrl-C is getting blocked somewhere, I don't know
 200   -- why --SDM 17/12/2004
 201   let sig_handler ControlC = interrupt
 202       sig_handler Break    = interrupt
 203       sig_handler _        = return ()
 204
 205   installHandler (Catch sig_handler)
 206   return ()
 207 #else
 208   return () -- nothing
 209 #endif
 210
 211 {-# NOINLINE interruptTargetThread #-}
 212 interruptTargetThread :: MVar [ThreadId]
 213 interruptTargetThread = unsafePerformIO (newMVar [])
 214 \end{code}