never executed always true always false
1 {-# LANGUAGE BangPatterns #-}
2 {-# LANGUAGE RankNTypes #-}
3 {-# LANGUAGE ViewPatterns #-}
4
5 {-
6 (c) The AQUA Project, Glasgow University, 1994-1998
7
8 \section[ErrsUtils]{Utilities for error reporting}
9 -}
10
11 module GHC.Utils.Error (
12 -- * Basic types
13 Validity'(..), Validity, andValid, allValid, isValid, getInvalids, orValid,
14 Severity(..),
15
16 -- * Messages
17 Diagnostic(..),
18 MsgEnvelope(..),
19 MessageClass(..),
20 SDoc,
21 DecoratedSDoc(unDecorated),
22 Messages,
23 mkMessages, unionMessages,
24 errorsFound, isEmptyMessages,
25
26 -- ** Formatting
27 pprMessageBag, pprMsgEnvelopeBagWithLoc,
28 pprMessages,
29 pprLocMsgEnvelope,
30 formatBulleted,
31
32 -- ** Construction
33 DiagOpts (..), diag_wopt, diag_fatal_wopt,
34 emptyMessages, mkDecorated, mkLocMessage, mkLocMessageAnn,
35 mkMsgEnvelope, mkPlainMsgEnvelope, mkPlainErrorMsgEnvelope,
36 mkErrorMsgEnvelope,
37 mkMCDiagnostic, errorDiagnostic, diagReasonSeverity,
38
39 mkPlainError,
40 mkPlainDiagnostic,
41 mkDecoratedError,
42 mkDecoratedDiagnostic,
43 noHints,
44
45 -- * Utilities
46 getCaretDiagnostic,
47
48 -- * Issuing messages during compilation
49 putMsg, printInfoForUser, printOutputForUser,
50 logInfo, logOutput,
51 errorMsg,
52 fatalErrorMsg,
53 compilationProgressMsg,
54 showPass,
55 withTiming, withTimingSilent,
56 debugTraceMsg,
57 ghcExit,
58 prettyPrintGhcErrors,
59 traceCmd,
60
61 sortMsgBag
62 ) where
63
64 import GHC.Prelude
65
66 import GHC.Driver.Flags
67
68 import GHC.Data.Bag
69 import qualified GHC.Data.EnumSet as EnumSet
70 import GHC.Data.EnumSet (EnumSet)
71
72 import GHC.Utils.Exception
73 import GHC.Utils.Outputable as Outputable
74 import GHC.Utils.Panic
75 import GHC.Utils.Panic.Plain
76 import GHC.Utils.Logger
77 import GHC.Types.Error
78 import GHC.Types.SrcLoc as SrcLoc
79
80 import System.Exit ( ExitCode(..), exitWith )
81 import Data.List ( sortBy )
82 import Data.Function
83 import Debug.Trace
84 import Control.Monad
85 import Control.Monad.IO.Class
86 import Control.Monad.Catch as MC (handle)
87 import GHC.Conc ( getAllocationCounter )
88 import System.CPUTime
89
90 data DiagOpts = DiagOpts
91 { diag_warning_flags :: !(EnumSet WarningFlag) -- ^ Enabled warnings
92 , diag_fatal_warning_flags :: !(EnumSet WarningFlag) -- ^ Fatal warnings
93 , diag_warn_is_error :: !Bool -- ^ Treat warnings as errors
94 , diag_reverse_errors :: !Bool -- ^ Reverse error reporting order
95 , diag_max_errors :: !(Maybe Int) -- ^ Max reported error count
96 , diag_ppr_ctx :: !SDocContext -- ^ Error printing context
97 }
98
99 diag_wopt :: WarningFlag -> DiagOpts -> Bool
100 diag_wopt wflag opts = wflag `EnumSet.member` diag_warning_flags opts
101
102 diag_fatal_wopt :: WarningFlag -> DiagOpts -> Bool
103 diag_fatal_wopt wflag opts = wflag `EnumSet.member` diag_fatal_warning_flags opts
104
105 -- | Computes the /right/ 'Severity' for the input 'DiagnosticReason' out of
106 -- the 'DiagOpts. This function /has/ to be called when a diagnostic is constructed,
107 -- i.e. with a 'DiagOpts \"snapshot\" taken as close as possible to where a
108 -- particular diagnostic message is built, otherwise the computed 'Severity' might
109 -- not be correct, due to the mutable nature of the 'DynFlags' in GHC.
110 diagReasonSeverity :: DiagOpts -> DiagnosticReason -> Severity
111 diagReasonSeverity opts reason = case reason of
112 WarningWithFlag wflag
113 | not (diag_wopt wflag opts) -> SevIgnore
114 | diag_fatal_wopt wflag opts -> SevError
115 | otherwise -> SevWarning
116 WarningWithoutFlag
117 | diag_warn_is_error opts -> SevError
118 | otherwise -> SevWarning
119 ErrorWithoutFlag
120 -> SevError
121
122
123 -- | Make a 'MessageClass' for a given 'DiagnosticReason', consulting the
124 -- 'DiagOpts.
125 mkMCDiagnostic :: DiagOpts -> DiagnosticReason -> MessageClass
126 mkMCDiagnostic opts reason = MCDiagnostic (diagReasonSeverity opts reason) reason
127
128 -- | Varation of 'mkMCDiagnostic' which can be used when we are /sure/ the
129 -- input 'DiagnosticReason' /is/ 'ErrorWithoutFlag'.
130 errorDiagnostic :: MessageClass
131 errorDiagnostic = MCDiagnostic SevError ErrorWithoutFlag
132
133 --
134 -- Creating MsgEnvelope(s)
135 --
136
137 mk_msg_envelope
138 :: Diagnostic e
139 => Severity
140 -> SrcSpan
141 -> PrintUnqualified
142 -> e
143 -> MsgEnvelope e
144 mk_msg_envelope severity locn print_unqual err
145 = MsgEnvelope { errMsgSpan = locn
146 , errMsgContext = print_unqual
147 , errMsgDiagnostic = err
148 , errMsgSeverity = severity
149 }
150
151 -- | Wrap a 'Diagnostic' in a 'MsgEnvelope', recording its location.
152 -- If you know your 'Diagnostic' is an error, consider using 'mkErrorMsgEnvelope',
153 -- which does not require looking at the 'DiagOpts'
154 mkMsgEnvelope
155 :: Diagnostic e
156 => DiagOpts
157 -> SrcSpan
158 -> PrintUnqualified
159 -> e
160 -> MsgEnvelope e
161 mkMsgEnvelope opts locn print_unqual err
162 = mk_msg_envelope (diagReasonSeverity opts (diagnosticReason err)) locn print_unqual err
163
164 -- | Wrap a 'Diagnostic' in a 'MsgEnvelope', recording its location.
165 -- Precondition: the diagnostic is, in fact, an error. That is,
166 -- @diagnosticReason msg == ErrorWithoutFlag@.
167 mkErrorMsgEnvelope :: Diagnostic e
168 => SrcSpan
169 -> PrintUnqualified
170 -> e
171 -> MsgEnvelope e
172 mkErrorMsgEnvelope locn unqual msg =
173 assert (diagnosticReason msg == ErrorWithoutFlag) $ mk_msg_envelope SevError locn unqual msg
174
175 -- | Variant that doesn't care about qualified/unqualified names.
176 mkPlainMsgEnvelope :: Diagnostic e
177 => DiagOpts
178 -> SrcSpan
179 -> e
180 -> MsgEnvelope e
181 mkPlainMsgEnvelope opts locn msg =
182 mkMsgEnvelope opts locn alwaysQualify msg
183
184 -- | Variant of 'mkPlainMsgEnvelope' which can be used when we are /sure/ we
185 -- are constructing a diagnostic with a 'ErrorWithoutFlag' reason.
186 mkPlainErrorMsgEnvelope :: Diagnostic e
187 => SrcSpan
188 -> e
189 -> MsgEnvelope e
190 mkPlainErrorMsgEnvelope locn msg =
191 mk_msg_envelope SevError locn alwaysQualify msg
192
193 -------------------------
194 data Validity' a
195 = IsValid -- ^ Everything is fine
196 | NotValid a -- ^ A problem, and some indication of why
197
198 -- | Monomorphic version of @Validity'@ specialised for 'SDoc's.
199 type Validity = Validity' SDoc
200
201 isValid :: Validity' a -> Bool
202 isValid IsValid = True
203 isValid (NotValid {}) = False
204
205 andValid :: Validity' a -> Validity' a -> Validity' a
206 andValid IsValid v = v
207 andValid v _ = v
208
209 -- | If they aren't all valid, return the first
210 allValid :: [Validity' a] -> Validity' a
211 allValid [] = IsValid
212 allValid (v : vs) = v `andValid` allValid vs
213
214 getInvalids :: [Validity' a] -> [a]
215 getInvalids vs = [d | NotValid d <- vs]
216
217 orValid :: Validity' a -> Validity' a -> Validity' a
218 orValid IsValid _ = IsValid
219 orValid _ v = v
220
221 -- -----------------------------------------------------------------------------
222 -- Collecting up messages for later ordering and printing.
223
224 ----------------
225 -- | Formats the input list of structured document, where each element of the list gets a bullet.
226 formatBulleted :: SDocContext -> DecoratedSDoc -> SDoc
227 formatBulleted ctx (unDecorated -> docs)
228 = case msgs of
229 [] -> Outputable.empty
230 [msg] -> msg
231 _ -> vcat $ map starred msgs
232 where
233 msgs = filter (not . Outputable.isEmpty ctx) docs
234 starred = (bullet<+>)
235
236 pprMessages :: Diagnostic e => Messages e -> SDoc
237 pprMessages = vcat . pprMsgEnvelopeBagWithLoc . getMessages
238
239 pprMsgEnvelopeBagWithLoc :: Diagnostic e => Bag (MsgEnvelope e) -> [SDoc]
240 pprMsgEnvelopeBagWithLoc bag = [ pprLocMsgEnvelope item | item <- sortMsgBag Nothing bag ]
241
242 pprLocMsgEnvelope :: Diagnostic e => MsgEnvelope e -> SDoc
243 pprLocMsgEnvelope (MsgEnvelope { errMsgSpan = s
244 , errMsgDiagnostic = e
245 , errMsgSeverity = sev
246 , errMsgContext = unqual })
247 = sdocWithContext $ \ctx ->
248 withErrStyle unqual $
249 mkLocMessage (MCDiagnostic sev (diagnosticReason e)) s (formatBulleted ctx $ diagnosticMessage e)
250
251 sortMsgBag :: Maybe DiagOpts -> Bag (MsgEnvelope e) -> [MsgEnvelope e]
252 sortMsgBag mopts = maybeLimit . sortBy (cmp `on` errMsgSpan) . bagToList
253 where
254 cmp
255 | Just opts <- mopts
256 , diag_reverse_errors opts
257 = SrcLoc.rightmost_smallest
258 | otherwise
259 = SrcLoc.leftmost_smallest
260 maybeLimit
261 | Just opts <- mopts
262 , Just err_limit <- diag_max_errors opts
263 = take err_limit
264 | otherwise
265 = id
266
267 ghcExit :: Logger -> Int -> IO ()
268 ghcExit logger val
269 | val == 0 = exitWith ExitSuccess
270 | otherwise = do errorMsg logger (text "\nCompilation had errors\n\n")
271 exitWith (ExitFailure val)
272
273 -- -----------------------------------------------------------------------------
274 -- Outputting messages from the compiler
275
276 errorMsg :: Logger -> SDoc -> IO ()
277 errorMsg logger msg
278 = logMsg logger errorDiagnostic noSrcSpan $
279 withPprStyle defaultErrStyle msg
280
281 fatalErrorMsg :: Logger -> SDoc -> IO ()
282 fatalErrorMsg logger msg =
283 logMsg logger MCFatal noSrcSpan $ withPprStyle defaultErrStyle msg
284
285 compilationProgressMsg :: Logger -> SDoc -> IO ()
286 compilationProgressMsg logger msg = do
287 let logflags = logFlags logger
288 let str = renderWithContext (log_default_user_context logflags) (text "GHC progress: " <> msg)
289 traceEventIO str
290 when (logVerbAtLeast logger 1) $
291 logOutput logger $ withPprStyle defaultUserStyle msg
292
293 showPass :: Logger -> String -> IO ()
294 showPass logger what =
295 when (logVerbAtLeast logger 2) $
296 logInfo logger $ withPprStyle defaultUserStyle (text "***" <+> text what <> colon)
297
298 data PrintTimings = PrintTimings | DontPrintTimings
299 deriving (Eq, Show)
300
301 -- | Time a compilation phase.
302 --
303 -- When timings are enabled (e.g. with the @-v2@ flag), the allocations
304 -- and CPU time used by the phase will be reported to stderr. Consider
305 -- a typical usage:
306 -- @withTiming getDynFlags (text "simplify") force PrintTimings pass@.
307 -- When timings are enabled the following costs are included in the
308 -- produced accounting,
309 --
310 -- - The cost of executing @pass@ to a result @r@ in WHNF
311 -- - The cost of evaluating @force r@ to WHNF (e.g. @()@)
312 --
313 -- The choice of the @force@ function depends upon the amount of forcing
314 -- desired; the goal here is to ensure that the cost of evaluating the result
315 -- is, to the greatest extent possible, included in the accounting provided by
316 -- 'withTiming'. Often the pass already sufficiently forces its result during
317 -- construction; in this case @const ()@ is a reasonable choice.
318 -- In other cases, it is necessary to evaluate the result to normal form, in
319 -- which case something like @Control.DeepSeq.rnf@ is appropriate.
320 --
321 -- To avoid adversely affecting compiler performance when timings are not
322 -- requested, the result is only forced when timings are enabled.
323 --
324 -- See Note [withTiming] for more.
325 withTiming :: MonadIO m
326 => Logger
327 -> SDoc -- ^ The name of the phase
328 -> (a -> ()) -- ^ A function to force the result
329 -- (often either @const ()@ or 'rnf')
330 -> m a -- ^ The body of the phase to be timed
331 -> m a
332 withTiming logger what force action =
333 withTiming' logger what force PrintTimings action
334
335 -- | Same as 'withTiming', but doesn't print timings in the
336 -- console (when given @-vN@, @N >= 2@ or @-ddump-timings@).
337 --
338 -- See Note [withTiming] for more.
339 withTimingSilent
340 :: MonadIO m
341 => Logger
342 -> SDoc -- ^ The name of the phase
343 -> (a -> ()) -- ^ A function to force the result
344 -- (often either @const ()@ or 'rnf')
345 -> m a -- ^ The body of the phase to be timed
346 -> m a
347 withTimingSilent logger what force action =
348 withTiming' logger what force DontPrintTimings action
349
350 -- | Worker for 'withTiming' and 'withTimingSilent'.
351 withTiming' :: MonadIO m
352 => Logger
353 -> SDoc -- ^ The name of the phase
354 -> (a -> ()) -- ^ A function to force the result
355 -- (often either @const ()@ or 'rnf')
356 -> PrintTimings -- ^ Whether to print the timings
357 -> m a -- ^ The body of the phase to be timed
358 -> m a
359 withTiming' logger what force_result prtimings action
360 = if logVerbAtLeast logger 2 || logHasDumpFlag logger Opt_D_dump_timings
361 then do whenPrintTimings $
362 logInfo logger $ withPprStyle defaultUserStyle $
363 text "***" <+> what <> colon
364 let ctx = log_default_user_context (logFlags logger)
365 alloc0 <- liftIO getAllocationCounter
366 start <- liftIO getCPUTime
367 eventBegins ctx what
368 recordAllocs alloc0
369 !r <- action
370 () <- pure $ force_result r
371 eventEnds ctx what
372 end <- liftIO getCPUTime
373 alloc1 <- liftIO getAllocationCounter
374 recordAllocs alloc1
375 -- recall that allocation counter counts down
376 let alloc = alloc0 - alloc1
377 time = realToFrac (end - start) * 1e-9
378
379 when (logVerbAtLeast logger 2 && prtimings == PrintTimings)
380 $ liftIO $ logInfo logger $ withPprStyle defaultUserStyle
381 (text "!!!" <+> what <> colon <+> text "finished in"
382 <+> doublePrec 2 time
383 <+> text "milliseconds"
384 <> comma
385 <+> text "allocated"
386 <+> doublePrec 3 (realToFrac alloc / 1024 / 1024)
387 <+> text "megabytes")
388
389 whenPrintTimings $
390 putDumpFileMaybe logger Opt_D_dump_timings "" FormatText
391 $ text $ showSDocOneLine ctx
392 $ hsep [ what <> colon
393 , text "alloc=" <> ppr alloc
394 , text "time=" <> doublePrec 3 time
395 ]
396 pure r
397 else action
398
399 where whenPrintTimings = liftIO . when (prtimings == PrintTimings)
400
401 recordAllocs alloc =
402 liftIO $ traceMarkerIO $ "GHC:allocs:" ++ show alloc
403
404 eventBegins ctx w = do
405 let doc = eventBeginsDoc ctx w
406 whenPrintTimings $ traceMarkerIO doc
407 liftIO $ traceEventIO doc
408
409 eventEnds ctx w = do
410 let doc = eventEndsDoc ctx w
411 whenPrintTimings $ traceMarkerIO doc
412 liftIO $ traceEventIO doc
413
414 eventBeginsDoc ctx w = showSDocOneLine ctx $ text "GHC:started:" <+> w
415 eventEndsDoc ctx w = showSDocOneLine ctx $ text "GHC:finished:" <+> w
416
417 debugTraceMsg :: Logger -> Int -> SDoc -> IO ()
418 debugTraceMsg logger val msg =
419 when (log_verbosity (logFlags logger) >= val) $
420 logInfo logger (withPprStyle defaultDumpStyle msg)
421 {-# INLINE debugTraceMsg #-} -- see Note [INLINE conditional tracing utilities]
422
423 putMsg :: Logger -> SDoc -> IO ()
424 putMsg logger msg = logInfo logger (withPprStyle defaultUserStyle msg)
425
426 printInfoForUser :: Logger -> PrintUnqualified -> SDoc -> IO ()
427 printInfoForUser logger print_unqual msg
428 = logInfo logger (withUserStyle print_unqual AllTheWay msg)
429
430 printOutputForUser :: Logger -> PrintUnqualified -> SDoc -> IO ()
431 printOutputForUser logger print_unqual msg
432 = logOutput logger (withUserStyle print_unqual AllTheWay msg)
433
434 logInfo :: Logger -> SDoc -> IO ()
435 logInfo logger msg = logMsg logger MCInfo noSrcSpan msg
436
437 -- | Like 'logInfo' but with 'SevOutput' rather then 'SevInfo'
438 logOutput :: Logger -> SDoc -> IO ()
439 logOutput logger msg = logMsg logger MCOutput noSrcSpan msg
440
441
442 prettyPrintGhcErrors :: ExceptionMonad m => Logger -> m a -> m a
443 prettyPrintGhcErrors logger = do
444 let ctx = log_default_user_context (logFlags logger)
445 MC.handle $ \e -> case e of
446 PprPanic str doc ->
447 pprDebugAndThen ctx panic (text str) doc
448 PprSorry str doc ->
449 pprDebugAndThen ctx sorry (text str) doc
450 PprProgramError str doc ->
451 pprDebugAndThen ctx pgmError (text str) doc
452 _ -> liftIO $ throwIO e
453
454 -- | Trace a command (when verbosity level >= 3)
455 traceCmd :: Logger -> String -> String -> IO a -> IO a
456 traceCmd logger phase_name cmd_line action = do
457 showPass logger phase_name
458 let
459 cmd_doc = text cmd_line
460 handle_exn exn = do
461 debugTraceMsg logger 2 (char '\n')
462 debugTraceMsg logger 2 (text "Failed:" <+> cmd_doc <+> text (show exn))
463 throwGhcExceptionIO (ProgramError (show exn))
464 debugTraceMsg logger 3 cmd_doc
465 loggerTraceFlush logger
466 -- And run it!
467 action `catchIO` handle_exn
468
469 {- Note [withTiming]
470 ~~~~~~~~~~~~~~~~~~~~
471
472 For reference:
473
474 withTiming
475 :: MonadIO
476 => m DynFlags -- how to get the DynFlags
477 -> SDoc -- label for the computation we're timing
478 -> (a -> ()) -- how to evaluate the result
479 -> PrintTimings -- whether to report the timings when passed
480 -- -v2 or -ddump-timings
481 -> m a -- computation we're timing
482 -> m a
483
484 withTiming lets you run an action while:
485
486 (1) measuring the CPU time it took and reporting that on stderr
487 (when PrintTimings is passed),
488 (2) emitting start/stop events to GHC's event log, with the label
489 given as an argument.
490
491 Evaluation of the result
492 ------------------------
493
494 'withTiming' takes as an argument a function of type 'a -> ()', whose purpose is
495 to evaluate the result "sufficiently". A given pass might return an 'm a' for
496 some monad 'm' and result type 'a', but where the 'a' is complex enough
497 that evaluating it to WHNF barely scratches its surface and leaves many
498 complex and time-consuming computations unevaluated. Those would only be
499 forced by the next pass, and the time needed to evaluate them would be
500 mis-attributed to that next pass. A more appropriate function would be
501 one that deeply evaluates the result, so as to assign the time spent doing it
502 to the pass we're timing.
503
504 Note: as hinted at above, the time spent evaluating the application of the
505 forcing function to the result is included in the timings reported by
506 'withTiming'.
507
508 How we use it
509 -------------
510
511 We measure the time and allocations of various passes in GHC's pipeline by just
512 wrapping the whole pass with 'withTiming'. This also materializes by having
513 a label for each pass in the eventlog, where each pass is executed in one go,
514 during a continuous time window.
515
516 However, from STG onwards, the pipeline uses streams to emit groups of
517 STG/Cmm/etc declarations one at a time, and process them until we get to
518 assembly code generation. This means that the execution of those last few passes
519 is interleaved and that we cannot measure how long they take by just wrapping
520 the whole thing with 'withTiming'. Instead we wrap the processing of each
521 individual stream element, all along the codegen pipeline, using the appropriate
522 label for the pass to which this processing belongs. That generates a lot more
523 data but allows us to get fine-grained timings about all the passes and we can
524 easily compute totals with tools like ghc-events-analyze (see below).
525
526
527 Producing an eventlog for GHC
528 -----------------------------
529
530 To actually produce the eventlog, you need an eventlog-capable GHC build:
531
532 With Hadrian:
533 $ hadrian/build -j "stage1.ghc-bin.ghc.link.opts += -eventlog"
534
535 With Make:
536 $ make -j GhcStage2HcOpts+=-eventlog
537
538 You can then produce an eventlog when compiling say hello.hs by simply
539 doing:
540
541 If GHC was built by Hadrian:
542 $ _build/stage1/bin/ghc -ddump-timings hello.hs -o hello +RTS -l
543
544 If GHC was built with Make:
545 $ inplace/bin/ghc-stage2 -ddump-timing hello.hs -o hello +RTS -l
546
547 You could alternatively use -v<N> (with N >= 2) instead of -ddump-timings,
548 to ask GHC to report timings (on stderr and the eventlog).
549
550 This will write the eventlog to ./ghc.eventlog in both cases. You can then
551 visualize it or look at the totals for each label by using ghc-events-analyze,
552 threadscope or any other eventlog consumer. Illustrating with
553 ghc-events-analyze:
554
555 $ ghc-events-analyze --timed --timed-txt --totals \
556 --start "GHC:started:" --stop "GHC:finished:" \
557 ghc.eventlog
558
559 This produces ghc.timed.txt (all event timestamps), ghc.timed.svg (visualisation
560 of the execution through the various labels) and ghc.totals.txt (total time
561 spent in each label).
562
563 -}