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, sorry, 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, modifyMVar_,
  40                             myThreadId )
  41 import Data.Dynamic
  42 import Debug.Trace      ( trace )
  43 import System.IO.Unsafe ( unsafePerformIO )
  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   | Signal Int                  -- some other fatal signal (SIGHUP,SIGTERM)
  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   | Sorry        String         -- the user tickled something that's known not to work yet,
  71                                 -- and we're not counting it as a bug.
  72   | InstallationError String    -- an installation problem
  73   | ProgramError String         -- error in the user's code, probably
  74   deriving Eq
  75
  76 instance Exception GhcException
  77
  78 progName :: String
  79 progName = unsafePerformIO (getProgName)
  80 {-# NOINLINE progName #-}
  81
  82 short_usage :: String
  83 short_usage = "Usage: For basic information, try the `--help' option."
  84
  85 showException :: Exception e => e -> String
  86 showException = show
  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 (Signal n)
 112    = showString "signal: " . shows n
 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 showGhcException (Sorry s)
 119    = showString ("sorry! (this is work in progress)\n"
 120                  ++ "  (GHC version " ++ cProjectVersion ++ " for " ++ TargetPlatform_NAME ++ "):\n\t"
 121                  ++ s ++ "\n")
 122
 123
 124 throwGhcException :: GhcException -> a
 125 throwGhcException = Exception.throw
 126
 127 handleGhcException :: ExceptionMonad m => (GhcException -> m a) -> m a -> m a
 128 handleGhcException = ghandle
 129
 130 ghcExceptionTc :: TyCon
 131 ghcExceptionTc = mkTyCon "GhcException"
 132 {-# NOINLINE ghcExceptionTc #-}
 133 instance Typeable GhcException where
 134   typeOf _ = mkTyConApp ghcExceptionTc []
 135 \end{code}
 136
 137 Panics and asserts.
 138
 139 \begin{code}
 140 panic, sorry, pgmError :: String -> a
 141 panic    x = throwGhcException (Panic x)
 142 sorry    x = throwGhcException (Sorry x)
 143 pgmError x = throwGhcException (ProgramError x)
 144
 145 --  #-versions because panic can't return an unboxed int, and that's
 146 -- what TAG_ is with GHC at the moment.  Ugh. (Simon)
 147 -- No, man -- Too Beautiful! (Will)
 148
 149 panicFastInt :: String -> FastInt
 150 panicFastInt s = case (panic s) of () -> _ILIT(0)
 151
 152 assertPanic :: String -> Int -> a
 153 assertPanic file line =
 154   Exception.throw (Exception.AssertionFailed
 155            ("ASSERT failed! file " ++ file ++ ", line " ++ show line))
 156 \end{code}
 157
 158 \begin{code}
 159 -- | tryMost is like try, but passes through UserInterrupt and Panic
 160 -- exceptions.  Used when we want soft failures when reading interface
 161 -- files, for example.
 162
 163 -- XXX I'm not entirely sure if this is catching what we really want to catch
 164 tryMost :: IO a -> IO (Either SomeException a)
 165 tryMost action = do r <- try action
 166                     case r of
 167                         Left se ->
 168                             case fromException se of
 169                                 -- Some GhcException's we rethrow,
 170                                 Just (Signal _)  -> throwIO se
 171                                 Just (Panic _)   -> throwIO se
 172                                 -- others we return
 173                                 Just _           -> return (Left se)
 174                                 Nothing ->
 175                                     case fromException se of
 176                                         -- All IOExceptions are returned
 177                                         Just (_ :: IOException) ->
 178                                             return (Left se)
 179                                         -- Anything else is rethrown
 180                                         Nothing -> throwIO se
 181                         Right v -> return (Right v)
 182 \end{code}
 183
 184 Standard signal handlers for catching ^C, which just throw an
 185 exception in the target thread.  The current target thread is
 186 the thread at the head of the list in the MVar passed to
 187 installSignalHandlers.
 188
 189 \begin{code}
 190 installSignalHandlers :: IO ()
 191 installSignalHandlers = do
 192   main_thread <- myThreadId
 193   modifyMVar_ interruptTargetThread (return . (main_thread :))
 194
 195   let
 196       interrupt_exn = (toException UserInterrupt)
 197
 198       interrupt = do
 199         withMVar interruptTargetThread $ \targets ->
 200           case targets of
 201            [] -> return ()
 202            (thread:_) -> throwTo thread interrupt_exn
 203
 204   --
 205 #if !defined(mingw32_HOST_OS)
 206   _ <- installHandler sigQUIT  (Catch interrupt) Nothing
 207   _ <- installHandler sigINT   (Catch interrupt) Nothing
 208   -- see #3656; in the future we should install these automatically for
 209   -- all Haskell programs in the same way that we install a ^C handler.
 210   let fatal_signal n = throwTo main_thread (Signal (fromIntegral n))
 211   _ <- installHandler sigHUP   (Catch (fatal_signal sigHUP))  Nothing
 212   _ <- installHandler sigTERM  (Catch (fatal_signal sigTERM)) Nothing
 213   return ()
 214 #else
 215   -- GHC 6.3+ has support for console events on Windows
 216   -- NOTE: running GHCi under a bash shell for some reason requires
 217   -- you to press Ctrl-Break rather than Ctrl-C to provoke
 218   -- an interrupt.  Ctrl-C is getting blocked somewhere, I don't know
 219   -- why --SDM 17/12/2004
 220   let sig_handler ControlC = interrupt
 221       sig_handler Break    = interrupt
 222       sig_handler _        = return ()
 223
 224   _ <- installHandler (Catch sig_handler)
 225   return ()
 226 #endif
 227
 228 {-# NOINLINE interruptTargetThread #-}
 229 interruptTargetThread :: MVar [ThreadId]
 230 interruptTargetThread = unsafePerformIO (newMVar [])
 231 \end{code}