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, panicFastInt, assertPanic, trace,
  18
  19      Exception.Exception(..), showException, try, tryJust, tryMost, tryUser,
  20      catchJust, ioErrors, throwTo,
  21
  22      installSignalHandlers, interruptTargetThread
  23    ) where
  24
  25 -- XXX This define is a bit of a hack, and should be done more nicely
  26 #define FAST_STRING_NOT_NEEDED 1
  27 #include "HsVersions.h"
  28
  29 import Config
  30 import FastTypes
  31
  32 #ifndef mingw32_HOST_OS
  33 import System.Posix.Signals
  34 #endif /* mingw32_HOST_OS */
  35
  36 #if defined(mingw32_HOST_OS) && __GLASGOW_HASKELL__ >= 603
  37 import GHC.ConsoleHandler
  38 #endif
  39
  40 import Control.Exception
  41 import Control.Concurrent ( MVar, ThreadId, withMVar, newMVar )
  42 import Data.Dynamic
  43 import qualified Control.Exception as Exception
  44 import Debug.Trace      ( trace )
  45 import System.IO.Unsafe ( unsafePerformIO )
  46 import System.IO.Error  ( isUserError )
  47 import System.Exit
  48 import System.Environment
  49 \end{code}
  50
  51 GHC's own exception type.
  52
  53 \begin{code}
  54 ghcError :: GhcException -> a
  55 ghcError e = Exception.throwDyn e
  56
  57 -- error messages all take the form
  58 --
  59 --      <location>: <error>
  60 --
  61 -- If the location is on the command line, or in GHC itself, then
  62 -- <location>="ghc".  All of the error types below correspond to
  63 -- a <location> of "ghc", except for ProgramError (where the string is
  64 -- assumed to contain a location already, so we don't print one).
  65
  66 data GhcException
  67   = PhaseFailed String          -- name of phase
  68                 ExitCode        -- an external phase (eg. cpp) failed
  69   | Interrupted                 -- someone pressed ^C
  70   | UsageError String           -- prints the short usage msg after the error
  71   | CmdLineError String         -- cmdline prob, but doesn't print usage
  72   | Panic String                -- the `impossible' happened
  73   | InstallationError String    -- an installation problem
  74   | ProgramError String         -- error in the user's code, probably
  75   deriving Eq
  76
  77 progName :: String
  78 progName = unsafePerformIO (getProgName)
  79 {-# NOINLINE progName #-}
  80
  81 short_usage :: String
  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@(CmdLineError _) = showString "<command line>: " . showGhcException e
  93   showsPrec _ e = showString progName . showString ": " . showGhcException e
  94
  95 showGhcException :: GhcException -> String -> String
  96 showGhcException (UsageError str)
  97    = showString str . showChar '\n' . showString short_usage
  98 showGhcException (PhaseFailed phase code)
  99    = showString "phase `" . showString phase .
 100      showString "' failed (exitcode = " . shows int_code .
 101      showString ")"
 102   where
 103     int_code =
 104       case code of
 105         ExitSuccess   -> (0::Int)
 106         ExitFailure x -> x
 107 showGhcException (CmdLineError str)
 108    = showString str
 109 showGhcException (ProgramError str)
 110    = showString str
 111 showGhcException (InstallationError str)
 112    = showString str
 113 showGhcException (Interrupted)
 114    = showString "interrupted"
 115 showGhcException (Panic s)
 116    = showString ("panic! (the 'impossible' happened)\n"
 117                  ++ "  (GHC version " ++ cProjectVersion ++ " for " ++ TargetPlatform_NAME ++ "):\n\t"
 118                  ++ s ++ "\n\n"
 119                  ++ "Please report this as a GHC bug:  http://www.haskell.org/ghc/reportabug\n")
 120
 121 myMkTyConApp :: TyCon -> [TypeRep] -> TypeRep
 122 #if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ < 603
 123 myMkTyConApp = mkAppTy
 124 #else
 125 myMkTyConApp = mkTyConApp
 126 #endif
 127
 128 ghcExceptionTc :: TyCon
 129 ghcExceptionTc = mkTyCon "GhcException"
 130 {-# NOINLINE ghcExceptionTc #-}
 131 instance Typeable GhcException where
 132   typeOf _ = myMkTyConApp ghcExceptionTc []
 133 \end{code}
 134
 135 Panics and asserts.
 136
 137 \begin{code}
 138 panic, pgmError :: String -> a
 139 panic    x = Exception.throwDyn (Panic x)
 140 pgmError x = Exception.throwDyn (ProgramError x)
 141
 142 --  #-versions because panic can't return an unboxed int, and that's
 143 -- what TAG_ is with GHC at the moment.  Ugh. (Simon)
 144 -- No, man -- Too Beautiful! (Will)
 145
 146 panicFastInt :: String -> FastInt
 147 panicFastInt s = case (panic s) of () -> _ILIT(0)
 148
 149 assertPanic :: String -> Int -> a
 150 assertPanic file line =
 151   Exception.throw (Exception.AssertionFailed
 152            ("ASSERT failed! file " ++ file ++ ", line " ++ show line))
 153 \end{code}
 154
 155 \begin{code}
 156 -- | tryMost is like try, but passes through Interrupted and Panic
 157 -- exceptions.  Used when we want soft failures when reading interface
 158 -- files, for example.
 159
 160 tryMost :: IO a -> IO (Either Exception.Exception a)
 161 tryMost action = do r <- try action; filter r
 162   where
 163    filter (Left e@(Exception.DynException d))
 164             | Just ghc_ex <- fromDynamic d
 165                 = case ghc_ex of
 166                     Interrupted -> Exception.throw e
 167                     Panic _     -> Exception.throw e
 168                     _other      -> return (Left e)
 169    filter other
 170      = return other
 171
 172 -- | tryUser is like try, but catches only UserErrors.
 173 -- These are the ones that are thrown by the TcRn monad
 174 -- to signal an error in the program being compiled
 175 tryUser :: IO a -> IO (Either Exception.Exception a)
 176 tryUser action = tryJust tc_errors action
 177   where
 178         tc_errors e@(Exception.IOException ioe) | isUserError ioe = Just e
 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}