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, tryJust, tryMost, tryUser,
  21      catchJust, throwTo,
  22
  23      installSignalHandlers, interruptTargetThread
  24    ) where
  25
  26 #include "HsVersions.h"
  27
  28 import Config
  29 import FastTypes
  30
  31 #ifndef mingw32_HOST_OS
  32 import System.Posix.Signals
  33 #endif /* mingw32_HOST_OS */
  34
  35 #if defined(mingw32_HOST_OS)
  36 import GHC.ConsoleHandler
  37 #endif
  38
  39 import Exception
  40 import Control.Concurrent ( MVar, ThreadId, withMVar, newMVar )
  41 import Data.Dynamic
  42 import Debug.Trace      ( trace )
  43 import System.IO.Unsafe ( unsafePerformIO )
  44 import System.IO.Error hiding ( try )
  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 #if __GLASGOW_HASKELL__ >= 609
  54 ghcError e = Exception.throw e
  55 #else
  56 ghcError e = Exception.throwDyn e
  57 #endif
  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 #if __GLASGOW_HASKELL__ >= 609
  80 instance Exception GhcException
  81 #endif
  82
  83 progName :: String
  84 progName = unsafePerformIO (getProgName)
  85 {-# NOINLINE progName #-}
  86
  87 short_usage :: String
  88 short_usage = "Usage: For basic information, try the `--help' option."
  89
  90 #if __GLASGOW_HASKELL__ < 609
  91 showException :: Exception.Exception -> String
  92 -- Show expected dynamic exceptions specially
  93 showException (Exception.DynException d) | Just e <- fromDynamic d
  94                                          = show (e::GhcException)
  95 showException other_exn                  = show other_exn
  96 #else
  97 showException :: Exception e => e -> String
  98 showException = show
  99 #endif
 100
 101 instance Show GhcException where
 102   showsPrec _ e@(ProgramError _) = showGhcException e
 103   showsPrec _ e@(CmdLineError _) = showString "<command line>: " . showGhcException e
 104   showsPrec _ e = showString progName . showString ": " . showGhcException e
 105
 106 showGhcException :: GhcException -> String -> String
 107 showGhcException (UsageError str)
 108    = showString str . showChar '\n' . showString short_usage
 109 showGhcException (PhaseFailed phase code)
 110    = showString "phase `" . showString phase .
 111      showString "' failed (exitcode = " . shows int_code .
 112      showString ")"
 113   where
 114     int_code =
 115       case code of
 116         ExitSuccess   -> (0::Int)
 117         ExitFailure x -> x
 118 showGhcException (CmdLineError str)
 119    = showString str
 120 showGhcException (ProgramError str)
 121    = showString str
 122 showGhcException (InstallationError str)
 123    = showString str
 124 showGhcException (Interrupted)
 125    = showString "interrupted"
 126 showGhcException (Panic s)
 127    = showString ("panic! (the 'impossible' happened)\n"
 128                  ++ "  (GHC version " ++ cProjectVersion ++ " for " ++ TargetPlatform_NAME ++ "):\n\t"
 129                  ++ s ++ "\n\n"
 130                  ++ "Please report this as a GHC bug:  http://www.haskell.org/ghc/reportabug\n")
 131
 132 throwGhcException :: GhcException -> a
 133 #if __GLASGOW_HASKELL__ < 609
 134 throwGhcException = Exception.throwDyn
 135 #else
 136 throwGhcException = Exception.throw
 137 #endif
 138
 139 handleGhcException :: ExceptionMonad m => (GhcException -> m a) -> m a -> m a
 140 #if __GLASGOW_HASKELL__ < 609
 141 handleGhcException = flip gcatchDyn
 142 #else
 143 handleGhcException = ghandle
 144 #endif
 145
 146 ghcExceptionTc :: TyCon
 147 ghcExceptionTc = mkTyCon "GhcException"
 148 {-# NOINLINE ghcExceptionTc #-}
 149 instance Typeable GhcException where
 150   typeOf _ = mkTyConApp ghcExceptionTc []
 151 \end{code}
 152
 153 Panics and asserts.
 154
 155 \begin{code}
 156 panic, pgmError :: String -> a
 157 panic    x = throwGhcException (Panic x)
 158 pgmError x = throwGhcException (ProgramError x)
 159
 160 --  #-versions because panic can't return an unboxed int, and that's
 161 -- what TAG_ is with GHC at the moment.  Ugh. (Simon)
 162 -- No, man -- Too Beautiful! (Will)
 163
 164 panicFastInt :: String -> FastInt
 165 panicFastInt s = case (panic s) of () -> _ILIT(0)
 166
 167 assertPanic :: String -> Int -> a
 168 assertPanic file line =
 169   Exception.throw (Exception.AssertionFailed
 170            ("ASSERT failed! file " ++ file ++ ", line " ++ show line))
 171 \end{code}
 172
 173 \begin{code}
 174 -- | tryMost is like try, but passes through Interrupted and Panic
 175 -- exceptions.  Used when we want soft failures when reading interface
 176 -- files, for example.
 177
 178 #if __GLASGOW_HASKELL__ < 609
 179 tryMost :: IO a -> IO (Either Exception.Exception a)
 180 tryMost action = do r <- try action; filter r
 181   where
 182    filter (Left e@(Exception.DynException d))
 183             | Just ghc_ex <- fromDynamic d
 184                 = case ghc_ex of
 185                     Interrupted -> Exception.throw e
 186                     Panic _     -> Exception.throw e
 187                     _other      -> return (Left e)
 188    filter other
 189      = return other
 190 #else
 191 -- XXX I'm not entirely sure if this is catching what we really want to catch
 192 tryMost :: IO a -> IO (Either SomeException a)
 193 tryMost action = do r <- try action
 194                     case r of
 195                         Left se@(SomeException e) ->
 196                             case cast e of
 197                                 -- Some GhcException's we rethrow,
 198                                 Just Interrupted -> throwIO se
 199                                 Just (Panic _)   -> throwIO se
 200                                 -- others we return
 201                                 Just _           -> return (Left se)
 202                                 Nothing ->
 203                                     case cast e of
 204                                         -- All IOExceptions are returned
 205                                         Just (_ :: IOException) ->
 206                                             return (Left se)
 207                                         -- Anything else is rethrown
 208                                         Nothing -> throwIO se
 209                         Right v -> return (Right v)
 210 #endif
 211
 212 -- | tryUser is like try, but catches only UserErrors.
 213 -- These are the ones that are thrown by the TcRn monad
 214 -- to signal an error in the program being compiled
 215 #if __GLASGOW_HASKELL__ < 609
 216 tryUser :: IO a -> IO (Either Exception.Exception a)
 217 tryUser action = tryJust tc_errors action
 218   where
 219         tc_errors e@(Exception.IOException ioe) | isUserError ioe = Just e
 220         tc_errors _other = Nothing
 221 #else
 222 tryUser :: IO a -> IO (Either IOException a)
 223 tryUser io =
 224     do ei <- try io
 225        case ei of
 226            Right v -> return (Right v)
 227            Left se@(SomeException ex) ->
 228                 case cast ex of
 229                    Just ioe
 230                     | isUserError ioe ->
 231                        return (Left ioe)
 232                    _ -> throw se
 233 #endif
 234 \end{code}
 235
 236 Standard signal handlers for catching ^C, which just throw an
 237 exception in the target thread.  The current target thread is
 238 the thread at the head of the list in the MVar passed to
 239 installSignalHandlers.
 240
 241 \begin{code}
 242 installSignalHandlers :: IO ()
 243 installSignalHandlers = do
 244   let
 245 #if __GLASGOW_HASKELL__ < 609
 246       interrupt_exn = Exception.DynException (toDyn Interrupted)
 247 #else
 248       interrupt_exn = (toException Interrupted)
 249 #endif
 250
 251       interrupt = do
 252         withMVar interruptTargetThread $ \targets ->
 253           case targets of
 254            [] -> return ()
 255            (thread:_) -> throwTo thread interrupt_exn
 256   --
 257 #if !defined(mingw32_HOST_OS)
 258   installHandler sigQUIT (Catch interrupt) Nothing
 259   installHandler sigINT  (Catch interrupt) Nothing
 260   return ()
 261 #else
 262   -- GHC 6.3+ has support for console events on Windows
 263   -- NOTE: running GHCi under a bash shell for some reason requires
 264   -- you to press Ctrl-Break rather than Ctrl-C to provoke
 265   -- an interrupt.  Ctrl-C is getting blocked somewhere, I don't know
 266   -- why --SDM 17/12/2004
 267   let sig_handler ControlC = interrupt
 268       sig_handler Break    = interrupt
 269       sig_handler _        = return ()
 270
 271   installHandler (Catch sig_handler)
 272   return ()
 273 #endif
 274
 275 {-# NOINLINE interruptTargetThread #-}
 276 interruptTargetThread :: MVar [ThreadId]
 277 interruptTargetThread = unsafePerformIO (newMVar [])
 278 \end{code}