Panic.lhs 10.1 KB
Newer Older
1
%
Simon Marlow's avatar
Simon Marlow committed
2
% (c) The University of Glasgow 2006
3
% (c) The GRASP Project, Glasgow University, 1992-2000
4
%
5
Defines basic functions for printing error messages.
6 7 8 9 10

It's hard to put these functions anywhere else without causing
some unnecessary loops in the module dependency graph.

\begin{code}
11 12
{-# LANGUAGE CPP, DeriveDataTypeable, ScopedTypeVariables #-}

13
module Panic (
14 15 16
     GhcException(..), showGhcException,
     throwGhcException, throwGhcExceptionIO,
     handleGhcException,
17
     progName,
18
     pgmError,
19

20
     panic, sorry, panicFastInt, assertPanic, trace,
21
     panicDoc, sorryDoc, panicDocFastInt, pgmErrorDoc,
Ian Lynagh's avatar
Ian Lynagh committed
22

23
     Exception.Exception(..), showException, safeShowException, try, tryMost, throwTo,
24

25 26
     installSignalHandlers,
     pushInterruptTargetThread, popInterruptTargetThread
27
) where
28 29
#include "HsVersions.h"

Ian Lynagh's avatar
Ian Lynagh committed
30 31
import {-# SOURCE #-} Outputable (SDoc)

32
import Config
33
import FastTypes
34
import Exception
Ian Lynagh's avatar
Ian Lynagh committed
35

36
import Control.Concurrent
Simon Marlow's avatar
Simon Marlow committed
37
import Data.Dynamic
Ian Lynagh's avatar
Ian Lynagh committed
38
import Debug.Trace        ( trace )
39
import System.IO.Unsafe
Simon Marlow's avatar
Simon Marlow committed
40 41
import System.Exit
import System.Environment
42

43 44 45 46 47 48 49
#ifndef mingw32_HOST_OS
import System.Posix.Signals
#endif

#if defined(mingw32_HOST_OS)
import GHC.ConsoleHandler
#endif
50

51
import GHC.Stack
52 53 54
import System.Mem.Weak  ( Weak, deRefWeak )

-- | GHC's own exception type
55
--   error messages all take the form:
56
--
57
--  @
Ian Lynagh's avatar
Ian Lynagh committed
58
--      <location>: <error>
59
--  @
Ian Lynagh's avatar
Ian Lynagh committed
60 61 62
--
--   If the location is on the command line, or in GHC itself, then
--   <location>="ghc".  All of the error types below correspond to
63 64
--   a <location> of "ghc", except for ProgramError (where the string is
--  assumed to contain a location already, so we don't print one).
65

66
data GhcException
Ian Lynagh's avatar
Ian Lynagh committed
67 68
  = PhaseFailed  String         -- name of phase
                 ExitCode       -- an external phase (eg. cpp) failed
69 70

  -- | Some other fatal signal (SIGHUP,SIGTERM)
Ian Lynagh's avatar
Ian Lynagh committed
71
  | Signal Int
72 73

  -- | Prints the short usage msg after the error
Ian Lynagh's avatar
Ian Lynagh committed
74
  | UsageError   String
75 76 77 78 79

  -- | A problem with the command line arguments, but don't print usage.
  | CmdLineError String

  -- | The 'impossible' happened.
Ian Lynagh's avatar
Ian Lynagh committed
80
  | Panic        String
Ian Lynagh's avatar
Ian Lynagh committed
81
  | PprPanic     String SDoc
82

Ian Lynagh's avatar
Ian Lynagh committed
83
  -- | The user tickled something that's known not to work yet,
84 85
  --   but we're not counting it as a bug.
  | Sorry        String
86
  | PprSorry     String SDoc
87 88 89 90 91

  -- | An installation problem.
  | InstallationError String

  -- | An error in the user's code, probably.
92 93
  | ProgramError    String
  | PprProgramError String SDoc
Ian Lynagh's avatar
Ian Lynagh committed
94
  deriving (Typeable)
95

96 97
instance Exception GhcException

98 99 100 101 102 103 104
instance Show GhcException where
  showsPrec _ e@(ProgramError _) = showGhcException e
  showsPrec _ e@(CmdLineError _) = showString "<command line>: " . showGhcException e
  showsPrec _ e = showString progName . showString ": " . showGhcException e


-- | The name of this GHC.
Ian Lynagh's avatar
Ian Lynagh committed
105
progName :: String
106 107 108
progName = unsafePerformIO (getProgName)
{-# NOINLINE progName #-}

109 110

-- | Short usage information to display when we are given the wrong cmd line arguments.
Ian Lynagh's avatar
Ian Lynagh committed
111
short_usage :: String
112
short_usage = "Usage: For basic information, try the `--help' option."
113

114 115

-- | Show an exception as a string.
116 117
showException :: Exception e => e -> String
showException = show
118

119 120 121 122 123 124 125 126 127 128 129 130
-- | Show an exception which can possibly throw other exceptions.
-- Used when displaying exception thrown within TH code.
safeShowException :: Exception e => e -> IO String
safeShowException e = do
    -- ensure the whole error message is evaluated inside try
    r <- try (return $! forceList (showException e))
    case r of
        Right msg -> return msg
        Left e' -> safeShowException (e' :: SomeException)
    where
        forceList [] = []
        forceList xs@(x : xt) = x `seq` forceList xt `seq` xs
131

132
-- | Append a description of the given exception to this string.
Ian Lynagh's avatar
Ian Lynagh committed
133
showGhcException :: GhcException -> String -> String
134 135
showGhcException exception
 = case exception of
Ian Lynagh's avatar
Ian Lynagh committed
136 137 138 139 140 141 142 143 144
        UsageError str
         -> showString str . showChar '\n' . showString short_usage

        PhaseFailed phase code
         -> showString "phase `" . showString phase .
            showString "' failed (exitcode = " . shows (int_code code) .
            showString ")"

        CmdLineError str        -> showString str
145 146
        PprProgramError str  _  ->
            showGhcException (ProgramError (str ++ "\n<<details unavailable>>"))
Ian Lynagh's avatar
Ian Lynagh committed
147 148 149 150
        ProgramError str        -> showString str
        InstallationError str   -> showString str
        Signal n                -> showString "signal: " . shows n

Ian Lynagh's avatar
Ian Lynagh committed
151 152
        PprPanic  s _ ->
            showGhcException (Panic (s ++ "\n<<details unavailable>>"))
Ian Lynagh's avatar
Ian Lynagh committed
153 154 155 156 157 158 159
        Panic s
         -> showString $
                "panic! (the 'impossible' happened)\n"
                ++ "  (GHC version " ++ cProjectVersion ++ " for " ++ TargetPlatform_NAME ++ "):\n\t"
                ++ s ++ "\n\n"
                ++ "Please report this as a GHC bug:  http://www.haskell.org/ghc/reportabug\n"

160 161
        PprSorry  s _ ->
            showGhcException (Sorry (s ++ "\n<<details unavailable>>"))
Ian Lynagh's avatar
Ian Lynagh committed
162 163 164 165 166 167 168 169 170 171
        Sorry s
         -> showString $
                "sorry! (unimplemented feature or known bug)\n"
                 ++ "  (GHC version " ++ cProjectVersion ++ " for " ++ TargetPlatform_NAME ++ "):\n\t"
                 ++ s ++ "\n"

  where int_code code =
          case code of
                ExitSuccess   -> (0::Int)
                ExitFailure x -> x
172 173


174 175 176
throwGhcException :: GhcException -> a
throwGhcException = Exception.throw

177 178 179
throwGhcExceptionIO :: GhcException -> IO a
throwGhcExceptionIO = Exception.throwIO

180 181
handleGhcException :: ExceptionMonad m => (GhcException -> m a) -> m a -> m a
handleGhcException = ghandle
182

183 184

-- | Panics and asserts.
185
panic, sorry, pgmError :: String -> a
186 187 188 189 190 191
panic    x = unsafeDupablePerformIO $ do
   stack <- ccsToStrings =<< getCurrentCCS x
   if null stack
      then throwGhcException (Panic x)
      else throwGhcException (Panic (x ++ '\n' : renderStack stack))

192
sorry    x = throwGhcException (Sorry x)
193
pgmError x = throwGhcException (ProgramError x)
194

195 196 197 198 199
panicDoc, sorryDoc, pgmErrorDoc :: String -> SDoc -> a
panicDoc    x doc = throwGhcException (PprPanic        x doc)
sorryDoc    x doc = throwGhcException (PprSorry        x doc)
pgmErrorDoc x doc = throwGhcException (PprProgramError x doc)

200

201 202 203
-- | Panic while pretending to return an unboxed int.
--   You can't use the regular panic functions in expressions
--   producing unboxed ints because they have the wrong kind.
204 205
panicFastInt :: String -> FastInt
panicFastInt s = case (panic s) of () -> _ILIT(0)
206

207 208 209
panicDocFastInt :: String -> SDoc -> FastInt
panicDocFastInt s d = case (panicDoc s d) of () -> _ILIT(0)

210 211

-- | Throw an failed assertion exception for a given filename and line number.
212
assertPanic :: String -> Int -> a
Ian Lynagh's avatar
Ian Lynagh committed
213 214
assertPanic file line =
  Exception.throw (Exception.AssertionFailed
215
           ("ASSERT failed! file " ++ file ++ ", line " ++ show line))
216 217


218 219 220
-- | Like try, but pass through UserInterrupt and Panic exceptions.
--   Used when we want soft failures when reading interface files, for example.
--   TODO: I'm not entirely sure if this is catching what we really want to catch
221 222 223
tryMost :: IO a -> IO (Either SomeException a)
tryMost action = do r <- try action
                    case r of
224 225
                        Left se ->
                            case fromException se of
226
                                -- Some GhcException's we rethrow,
227
                                Just (Signal _)  -> throwIO se
228 229 230 231
                                Just (Panic _)   -> throwIO se
                                -- others we return
                                Just _           -> return (Left se)
                                Nothing ->
232
                                    case fromException se of
233 234 235 236 237 238
                                        -- All IOExceptions are returned
                                        Just (_ :: IOException) ->
                                            return (Left se)
                                        -- Anything else is rethrown
                                        Nothing -> throwIO se
                        Right v -> return (Right v)
239

240

241 242 243 244
-- | Install standard signal handlers for catching ^C, which just throw an
--   exception in the target thread.  The current target thread is the
--   thread at the head of the list in the MVar passed to
--   installSignalHandlers.
245 246
installSignalHandlers :: IO ()
installSignalHandlers = do
247
  main_thread <- myThreadId
248
  pushInterruptTargetThread main_thread
249

250
  let
251
      interrupt_exn = (toException UserInterrupt)
252 253

      interrupt = do
254
        mt <- peekInterruptTargetThread
255 256 257
        case mt of
          Nothing -> return ()
          Just t  -> throwTo t interrupt_exn
258

259 260
  --
#if !defined(mingw32_HOST_OS)
Ian Lynagh's avatar
Ian Lynagh committed
261
  _ <- installHandler sigQUIT  (Catch interrupt) Nothing
262 263 264
  _ <- installHandler sigINT   (Catch interrupt) Nothing
  -- see #3656; in the future we should install these automatically for
  -- all Haskell programs in the same way that we install a ^C handler.
Simon Marlow's avatar
Simon Marlow committed
265
  let fatal_signal n = throwTo main_thread (Signal (fromIntegral n))
266 267
  _ <- installHandler sigHUP   (Catch (fatal_signal sigHUP))  Nothing
  _ <- installHandler sigTERM  (Catch (fatal_signal sigTERM)) Nothing
268
  return ()
269
#else
270
  -- GHC 6.3+ has support for console events on Windows
271 272 273 274
  -- NOTE: running GHCi under a bash shell for some reason requires
  -- you to press Ctrl-Break rather than Ctrl-C to provoke
  -- an interrupt.  Ctrl-C is getting blocked somewhere, I don't know
  -- why --SDM 17/12/2004
275 276 277 278
  let sig_handler ControlC = interrupt
      sig_handler Break    = interrupt
      sig_handler _        = return ()

279
  _ <- installHandler (Catch sig_handler)
280
  return ()
281
#endif
282

283 284 285 286 287 288 289
{-# NOINLINE interruptTargetThread #-}
interruptTargetThread :: MVar [Weak ThreadId]
interruptTargetThread = unsafePerformIO (newMVar [])

pushInterruptTargetThread :: ThreadId -> IO ()
pushInterruptTargetThread tid = do
 wtid <- mkWeakThreadId tid
290
 modifyMVar_ interruptTargetThread $ return . (wtid :)
291

292 293 294
peekInterruptTargetThread :: IO (Maybe ThreadId)
peekInterruptTargetThread =
  withMVar interruptTargetThread $ loop
295
 where
296
   loop [] = return Nothing
297 298 299 300
   loop (t:ts) = do
     r <- deRefWeak t
     case r of
       Nothing -> loop ts
301 302 303 304 305 306
       Just t  -> return (Just t)

popInterruptTargetThread :: IO ()
popInterruptTargetThread =
  modifyMVar_ interruptTargetThread $
   \tids -> return $! case tids of []     -> []
Ian Lynagh's avatar
Ian Lynagh committed
307
                                   (_:ts) -> ts
308

309
\end{code}