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