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