Panic.hs 10.3 KB
Newer Older
Austin Seipp's avatar
Austin Seipp committed
1 2 3 4
{-
(c) The University of Glasgow 2006
(c) The GRASP Project, Glasgow University, 1992-2000

5
Defines basic functions for printing error messages.
6 7 8

It's hard to put these functions anywhere else without causing
some unnecessary loops in the module dependency graph.
Austin Seipp's avatar
Austin Seipp committed
9
-}
10

Sylvain HENRY's avatar
Sylvain HENRY committed
11
{-# LANGUAGE CPP, ScopedTypeVariables, LambdaCase #-}
12

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

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

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

Sylvain HENRY's avatar
Sylvain HENRY committed
26
     withSignalHandlers,
27
) where
28 29
#include "HsVersions.h"

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

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

Sylvain HENRY's avatar
Sylvain HENRY committed
35
import Control.Monad.IO.Class
36
import Control.Concurrent
Ian Lynagh's avatar
Ian Lynagh committed
37
import Debug.Trace        ( trace )
38
import System.IO.Unsafe
Simon Marlow's avatar
Simon Marlow committed
39
import System.Environment
40

41
#ifndef mingw32_HOST_OS
Sylvain HENRY's avatar
Sylvain HENRY committed
42
import System.Posix.Signals as S
43 44 45
#endif

#if defined(mingw32_HOST_OS)
Sylvain HENRY's avatar
Sylvain HENRY committed
46
import GHC.ConsoleHandler as S
47
#endif
48

49
import GHC.Stack
50
import System.Mem.Weak  ( deRefWeak )
51 52

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

64
data GhcException
65
  -- | Some other fatal signal (SIGHUP,SIGTERM)
66
  = Signal Int
67 68

  -- | Prints the short usage msg after the error
Ian Lynagh's avatar
Ian Lynagh committed
69
  | UsageError   String
70 71 72 73 74

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

  -- | The 'impossible' happened.
Ian Lynagh's avatar
Ian Lynagh committed
75
  | Panic        String
Ian Lynagh's avatar
Ian Lynagh committed
76
  | PprPanic     String SDoc
77

Ian Lynagh's avatar
Ian Lynagh committed
78
  -- | The user tickled something that's known not to work yet,
79 80
  --   but we're not counting it as a bug.
  | Sorry        String
81
  | PprSorry     String SDoc
82 83 84 85 86

  -- | An installation problem.
  | InstallationError String

  -- | An error in the user's code, probably.
87 88
  | ProgramError    String
  | PprProgramError String SDoc
89

90 91
instance Exception GhcException

92 93 94 95 96 97 98
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
99
progName :: String
100 101 102
progName = unsafePerformIO (getProgName)
{-# NOINLINE progName #-}

103 104

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

108 109

-- | Show an exception as a string.
110 111
showException :: Exception e => e -> String
showException = show
112

113 114 115 116 117 118 119 120 121 122 123 124
-- | 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
125

126
-- | Append a description of the given exception to this string.
Ben Gamari's avatar
Ben Gamari committed
127 128 129 130 131 132
--
-- Note that this uses 'DynFlags.unsafeGlobalDynFlags', which may have some
-- uninitialized fields if invoked before 'GHC.initGhcMonad' has been called.
-- If the error message to be printed includes a pretty-printer document
-- which forces one of these fields this call may bottom.
showGhcException :: GhcException -> ShowS
133 134
showGhcException exception
 = case exception of
Ian Lynagh's avatar
Ian Lynagh committed
135 136 137 138
        UsageError str
         -> showString str . showChar '\n' . showString short_usage

        CmdLineError str        -> showString str
Ben Gamari's avatar
Ben Gamari committed
139 140 141
        PprProgramError str  sdoc  ->
            showString str . showString "\n\n" .
            showString (showSDocUnsafe sdoc)
Ian Lynagh's avatar
Ian Lynagh committed
142 143 144 145
        ProgramError str        -> showString str
        InstallationError str   -> showString str
        Signal n                -> showString "signal: " . shows n

Ben Gamari's avatar
Ben Gamari committed
146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167
        PprPanic  s sdoc ->
            panicMsg $ showString s . showString "\n\n"
                     . showString (showSDocUnsafe sdoc)
        Panic s -> panicMsg (showString s)

        PprSorry  s sdoc ->
            sorryMsg $ showString s . showString "\n\n"
                     . showString (showSDocUnsafe sdoc)
        Sorry s -> sorryMsg (showString s)
  where
    sorryMsg :: ShowS -> ShowS
    sorryMsg s =
        showString "sorry! (unimplemented feature or known bug)\n"
      . showString ("  (GHC version " ++ cProjectVersion ++ " for " ++ TargetPlatform_NAME ++ "):\n\t")
      . s . showString "\n"

    panicMsg :: ShowS -> ShowS
    panicMsg s =
        showString "panic! (the 'impossible' happened)\n"
      . showString ("  (GHC version " ++ cProjectVersion ++ " for " ++ TargetPlatform_NAME ++ "):\n\t")
      . s . showString "\n\n"
      . showString "Please report this as a GHC bug:  http://www.haskell.org/ghc/reportabug\n"
Ian Lynagh's avatar
Ian Lynagh committed
168

169

170 171 172
throwGhcException :: GhcException -> a
throwGhcException = Exception.throw

173 174 175
throwGhcExceptionIO :: GhcException -> IO a
throwGhcExceptionIO = Exception.throwIO

176 177
handleGhcException :: ExceptionMonad m => (GhcException -> m a) -> m a -> m a
handleGhcException = ghandle
178

179 180

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

188
sorry    x = throwGhcException (Sorry x)
189
pgmError x = throwGhcException (ProgramError x)
190

191 192 193 194 195
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)

196

197
-- | Throw an failed assertion exception for a given filename and line number.
198
assertPanic :: String -> Int -> a
Ian Lynagh's avatar
Ian Lynagh committed
199 200
assertPanic file line =
  Exception.throw (Exception.AssertionFailed
201
           ("ASSERT failed! file " ++ file ++ ", line " ++ show line))
202 203


204 205 206
-- | 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
207 208 209
tryMost :: IO a -> IO (Either SomeException a)
tryMost action = do r <- try action
                    case r of
210 211
                        Left se ->
                            case fromException se of
212
                                -- Some GhcException's we rethrow,
213
                                Just (Signal _)  -> throwIO se
214 215 216 217
                                Just (Panic _)   -> throwIO se
                                -- others we return
                                Just _           -> return (Left se)
                                Nothing ->
218
                                    case fromException se of
219 220 221 222 223 224
                                        -- All IOExceptions are returned
                                        Just (_ :: IOException) ->
                                            return (Left se)
                                        -- Anything else is rethrown
                                        Nothing -> throwIO se
                        Right v -> return (Right v)
225

Sylvain HENRY's avatar
Sylvain HENRY committed
226 227 228 229 230 231 232 233 234
-- | We use reference counting for signal handlers
{-# NOINLINE signalHandlersRefCount #-}
#if !defined(mingw32_HOST_OS)
signalHandlersRefCount :: MVar (Word, Maybe (S.Handler,S.Handler
                                            ,S.Handler,S.Handler))
#else
signalHandlersRefCount :: MVar (Word, Maybe S.Handler)
#endif
signalHandlersRefCount = unsafePerformIO $ newMVar (0,Nothing)
235

Sylvain HENRY's avatar
Sylvain HENRY committed
236 237 238 239 240 241 242

-- | Temporarily install standard signal handlers for catching ^C, which just
-- throw an exception in the current thread.
withSignalHandlers :: (ExceptionMonad m, MonadIO m) => m a -> m a
withSignalHandlers act = do
  main_thread <- liftIO myThreadId
  wtid <- liftIO (mkWeakThreadId main_thread)
243

244
  let
245
      interrupt = do
246 247
        r <- deRefWeak wtid
        case r of
248
          Nothing -> return ()
249
          Just t  -> throwTo t UserInterrupt
250

251
#if !defined(mingw32_HOST_OS)
Sylvain HENRY's avatar
Sylvain HENRY committed
252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268
  let installHandlers = do
        let installHandler' a b = installHandler a b Nothing
        hdlQUIT <- installHandler' sigQUIT  (Catch interrupt)
        hdlINT  <- installHandler' sigINT   (Catch interrupt)
        -- see #3656; in the future we should install these automatically for
        -- all Haskell programs in the same way that we install a ^C handler.
        let fatal_signal n = throwTo main_thread (Signal (fromIntegral n))
        hdlHUP  <- installHandler' sigHUP   (Catch (fatal_signal sigHUP))
        hdlTERM <- installHandler' sigTERM  (Catch (fatal_signal sigTERM))
        return (hdlQUIT,hdlINT,hdlHUP,hdlTERM)

  let uninstallHandlers (hdlQUIT,hdlINT,hdlHUP,hdlTERM) = do
        _ <- installHandler sigQUIT  hdlQUIT Nothing
        _ <- installHandler sigINT   hdlINT  Nothing
        _ <- installHandler sigHUP   hdlHUP  Nothing
        _ <- installHandler sigTERM  hdlTERM Nothing
        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 ()

Sylvain HENRY's avatar
Sylvain HENRY committed
279 280
  let installHandlers   = installHandler (Catch sig_handler)
  let uninstallHandlers = installHandler -- directly install the old handler
281
#endif
Sylvain HENRY's avatar
Sylvain HENRY committed
282 283 284 285 286 287 288 289 290 291 292

  -- install signal handlers if necessary
  let mayInstallHandlers = liftIO $ modifyMVar_ signalHandlersRefCount $ \case
        (0,Nothing)     -> do
          hdls <- installHandlers
          return (1,Just hdls)
        (c,oldHandlers) -> return (c+1,oldHandlers)

  -- uninstall handlers if necessary
  let mayUninstallHandlers = liftIO $ modifyMVar_ signalHandlersRefCount $ \case
        (1,Just hdls)   -> do
Tamar Christina's avatar
Tamar Christina committed
293
          _ <- uninstallHandlers hdls
Sylvain HENRY's avatar
Sylvain HENRY committed
294 295 296 297 298
          return (0,Nothing)
        (c,oldHandlers) -> return (c-1,oldHandlers)

  mayInstallHandlers
  act `gfinally` mayUninstallHandlers