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