2 % (c) The University of Glasgow 2006
3 % (c) The GRASP Project, Glasgow University, 1992-2000
6 Defines basic funtions for printing error messages.
8 It's hard to put these functions anywhere else without causing
9 some unnecessary loops in the module dependency graph.
14 GhcException(..), showGhcException, throwGhcException, handleGhcException,
18 panic, panicFastInt, assertPanic, trace,
20 Exception.Exception(..), showException, try, tryMost, throwTo,
22 installSignalHandlers, interruptTargetThread
25 #include "HsVersions.h"
30 #ifndef mingw32_HOST_OS
31 import System.Posix.Signals
32 #endif /* mingw32_HOST_OS */
34 #if defined(mingw32_HOST_OS)
35 import GHC.ConsoleHandler
39 import Control.Concurrent ( MVar, ThreadId, withMVar, newMVar, modifyMVar_,
42 import Debug.Trace ( trace )
43 import System.IO.Unsafe ( unsafePerformIO )
45 import System.Environment
48 GHC's own exception type.
51 ghcError :: GhcException -> a
52 ghcError e = Exception.throw e
54 -- error messages all take the form
56 -- <location>: <error>
58 -- If the location is on the command line, or in GHC itself, then
59 -- <location>="ghc". All of the error types below correspond to
60 -- a <location> of "ghc", except for ProgramError (where the string is
61 -- assumed to contain a location already, so we don't print one).
64 = PhaseFailed String -- name of phase
65 ExitCode -- an external phase (eg. cpp) failed
66 | Interrupted -- someone pressed ^C
67 | Signal Int -- some other fatal signal (SIGHUP,SIGTERM)
68 | UsageError String -- prints the short usage msg after the error
69 | CmdLineError String -- cmdline prob, but doesn't print usage
70 | Panic String -- the `impossible' happened
71 | InstallationError String -- an installation problem
72 | ProgramError String -- error in the user's code, probably
75 instance Exception GhcException
78 progName = unsafePerformIO (getProgName)
79 {-# NOINLINE progName #-}
82 short_usage = "Usage: For basic information, try the `--help' option."
84 showException :: Exception e => e -> String
87 instance Show GhcException where
88 showsPrec _ e@(ProgramError _) = showGhcException e
89 showsPrec _ e@(CmdLineError _) = showString "<command line>: " . showGhcException e
90 showsPrec _ e = showString progName . showString ": " . showGhcException e
92 showGhcException :: GhcException -> String -> String
93 showGhcException (UsageError str)
94 = showString str . showChar '\n' . showString short_usage
95 showGhcException (PhaseFailed phase code)
96 = showString "phase `" . showString phase .
97 showString "' failed (exitcode = " . shows int_code .
102 ExitSuccess -> (0::Int)
104 showGhcException (CmdLineError str)
106 showGhcException (ProgramError str)
108 showGhcException (InstallationError str)
110 showGhcException (Interrupted)
111 = showString "interrupted"
112 showGhcException (Signal n)
113 = showString "signal: " . shows n
114 showGhcException (Panic s)
115 = showString ("panic! (the 'impossible' happened)\n"
116 ++ " (GHC version " ++ cProjectVersion ++ " for " ++ TargetPlatform_NAME ++ "):\n\t"
118 ++ "Please report this as a GHC bug: http://www.haskell.org/ghc/reportabug\n")
120 throwGhcException :: GhcException -> a
121 throwGhcException = Exception.throw
123 handleGhcException :: ExceptionMonad m => (GhcException -> m a) -> m a -> m a
124 handleGhcException = ghandle
126 ghcExceptionTc :: TyCon
127 ghcExceptionTc = mkTyCon "GhcException"
128 {-# NOINLINE ghcExceptionTc #-}
129 instance Typeable GhcException where
130 typeOf _ = mkTyConApp ghcExceptionTc []
136 panic, pgmError :: String -> a
137 panic x = throwGhcException (Panic x)
138 pgmError x = throwGhcException (ProgramError x)
140 -- #-versions because panic can't return an unboxed int, and that's
141 -- what TAG_ is with GHC at the moment. Ugh. (Simon)
142 -- No, man -- Too Beautiful! (Will)
144 panicFastInt :: String -> FastInt
145 panicFastInt s = case (panic s) of () -> _ILIT(0)
147 assertPanic :: String -> Int -> a
148 assertPanic file line =
149 Exception.throw (Exception.AssertionFailed
150 ("ASSERT failed! file " ++ file ++ ", line " ++ show line))
154 -- | tryMost is like try, but passes through Interrupted and Panic
155 -- exceptions. Used when we want soft failures when reading interface
156 -- files, for example.
158 -- XXX I'm not entirely sure if this is catching what we really want to catch
159 tryMost :: IO a -> IO (Either SomeException a)
160 tryMost action = do r <- try action
163 case fromException se of
164 -- Some GhcException's we rethrow,
165 Just Interrupted -> throwIO se
166 Just (Signal _) -> throwIO se
167 Just (Panic _) -> throwIO se
169 Just _ -> return (Left se)
171 case fromException se of
172 -- All IOExceptions are returned
173 Just (_ :: IOException) ->
175 -- Anything else is rethrown
176 Nothing -> throwIO se
177 Right v -> return (Right v)
180 Standard signal handlers for catching ^C, which just throw an
181 exception in the target thread. The current target thread is
182 the thread at the head of the list in the MVar passed to
183 installSignalHandlers.
186 installSignalHandlers :: IO ()
187 installSignalHandlers = do
188 main_thread <- myThreadId
189 modifyMVar_ interruptTargetThread (return . (main_thread :))
192 interrupt_exn = (toException Interrupted)
195 withMVar interruptTargetThread $ \targets ->
198 (thread:_) -> throwTo thread interrupt_exn
201 #if !defined(mingw32_HOST_OS)
202 _ <- installHandler sigQUIT (Catch interrupt) Nothing
203 _ <- installHandler sigINT (Catch interrupt) Nothing
204 -- see #3656; in the future we should install these automatically for
205 -- all Haskell programs in the same way that we install a ^C handler.
206 let fatal_signal n = throwTo main_thread (Signal (fromIntegral n))
207 _ <- installHandler sigHUP (Catch (fatal_signal sigHUP)) Nothing
208 _ <- installHandler sigTERM (Catch (fatal_signal sigTERM)) Nothing
211 -- GHC 6.3+ has support for console events on Windows
212 -- NOTE: running GHCi under a bash shell for some reason requires
213 -- you to press Ctrl-Break rather than Ctrl-C to provoke
214 -- an interrupt. Ctrl-C is getting blocked somewhere, I don't know
215 -- why --SDM 17/12/2004
216 let sig_handler ControlC = interrupt
217 sig_handler Break = interrupt
218 sig_handler _ = return ()
220 _ <- installHandler (Catch sig_handler)
224 {-# NOINLINE interruptTargetThread #-}
225 interruptTargetThread :: MVar [ThreadId]
226 interruptTargetThread = unsafePerformIO (newMVar [])