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