e1c848d5402a2fba750afde3ef9f96579f895562
[ghc.git] / compiler / utils / Panic.hs
1 {-
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 It's hard to put these functions anywhere else without causing
8 some unnecessary loops in the module dependency graph.
9 -}
10
11 {-# LANGUAGE CPP, DeriveDataTypeable, ScopedTypeVariables #-}
12
13 module Panic (
14 GhcException(..), showGhcException,
15 throwGhcException, throwGhcExceptionIO,
16 handleGhcException,
17 progName,
18 pgmError,
19
20 panic, sorry, assertPanic, trace,
21 panicDoc, sorryDoc, pgmErrorDoc,
22
23 Exception.Exception(..), showException, safeShowException, try, tryMost, throwTo,
24
25 installSignalHandlers,
26 pushInterruptTargetThread, popInterruptTargetThread
27 ) where
28 #include "HsVersions.h"
29
30 import {-# SOURCE #-} Outputable (SDoc)
31
32 import Config
33 import Exception
34
35 import Control.Concurrent
36 import Data.Dynamic
37 import Debug.Trace ( trace )
38 import System.IO.Unsafe
39 import System.Exit
40 import System.Environment
41
42 #ifndef mingw32_HOST_OS
43 import System.Posix.Signals
44 #endif
45
46 #if defined(mingw32_HOST_OS)
47 import GHC.ConsoleHandler
48 #endif
49
50 import GHC.Stack
51 import System.Mem.Weak ( Weak, deRefWeak )
52
53 -- | GHC's own exception type
54 -- error messages all take the form:
55 --
56 -- @
57 -- <location>: <error>
58 -- @
59 --
60 -- If the location is on the command line, or in GHC itself, then
61 -- <location>="ghc". All of the error types below correspond to
62 -- a <location> of "ghc", except for ProgramError (where the string is
63 -- assumed to contain a location already, so we don't print one).
64
65 data GhcException
66 = PhaseFailed String -- name of phase
67 ExitCode -- an external phase (eg. cpp) failed
68
69 -- | Some other fatal signal (SIGHUP,SIGTERM)
70 | Signal Int
71
72 -- | Prints the short usage msg after the error
73 | UsageError String
74
75 -- | A problem with the command line arguments, but don't print usage.
76 | CmdLineError String
77
78 -- | The 'impossible' happened.
79 | Panic String
80 | PprPanic String SDoc
81
82 -- | The user tickled something that's known not to work yet,
83 -- but we're not counting it as a bug.
84 | Sorry String
85 | PprSorry String SDoc
86
87 -- | An installation problem.
88 | InstallationError String
89
90 -- | An error in the user's code, probably.
91 | ProgramError String
92 | PprProgramError String SDoc
93 deriving (Typeable)
94
95 instance Exception GhcException
96
97 instance Show GhcException where
98 showsPrec _ e@(ProgramError _) = showGhcException e
99 showsPrec _ e@(CmdLineError _) = showString "<command line>: " . showGhcException e
100 showsPrec _ e = showString progName . showString ": " . showGhcException e
101
102
103 -- | The name of this GHC.
104 progName :: String
105 progName = unsafePerformIO (getProgName)
106 {-# NOINLINE progName #-}
107
108
109 -- | Short usage information to display when we are given the wrong cmd line arguments.
110 short_usage :: String
111 short_usage = "Usage: For basic information, try the `--help' option."
112
113
114 -- | Show an exception as a string.
115 showException :: Exception e => e -> String
116 showException = show
117
118 -- | Show an exception which can possibly throw other exceptions.
119 -- Used when displaying exception thrown within TH code.
120 safeShowException :: Exception e => e -> IO String
121 safeShowException e = do
122 -- ensure the whole error message is evaluated inside try
123 r <- try (return $! forceList (showException e))
124 case r of
125 Right msg -> return msg
126 Left e' -> safeShowException (e' :: SomeException)
127 where
128 forceList [] = []
129 forceList xs@(x : xt) = x `seq` forceList xt `seq` xs
130
131 -- | Append a description of the given exception to this string.
132 showGhcException :: GhcException -> String -> String
133 showGhcException exception
134 = case exception of
135 UsageError str
136 -> showString str . showChar '\n' . showString short_usage
137
138 PhaseFailed phase code
139 -> showString "phase `" . showString phase .
140 showString "' failed (exitcode = " . shows (int_code code) .
141 showString ")"
142
143 CmdLineError str -> showString str
144 PprProgramError str _ ->
145 showGhcException (ProgramError (str ++ "\n<<details unavailable>>"))
146 ProgramError str -> showString str
147 InstallationError str -> showString str
148 Signal n -> showString "signal: " . shows n
149
150 PprPanic s _ ->
151 showGhcException (Panic (s ++ "\n<<details unavailable>>"))
152 Panic s
153 -> showString $
154 "panic! (the 'impossible' happened)\n"
155 ++ " (GHC version " ++ cProjectVersion ++ " for " ++ TargetPlatform_NAME ++ "):\n\t"
156 ++ s ++ "\n\n"
157 ++ "Please report this as a GHC bug: http://www.haskell.org/ghc/reportabug\n"
158
159 PprSorry s _ ->
160 showGhcException (Sorry (s ++ "\n<<details unavailable>>"))
161 Sorry s
162 -> showString $
163 "sorry! (unimplemented feature or known bug)\n"
164 ++ " (GHC version " ++ cProjectVersion ++ " for " ++ TargetPlatform_NAME ++ "):\n\t"
165 ++ s ++ "\n"
166
167 where int_code code =
168 case code of
169 ExitSuccess -> (0::Int)
170 ExitFailure x -> x
171
172
173 throwGhcException :: GhcException -> a
174 throwGhcException = Exception.throw
175
176 throwGhcExceptionIO :: GhcException -> IO a
177 throwGhcExceptionIO = Exception.throwIO
178
179 handleGhcException :: ExceptionMonad m => (GhcException -> m a) -> m a -> m a
180 handleGhcException = ghandle
181
182
183 -- | Panics and asserts.
184 panic, sorry, pgmError :: String -> a
185 panic x = unsafeDupablePerformIO $ do
186 stack <- ccsToStrings =<< getCurrentCCS x
187 if null stack
188 then throwGhcException (Panic x)
189 else throwGhcException (Panic (x ++ '\n' : renderStack stack))
190
191 sorry x = throwGhcException (Sorry x)
192 pgmError x = throwGhcException (ProgramError x)
193
194 panicDoc, sorryDoc, pgmErrorDoc :: String -> SDoc -> a
195 panicDoc x doc = throwGhcException (PprPanic x doc)
196 sorryDoc x doc = throwGhcException (PprSorry x doc)
197 pgmErrorDoc x doc = throwGhcException (PprProgramError x doc)
198
199
200 -- | Throw an failed assertion exception for a given filename and line number.
201 assertPanic :: String -> Int -> a
202 assertPanic file line =
203 Exception.throw (Exception.AssertionFailed
204 ("ASSERT failed! file " ++ file ++ ", line " ++ show line))
205
206
207 -- | Like try, but pass through UserInterrupt and Panic exceptions.
208 -- Used when we want soft failures when reading interface files, for example.
209 -- TODO: I'm not entirely sure if this is catching what we really want to catch
210 tryMost :: IO a -> IO (Either SomeException a)
211 tryMost action = do r <- try action
212 case r of
213 Left se ->
214 case fromException se of
215 -- Some GhcException's we rethrow,
216 Just (Signal _) -> throwIO se
217 Just (Panic _) -> throwIO se
218 -- others we return
219 Just _ -> return (Left se)
220 Nothing ->
221 case fromException se of
222 -- All IOExceptions are returned
223 Just (_ :: IOException) ->
224 return (Left se)
225 -- Anything else is rethrown
226 Nothing -> throwIO se
227 Right v -> return (Right v)
228
229
230 -- | Install standard signal handlers for catching ^C, which just throw an
231 -- exception in the target thread. The current target thread is the
232 -- thread at the head of the list in the MVar passed to
233 -- installSignalHandlers.
234 installSignalHandlers :: IO ()
235 installSignalHandlers = do
236 main_thread <- myThreadId
237 pushInterruptTargetThread main_thread
238
239 let
240 interrupt_exn = (toException UserInterrupt)
241
242 interrupt = do
243 mt <- peekInterruptTargetThread
244 case mt of
245 Nothing -> return ()
246 Just t -> throwTo t interrupt_exn
247
248 --
249 #if !defined(mingw32_HOST_OS)
250 _ <- installHandler sigQUIT (Catch interrupt) Nothing
251 _ <- installHandler sigINT (Catch interrupt) Nothing
252 -- see #3656; in the future we should install these automatically for
253 -- all Haskell programs in the same way that we install a ^C handler.
254 let fatal_signal n = throwTo main_thread (Signal (fromIntegral n))
255 _ <- installHandler sigHUP (Catch (fatal_signal sigHUP)) Nothing
256 _ <- installHandler sigTERM (Catch (fatal_signal sigTERM)) Nothing
257 return ()
258 #else
259 -- GHC 6.3+ has support for console events on Windows
260 -- NOTE: running GHCi under a bash shell for some reason requires
261 -- you to press Ctrl-Break rather than Ctrl-C to provoke
262 -- an interrupt. Ctrl-C is getting blocked somewhere, I don't know
263 -- why --SDM 17/12/2004
264 let sig_handler ControlC = interrupt
265 sig_handler Break = interrupt
266 sig_handler _ = return ()
267
268 _ <- installHandler (Catch sig_handler)
269 return ()
270 #endif
271
272 {-# NOINLINE interruptTargetThread #-}
273 interruptTargetThread :: MVar [Weak ThreadId]
274 interruptTargetThread = unsafePerformIO (newMVar [])
275
276 pushInterruptTargetThread :: ThreadId -> IO ()
277 pushInterruptTargetThread tid = do
278 wtid <- mkWeakThreadId tid
279 modifyMVar_ interruptTargetThread $ return . (wtid :)
280
281 peekInterruptTargetThread :: IO (Maybe ThreadId)
282 peekInterruptTargetThread =
283 withMVar interruptTargetThread $ loop
284 where
285 loop [] = return Nothing
286 loop (t:ts) = do
287 r <- deRefWeak t
288 case r of
289 Nothing -> loop ts
290 Just t -> return (Just t)
291
292 popInterruptTargetThread :: IO ()
293 popInterruptTargetThread =
294 modifyMVar_ interruptTargetThread $
295 \tids -> return $! case tids of [] -> []
296 (_:ts) -> ts