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, tryUser, 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 hiding ( try )
  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.throw 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 instance Exception GhcException
  75
  76 progName :: String
  77 progName = unsafePerformIO (getProgName)
  78 {-# NOINLINE progName #-}
  79
  80 short_usage :: String
  81 short_usage = "Usage: For basic information, try the `--help' option."
  82
  83 showException :: Exception e => e -> String
  84 showException = show
  85
  86 instance Show GhcException where
  87   showsPrec _ e@(ProgramError _) = showGhcException e
  88   showsPrec _ e@(CmdLineError _) = showString "<command line>: " . showGhcException e
  89   showsPrec _ e = showString progName . showString ": " . showGhcException e
  90
  91 showGhcException :: GhcException -> String -> String
  92 showGhcException (UsageError str)
  93    = showString str . showChar '\n' . showString short_usage
  94 showGhcException (PhaseFailed phase code)
  95    = showString "phase `" . showString phase .
  96      showString "' failed (exitcode = " . shows int_code .
  97      showString ")"
  98   where
  99     int_code =
 100       case code of
 101         ExitSuccess   -> (0::Int)
 102         ExitFailure x -> x
 103 showGhcException (CmdLineError str)
 104    = showString str
 105 showGhcException (ProgramError str)
 106    = showString str
 107 showGhcException (InstallationError str)
 108    = showString str
 109 showGhcException (Interrupted)
 110    = showString "interrupted"
 111 showGhcException (Panic s)
 112    = showString ("panic! (the 'impossible' happened)\n"
 113                  ++ "  (GHC version " ++ cProjectVersion ++ " for " ++ TargetPlatform_NAME ++ "):\n\t"
 114                  ++ s ++ "\n\n"
 115                  ++ "Please report this as a GHC bug:  http://www.haskell.org/ghc/reportabug\n")
 116
 117 throwGhcException :: GhcException -> a
 118 throwGhcException = Exception.throw
 119
 120 handleGhcException :: ExceptionMonad m => (GhcException -> m a) -> m a -> m a
 121 handleGhcException = ghandle
 122
 123 ghcExceptionTc :: TyCon
 124 ghcExceptionTc = mkTyCon "GhcException"
 125 {-# NOINLINE ghcExceptionTc #-}
 126 instance Typeable GhcException where
 127   typeOf _ = mkTyConApp ghcExceptionTc []
 128 \end{code}
 129
 130 Panics and asserts.
 131
 132 \begin{code}
 133 panic, pgmError :: String -> a
 134 panic    x = throwGhcException (Panic x)
 135 pgmError x = throwGhcException (ProgramError x)
 136
 137 --  #-versions because panic can't return an unboxed int, and that's
 138 -- what TAG_ is with GHC at the moment.  Ugh. (Simon)
 139 -- No, man -- Too Beautiful! (Will)
 140
 141 panicFastInt :: String -> FastInt
 142 panicFastInt s = case (panic s) of () -> _ILIT(0)
 143
 144 assertPanic :: String -> Int -> a
 145 assertPanic file line =
 146   Exception.throw (Exception.AssertionFailed
 147            ("ASSERT failed! file " ++ file ++ ", line " ++ show line))
 148 \end{code}
 149
 150 \begin{code}
 151 -- | tryMost is like try, but passes through Interrupted and Panic
 152 -- exceptions.  Used when we want soft failures when reading interface
 153 -- files, for example.
 154
 155 -- XXX I'm not entirely sure if this is catching what we really want to catch
 156 tryMost :: IO a -> IO (Either SomeException a)
 157 tryMost action = do r <- try action
 158                     case r of
 159                         Left se ->
 160                             case fromException se of
 161                                 -- Some GhcException's we rethrow,
 162                                 Just Interrupted -> throwIO se
 163                                 Just (Panic _)   -> throwIO se
 164                                 -- others we return
 165                                 Just _           -> return (Left se)
 166                                 Nothing ->
 167                                     case fromException se of
 168                                         -- All IOExceptions are returned
 169                                         Just (_ :: IOException) ->
 170                                             return (Left se)
 171                                         -- Anything else is rethrown
 172                                         Nothing -> throwIO se
 173                         Right v -> return (Right v)
 174
 175 -- | tryUser is like try, but catches only UserErrors.
 176 -- These are the ones that are thrown by the TcRn monad
 177 -- to signal an error in the program being compiled
 178 tryUser :: IO a -> IO (Either IOException a)
 179 tryUser io =
 180     do ei <- try io
 181        case ei of
 182            Right v -> return (Right v)
 183            Left se ->
 184                 case fromException se of
 185                    Just ioe
 186                     | isUserError ioe ->
 187                        return (Left ioe)
 188                    _ -> throw se
 189 \end{code}
 190
 191 Standard signal handlers for catching ^C, which just throw an
 192 exception in the target thread.  The current target thread is
 193 the thread at the head of the list in the MVar passed to
 194 installSignalHandlers.
 195
 196 \begin{code}
 197 installSignalHandlers :: IO ()
 198 installSignalHandlers = do
 199   let
 200       interrupt_exn = (toException Interrupted)
 201
 202       interrupt = do
 203         withMVar interruptTargetThread $ \targets ->
 204           case targets of
 205            [] -> return ()
 206            (thread:_) -> throwTo thread interrupt_exn
 207   --
 208 #if !defined(mingw32_HOST_OS)
 209   installHandler sigQUIT (Catch interrupt) Nothing
 210   installHandler sigINT  (Catch interrupt) Nothing
 211   return ()
 212 #else
 213   -- GHC 6.3+ has support for console events on Windows
 214   -- NOTE: running GHCi under a bash shell for some reason requires
 215   -- you to press Ctrl-Break rather than Ctrl-C to provoke
 216   -- an interrupt.  Ctrl-C is getting blocked somewhere, I don't know
 217   -- why --SDM 17/12/2004
 218   let sig_handler ControlC = interrupt
 219       sig_handler Break    = interrupt
 220       sig_handler _        = return ()
 221
 222   installHandler (Catch sig_handler)
 223   return ()
 224 #endif
 225
 226 {-# NOINLINE interruptTargetThread #-}
 227 interruptTargetThread :: MVar [ThreadId]
 228 interruptTargetThread = unsafePerformIO (newMVar [])
 229 \end{code}