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 | Signal Int -- some other fatal signal (SIGHUP,SIGTERM)
67 | UsageError String -- prints the short usage msg after the error
68 | CmdLineError String -- cmdline prob, but doesn't print usage
69 | Panic String -- the `impossible' happened
70 | InstallationError String -- an installation problem
71 | ProgramError String -- error in the user's code, probably
74 instance Exception GhcException
77 progName = unsafePerformIO (getProgName)
78 {-# NOINLINE progName #-}
81 short_usage = "Usage: For basic information, try the `--help' option."
83 showException :: Exception e => e -> String
86 instance Show GhcException where
87 showsPrec _ e@(ProgramError _) = showGhcException e
88 showsPrec _ e@(CmdLineError _) = showString "<command line>: " . showGhcException e
89 showsPrec _ e = showString progName . showString ": " . showGhcException e
91 showGhcException :: GhcException -> String -> String
92 showGhcException (UsageError str)
93 = showString str . showChar '\n' . showString short_usage
94 showGhcException (PhaseFailed phase code)
95 = showString "phase `" . showString phase .
96 showString "' failed (exitcode = " . shows int_code .
101 ExitSuccess -> (0::Int)
103 showGhcException (CmdLineError str)
105 showGhcException (ProgramError str)
107 showGhcException (InstallationError str)
109 showGhcException (Signal n)
110 = showString "signal: " . shows n
111 showGhcException (Panic s)
112 = showString ("panic! (the 'impossible' happened)\n"
113 ++ " (GHC version " ++ cProjectVersion ++ " for " ++ TargetPlatform_NAME ++ "):\n\t"
115 ++ "Please report this as a GHC bug: http://www.haskell.org/ghc/reportabug\n")
117 throwGhcException :: GhcException -> a
118 throwGhcException = Exception.throw
120 handleGhcException :: ExceptionMonad m => (GhcException -> m a) -> m a -> m a
121 handleGhcException = ghandle
123 ghcExceptionTc :: TyCon
124 ghcExceptionTc = mkTyCon "GhcException"
125 {-# NOINLINE ghcExceptionTc #-}
126 instance Typeable GhcException where
127 typeOf _ = mkTyConApp ghcExceptionTc []
133 panic, pgmError :: String -> a
134 panic x = throwGhcException (Panic x)
135 pgmError x = throwGhcException (ProgramError x)
137 -- #-versions because panic can't return an unboxed int, and that's
138 -- what TAG_ is with GHC at the moment. Ugh. (Simon)
139 -- No, man -- Too Beautiful! (Will)
141 panicFastInt :: String -> FastInt
142 panicFastInt s = case (panic s) of () -> _ILIT(0)
144 assertPanic :: String -> Int -> a
145 assertPanic file line =
146 Exception.throw (Exception.AssertionFailed
147 ("ASSERT failed! file " ++ file ++ ", line " ++ show line))
151 -- | tryMost is like try, but passes through UserInterrupt and Panic
152 -- exceptions. Used when we want soft failures when reading interface
153 -- files, for example.
155 -- XXX I'm not entirely sure if this is catching what we really want to catch
156 tryMost :: IO a -> IO (Either SomeException a)
157 tryMost action = do r <- try action
160 case fromException se of
161 -- Some GhcException's we rethrow,
162 Just (Signal _) -> throwIO se
163 Just (Panic _) -> throwIO se
165 Just _ -> return (Left se)
167 case fromException se of
168 -- All IOExceptions are returned
169 Just (_ :: IOException) ->
171 -- Anything else is rethrown
172 Nothing -> throwIO se
173 Right v -> return (Right v)
176 Standard signal handlers for catching ^C, which just throw an
177 exception in the target thread. The current target thread is
178 the thread at the head of the list in the MVar passed to
179 installSignalHandlers.
182 installSignalHandlers :: IO ()
183 installSignalHandlers = do
184 main_thread <- myThreadId
185 modifyMVar_ interruptTargetThread (return . (main_thread :))
188 interrupt_exn = (toException UserInterrupt)
191 withMVar interruptTargetThread $ \targets ->
194 (thread:_) -> throwTo thread interrupt_exn
197 #if !defined(mingw32_HOST_OS)
198 _ <- installHandler sigQUIT (Catch interrupt) Nothing
199 _ <- installHandler sigINT (Catch interrupt) Nothing
200 -- see #3656; in the future we should install these automatically for
201 -- all Haskell programs in the same way that we install a ^C handler.
202 let fatal_signal n = throwTo main_thread (Signal (fromIntegral n))
203 _ <- installHandler sigHUP (Catch (fatal_signal sigHUP)) Nothing
204 _ <- installHandler sigTERM (Catch (fatal_signal sigTERM)) Nothing
207 -- GHC 6.3+ has support for console events on Windows
208 -- NOTE: running GHCi under a bash shell for some reason requires
209 -- you to press Ctrl-Break rather than Ctrl-C to provoke
210 -- an interrupt. Ctrl-C is getting blocked somewhere, I don't know
211 -- why --SDM 17/12/2004
212 let sig_handler ControlC = interrupt
213 sig_handler Break = interrupt
214 sig_handler _ = return ()
216 _ <- installHandler (Catch sig_handler)
220 {-# NOINLINE interruptTargetThread #-}
221 interruptTargetThread :: MVar [ThreadId]
222 interruptTargetThread = unsafePerformIO (newMVar [])