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
  43 import Control.Concurrent ( MVar, ThreadId, withMVar, newMVar )
  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
 175         tc_errors e@(Exception.IOException ioe) | isUserError ioe = Just e
 176 #else
 177         tc_errors e@(Exception.IOException ioe) | isUserError e = Just e
 178 #endif
 179         tc_errors _other = Nothing
 180 \end{code}
 181
 182 Standard signal handlers for catching ^C, which just throw an
 183 exception in the target thread.  The current target thread is
 184 the thread at the head of the list in the MVar passed to
 185 installSignalHandlers.
 186
 187 \begin{code}
 188 installSignalHandlers :: IO ()
 189 installSignalHandlers = do
 190   let
 191       interrupt_exn = Exception.DynException (toDyn Interrupted)
 192
 193       interrupt = do
 194         withMVar interruptTargetThread $ \targets ->
 195           case targets of
 196            [] -> return ()
 197            (thread:_) -> throwTo thread interrupt_exn
 198   --
 199 #if !defined(mingw32_HOST_OS)
 200   installHandler sigQUIT (Catch interrupt) Nothing
 201   installHandler sigINT  (Catch interrupt) Nothing
 202   return ()
 203 #elif __GLASGOW_HASKELL__ >= 603
 204   -- GHC 6.3+ has support for console events on Windows
 205   -- NOTE: running GHCi under a bash shell for some reason requires
 206   -- you to press Ctrl-Break rather than Ctrl-C to provoke
 207   -- an interrupt.  Ctrl-C is getting blocked somewhere, I don't know
 208   -- why --SDM 17/12/2004
 209   let sig_handler ControlC = interrupt
 210       sig_handler Break    = interrupt
 211       sig_handler _        = return ()
 212
 213   installHandler (Catch sig_handler)
 214   return ()
 215 #else
 216   return () -- nothing
 217 #endif
 218
 219 {-# NOINLINE interruptTargetThread #-}
 220 interruptTargetThread :: MVar [ThreadId]
 221 interruptTargetThread = unsafePerformIO (newMVar [])
 222 \end{code}