2 % (c) The University of Glasgow 2006
3 % (c) The GRASP Project, Glasgow University, 1992-2000
5 Defines basic functions for printing error messages.
7 It's hard to put these functions anywhere else without causing
8 some unnecessary loops in the module dependency graph.
12 GhcException(..), showGhcException, throwGhcException, handleGhcException,
16 panic, sorry, panicFastInt, assertPanic, trace,
18 Exception.Exception(..), showException, try, tryMost, throwTo,
20 installSignalHandlers, interruptTargetThread
22 #include "HsVersions.h"
27 import Control.Concurrent ( MVar, ThreadId, withMVar, newMVar, modifyMVar_,
30 import Debug.Trace ( trace )
31 import System.IO.Unsafe ( unsafePerformIO )
33 import System.Environment
35 #ifndef mingw32_HOST_OS
36 import System.Posix.Signals
39 #if defined(mingw32_HOST_OS)
40 import GHC.ConsoleHandler
44 -- | GHC's own exception type
45 -- error messages all take the form:
48 -- <location>: <error>
51 -- If the location is on the command line, or in GHC itself, then
52 -- <location>="ghc". All of the error types below correspond to
53 -- a <location> of "ghc", except for ProgramError (where the string is
54 -- assumed to contain a location already, so we don't print one).
57 = PhaseFailed String -- name of phase
58 ExitCode -- an external phase (eg. cpp) failed
60 -- | Some other fatal signal (SIGHUP,SIGTERM)
63 -- | Prints the short usage msg after the error
66 -- | A problem with the command line arguments, but don't print usage.
69 -- | The 'impossible' happened.
72 -- | The user tickled something that's known not to work yet,
73 -- but we're not counting it as a bug.
76 -- | An installation problem.
77 | InstallationError String
79 -- | An error in the user's code, probably.
83 instance Exception GhcException
85 instance Show GhcException where
86 showsPrec _ e@(ProgramError _) = showGhcException e
87 showsPrec _ e@(CmdLineError _) = showString "<command line>: " . showGhcException e
88 showsPrec _ e = showString progName . showString ": " . showGhcException e
90 instance Typeable GhcException where
91 typeOf _ = mkTyConApp ghcExceptionTc []
94 -- | The name of this GHC.
96 progName = unsafePerformIO (getProgName)
97 {-# NOINLINE progName #-}
100 -- | Short usage information to display when we are given the wrong cmd line arguments.
101 short_usage :: String
102 short_usage = "Usage: For basic information, try the `--help' option."
105 -- | Show an exception as a string.
106 showException :: Exception e => e -> String
110 -- | Append a description of the given exception to this string.
111 showGhcException :: GhcException -> String -> String
112 showGhcException exception
115 -> showString str . showChar '\n' . showString short_usage
117 PhaseFailed phase code
118 -> showString "phase `" . showString phase .
119 showString "' failed (exitcode = " . shows (int_code code) .
122 CmdLineError str -> showString str
123 ProgramError str -> showString str
124 InstallationError str -> showString str
125 Signal n -> showString "signal: " . shows n
129 "panic! (the 'impossible' happened)\n"
130 ++ " (GHC version " ++ cProjectVersion ++ " for " ++ TargetPlatform_NAME ++ "):\n\t"
132 ++ "Please report this as a GHC bug: http://www.haskell.org/ghc/reportabug\n"
136 "sorry! (unimplemented feature or known bug)\n"
137 ++ " (GHC version " ++ cProjectVersion ++ " for " ++ TargetPlatform_NAME ++ "):\n\t"
140 where int_code code =
142 ExitSuccess -> (0::Int)
146 -- | Alias for `throwGhcException`
147 ghcError :: GhcException -> a
148 ghcError e = Exception.throw e
150 throwGhcException :: GhcException -> a
151 throwGhcException = Exception.throw
153 handleGhcException :: ExceptionMonad m => (GhcException -> m a) -> m a -> m a
154 handleGhcException = ghandle
157 ghcExceptionTc :: TyCon
158 ghcExceptionTc = mkTyCon "GhcException"
159 {-# NOINLINE ghcExceptionTc #-}
162 -- | Panics and asserts.
163 panic, sorry, pgmError :: String -> a
164 panic x = throwGhcException (Panic x)
165 sorry x = throwGhcException (Sorry x)
166 pgmError x = throwGhcException (ProgramError x)
169 -- | Panic while pretending to return an unboxed int.
170 -- You can't use the regular panic functions in expressions
171 -- producing unboxed ints because they have the wrong kind.
172 panicFastInt :: String -> FastInt
173 panicFastInt s = case (panic s) of () -> _ILIT(0)
176 -- | Throw an failed assertion exception for a given filename and line number.
177 assertPanic :: String -> Int -> a
178 assertPanic file line =
179 Exception.throw (Exception.AssertionFailed
180 ("ASSERT failed! file " ++ file ++ ", line " ++ show line))
183 -- | Like try, but pass through UserInterrupt and Panic exceptions.
184 -- Used when we want soft failures when reading interface files, for example.
185 -- TODO: I'm not entirely sure if this is catching what we really want to catch
186 tryMost :: IO a -> IO (Either SomeException a)
187 tryMost action = do r <- try action
190 case fromException se of
191 -- Some GhcException's we rethrow,
192 Just (Signal _) -> throwIO se
193 Just (Panic _) -> throwIO se
195 Just _ -> return (Left se)
197 case fromException se of
198 -- All IOExceptions are returned
199 Just (_ :: IOException) ->
201 -- Anything else is rethrown
202 Nothing -> throwIO se
203 Right v -> return (Right v)
206 -- | Install standard signal handlers for catching ^C, which just throw an
207 -- exception in the target thread. The current target thread is the
208 -- thread at the head of the list in the MVar passed to
209 -- installSignalHandlers.
210 installSignalHandlers :: IO ()
211 installSignalHandlers = do
212 main_thread <- myThreadId
213 modifyMVar_ interruptTargetThread (return . (main_thread :))
216 interrupt_exn = (toException UserInterrupt)
219 withMVar interruptTargetThread $ \targets ->
222 (thread:_) -> throwTo thread interrupt_exn
225 #if !defined(mingw32_HOST_OS)
226 _ <- installHandler sigQUIT (Catch interrupt) Nothing
227 _ <- installHandler sigINT (Catch interrupt) Nothing
228 -- see #3656; in the future we should install these automatically for
229 -- all Haskell programs in the same way that we install a ^C handler.
230 let fatal_signal n = throwTo main_thread (Signal (fromIntegral n))
231 _ <- installHandler sigHUP (Catch (fatal_signal sigHUP)) Nothing
232 _ <- installHandler sigTERM (Catch (fatal_signal sigTERM)) Nothing
235 -- GHC 6.3+ has support for console events on Windows
236 -- NOTE: running GHCi under a bash shell for some reason requires
237 -- you to press Ctrl-Break rather than Ctrl-C to provoke
238 -- an interrupt. Ctrl-C is getting blocked somewhere, I don't know
239 -- why --SDM 17/12/2004
240 let sig_handler ControlC = interrupt
241 sig_handler Break = interrupt
242 sig_handler _ = return ()
244 _ <- installHandler (Catch sig_handler)
248 {-# NOINLINE interruptTargetThread #-}
249 interruptTargetThread :: MVar [ThreadId]
250 interruptTargetThread = unsafePerformIO (newMVar [])