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