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 #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)
  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 :: String
  76 progName = unsafePerformIO (getProgName)
  77 {-# NOINLINE progName #-}
  78
  79 short_usage :: String
  80 short_usage = "Usage: For basic information, try the `--help' option."
  81
  82 showException :: Exception.Exception -> String
  83 -- Show expected dynamic exceptions specially
  84 showException (Exception.DynException d) | Just e <- fromDynamic d
  85                                          = show (e::GhcException)
  86 showException other_exn                  = show other_exn
  87
  88 instance Show GhcException where
  89   showsPrec _ e@(ProgramError _) = showGhcException e
  90   showsPrec _ e@(CmdLineError _) = showString "<command line>: " . showGhcException e
  91   showsPrec _ e = showString progName . showString ": " . showGhcException e
  92
  93 showGhcException :: GhcException -> String -> String
  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 ghcExceptionTc :: TyCon
 120 ghcExceptionTc = mkTyCon "GhcException"
 121 {-# NOINLINE ghcExceptionTc #-}
 122 instance Typeable GhcException where
 123   typeOf _ = mkTyConApp ghcExceptionTc []
 124 \end{code}
 125
 126 Panics and asserts.
 127
 128 \begin{code}
 129 panic, pgmError :: String -> a
 130 panic    x = Exception.throwDyn (Panic x)
 131 pgmError x = Exception.throwDyn (ProgramError x)
 132
 133 --  #-versions because panic can't return an unboxed int, and that's
 134 -- what TAG_ is with GHC at the moment.  Ugh. (Simon)
 135 -- No, man -- Too Beautiful! (Will)
 136
 137 panicFastInt :: String -> FastInt
 138 panicFastInt s = case (panic s) of () -> _ILIT(0)
 139
 140 assertPanic :: String -> Int -> a
 141 assertPanic file line =
 142   Exception.throw (Exception.AssertionFailed
 143            ("ASSERT failed! file " ++ file ++ ", line " ++ show line))
 144 \end{code}
 145
 146 \begin{code}
 147 -- | tryMost is like try, but passes through Interrupted and Panic
 148 -- exceptions.  Used when we want soft failures when reading interface
 149 -- files, for example.
 150
 151 tryMost :: IO a -> IO (Either Exception.Exception a)
 152 tryMost action = do r <- try action; filter r
 153   where
 154    filter (Left e@(Exception.DynException d))
 155             | Just ghc_ex <- fromDynamic d
 156                 = case ghc_ex of
 157                     Interrupted -> Exception.throw e
 158                     Panic _     -> Exception.throw e
 159                     _other      -> return (Left e)
 160    filter other
 161      = return other
 162
 163 -- | tryUser is like try, but catches only UserErrors.
 164 -- These are the ones that are thrown by the TcRn monad
 165 -- to signal an error in the program being compiled
 166 tryUser :: IO a -> IO (Either Exception.Exception a)
 167 tryUser action = tryJust tc_errors action
 168   where
 169         tc_errors e@(Exception.IOException ioe) | isUserError ioe = Just e
 170         tc_errors _other = Nothing
 171 \end{code}
 172
 173 Standard signal handlers for catching ^C, which just throw an
 174 exception in the target thread.  The current target thread is
 175 the thread at the head of the list in the MVar passed to
 176 installSignalHandlers.
 177
 178 \begin{code}
 179 installSignalHandlers :: IO ()
 180 installSignalHandlers = do
 181   let
 182       interrupt_exn = Exception.DynException (toDyn Interrupted)
 183
 184       interrupt = do
 185         withMVar interruptTargetThread $ \targets ->
 186           case targets of
 187            [] -> return ()
 188            (thread:_) -> throwTo thread interrupt_exn
 189   --
 190 #if !defined(mingw32_HOST_OS)
 191   installHandler sigQUIT (Catch interrupt) Nothing
 192   installHandler sigINT  (Catch interrupt) Nothing
 193   return ()
 194 #else
 195   -- GHC 6.3+ has support for console events on Windows
 196   -- NOTE: running GHCi under a bash shell for some reason requires
 197   -- you to press Ctrl-Break rather than Ctrl-C to provoke
 198   -- an interrupt.  Ctrl-C is getting blocked somewhere, I don't know
 199   -- why --SDM 17/12/2004
 200   let sig_handler ControlC = interrupt
 201       sig_handler Break    = interrupt
 202       sig_handler _        = return ()
 203
 204   installHandler (Catch sig_handler)
 205   return ()
 206 #endif
 207
 208 {-# NOINLINE interruptTargetThread #-}
 209 interruptTargetThread :: MVar [ThreadId]
 210 interruptTargetThread = unsafePerformIO (newMVar [])
 211 \end{code}