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