gitlab-ci: Update bootstrap compiled used for Darwin builds
[ghc.git] / compiler / main / ErrUtils.hs
1 {-
2 (c) The AQUA Project, Glasgow University, 1994-1998
3
4 \section[ErrsUtils]{Utilities for error reporting}
5 -}
6
7 {-# LANGUAGE CPP #-}
8 {-# LANGUAGE BangPatterns #-}
9 {-# LANGUAGE RecordWildCards #-}
10
11 module ErrUtils (
12 -- * Basic types
13 Validity(..), andValid, allValid, isValid, getInvalids, orValid,
14 Severity(..),
15
16 -- * Messages
17 ErrMsg, errMsgDoc, errMsgSeverity, errMsgReason,
18 ErrDoc, errDoc, errDocImportant, errDocContext, errDocSupplementary,
19 WarnMsg, MsgDoc,
20 Messages, ErrorMessages, WarningMessages,
21 unionMessages,
22 errMsgSpan, errMsgContext,
23 errorsFound, isEmptyMessages,
24 isWarnMsgFatal,
25 warningsToMessages,
26
27 -- ** Formatting
28 pprMessageBag, pprErrMsgBagWithLoc,
29 pprLocErrMsg, printBagOfErrors,
30 formatErrDoc,
31
32 -- ** Construction
33 emptyMessages, mkLocMessage, mkLocMessageAnn, makeIntoWarning,
34 mkErrMsg, mkPlainErrMsg, mkErrDoc, mkLongErrMsg, mkWarnMsg,
35 mkPlainWarnMsg,
36 mkLongWarnMsg,
37
38 -- * Utilities
39 doIfSet, doIfSet_dyn,
40 getCaretDiagnostic,
41
42 -- * Dump files
43 dumpIfSet, dumpIfSet_dyn, dumpIfSet_dyn_printer,
44 mkDumpDoc, dumpSDoc, dumpSDocForUser,
45 dumpSDocWithStyle,
46
47 -- * Issuing messages during compilation
48 putMsg, printInfoForUser, printOutputForUser,
49 logInfo, logOutput,
50 errorMsg, warningMsg,
51 fatalErrorMsg, fatalErrorMsg'',
52 compilationProgressMsg,
53 showPass, withTiming,
54 debugTraceMsg,
55 ghcExit,
56 prettyPrintGhcErrors,
57 traceCmd
58 ) where
59
60 #include "HsVersions.h"
61
62 import GhcPrelude
63
64 import Bag
65 import Exception
66 import Outputable
67 import Panic
68 import qualified PprColour as Col
69 import SrcLoc
70 import DynFlags
71 import FastString (unpackFS)
72 import StringBuffer (atLine, hGetStringBuffer, len, lexemeToString)
73 import Json
74
75 import System.Directory
76 import System.Exit ( ExitCode(..), exitWith )
77 import System.FilePath ( takeDirectory, (</>) )
78 import Data.List
79 import qualified Data.Set as Set
80 import Data.IORef
81 import Data.Maybe ( fromMaybe )
82 import Data.Ord
83 import Data.Time
84 import Debug.Trace
85 import Control.Monad
86 import Control.Monad.IO.Class
87 import System.IO
88 import System.IO.Error ( catchIOError )
89 import GHC.Conc ( getAllocationCounter )
90 import System.CPUTime
91
92 -------------------------
93 type MsgDoc = SDoc
94
95 -------------------------
96 data Validity
97 = IsValid -- ^ Everything is fine
98 | NotValid MsgDoc -- ^ A problem, and some indication of why
99
100 isValid :: Validity -> Bool
101 isValid IsValid = True
102 isValid (NotValid {}) = False
103
104 andValid :: Validity -> Validity -> Validity
105 andValid IsValid v = v
106 andValid v _ = v
107
108 -- | If they aren't all valid, return the first
109 allValid :: [Validity] -> Validity
110 allValid [] = IsValid
111 allValid (v : vs) = v `andValid` allValid vs
112
113 getInvalids :: [Validity] -> [MsgDoc]
114 getInvalids vs = [d | NotValid d <- vs]
115
116 orValid :: Validity -> Validity -> Validity
117 orValid IsValid _ = IsValid
118 orValid _ v = v
119
120 -- -----------------------------------------------------------------------------
121 -- Basic error messages: just render a message with a source location.
122
123 type Messages = (WarningMessages, ErrorMessages)
124 type WarningMessages = Bag WarnMsg
125 type ErrorMessages = Bag ErrMsg
126
127 unionMessages :: Messages -> Messages -> Messages
128 unionMessages (warns1, errs1) (warns2, errs2) =
129 (warns1 `unionBags` warns2, errs1 `unionBags` errs2)
130
131 data ErrMsg = ErrMsg {
132 errMsgSpan :: SrcSpan,
133 errMsgContext :: PrintUnqualified,
134 errMsgDoc :: ErrDoc,
135 -- | This has the same text as errDocImportant . errMsgDoc.
136 errMsgShortString :: String,
137 errMsgSeverity :: Severity,
138 errMsgReason :: WarnReason
139 }
140 -- The SrcSpan is used for sorting errors into line-number order
141
142
143 -- | Categorise error msgs by their importance. This is so each section can
144 -- be rendered visually distinct. See Note [Error report] for where these come
145 -- from.
146 data ErrDoc = ErrDoc {
147 -- | Primary error msg.
148 errDocImportant :: [MsgDoc],
149 -- | Context e.g. \"In the second argument of ...\".
150 errDocContext :: [MsgDoc],
151 -- | Supplementary information, e.g. \"Relevant bindings include ...\".
152 errDocSupplementary :: [MsgDoc]
153 }
154
155 errDoc :: [MsgDoc] -> [MsgDoc] -> [MsgDoc] -> ErrDoc
156 errDoc = ErrDoc
157
158 type WarnMsg = ErrMsg
159
160 data Severity
161 = SevOutput
162 | SevFatal
163 | SevInteractive
164
165 | SevDump
166 -- ^ Log message intended for compiler developers
167 -- No file/line/column stuff
168
169 | SevInfo
170 -- ^ Log messages intended for end users.
171 -- No file/line/column stuff.
172
173 | SevWarning
174 | SevError
175 -- ^ SevWarning and SevError are used for warnings and errors
176 -- o The message has a file/line/column heading,
177 -- plus "warning:" or "error:",
178 -- added by mkLocMessags
179 -- o Output is intended for end users
180 deriving Show
181
182
183 instance ToJson Severity where
184 json s = JSString (show s)
185
186
187 instance Show ErrMsg where
188 show em = errMsgShortString em
189
190 pprMessageBag :: Bag MsgDoc -> SDoc
191 pprMessageBag msgs = vcat (punctuate blankLine (bagToList msgs))
192
193 -- | Make an unannotated error message with location info.
194 mkLocMessage :: Severity -> SrcSpan -> MsgDoc -> MsgDoc
195 mkLocMessage = mkLocMessageAnn Nothing
196
197 -- | Make a possibly annotated error message with location info.
198 mkLocMessageAnn
199 :: Maybe String -- ^ optional annotation
200 -> Severity -- ^ severity
201 -> SrcSpan -- ^ location
202 -> MsgDoc -- ^ message
203 -> MsgDoc
204 -- Always print the location, even if it is unhelpful. Error messages
205 -- are supposed to be in a standard format, and one without a location
206 -- would look strange. Better to say explicitly "<no location info>".
207 mkLocMessageAnn ann severity locn msg
208 = sdocWithDynFlags $ \dflags ->
209 let locn' = if gopt Opt_ErrorSpans dflags
210 then ppr locn
211 else ppr (srcSpanStart locn)
212
213 sevColour = getSeverityColour severity (colScheme dflags)
214
215 -- Add optional information
216 optAnn = case ann of
217 Nothing -> text ""
218 Just i -> text " [" <> coloured sevColour (text i) <> text "]"
219
220 -- Add prefixes, like Foo.hs:34: warning:
221 -- <the warning message>
222 header = locn' <> colon <+>
223 coloured sevColour sevText <> optAnn
224
225 in coloured (Col.sMessage (colScheme dflags))
226 (hang (coloured (Col.sHeader (colScheme dflags)) header) 4
227 msg)
228
229 where
230 sevText =
231 case severity of
232 SevWarning -> text "warning:"
233 SevError -> text "error:"
234 SevFatal -> text "fatal:"
235 _ -> empty
236
237 getSeverityColour :: Severity -> Col.Scheme -> Col.PprColour
238 getSeverityColour SevWarning = Col.sWarning
239 getSeverityColour SevError = Col.sError
240 getSeverityColour SevFatal = Col.sFatal
241 getSeverityColour _ = const mempty
242
243 getCaretDiagnostic :: Severity -> SrcSpan -> IO MsgDoc
244 getCaretDiagnostic _ (UnhelpfulSpan _) = pure empty
245 getCaretDiagnostic severity (RealSrcSpan span) = do
246 caretDiagnostic <$> getSrcLine (srcSpanFile span) row
247
248 where
249 getSrcLine fn i =
250 getLine i (unpackFS fn)
251 `catchIOError` \_ ->
252 pure Nothing
253
254 getLine i fn = do
255 -- StringBuffer has advantages over readFile:
256 -- (a) no lazy IO, otherwise IO exceptions may occur in pure code
257 -- (b) always UTF-8, rather than some system-dependent encoding
258 -- (Haskell source code must be UTF-8 anyway)
259 content <- hGetStringBuffer fn
260 case atLine i content of
261 Just at_line -> pure $
262 case lines (fix <$> lexemeToString at_line (len at_line)) of
263 srcLine : _ -> Just srcLine
264 _ -> Nothing
265 _ -> pure Nothing
266
267 -- allow user to visibly see that their code is incorrectly encoded
268 -- (StringBuffer.nextChar uses \0 to represent undecodable characters)
269 fix '\0' = '\xfffd'
270 fix c = c
271
272 row = srcSpanStartLine span
273 rowStr = show row
274 multiline = row /= srcSpanEndLine span
275
276 caretDiagnostic Nothing = empty
277 caretDiagnostic (Just srcLineWithNewline) =
278 sdocWithDynFlags $ \ dflags ->
279 let sevColour = getSeverityColour severity (colScheme dflags)
280 marginColour = Col.sMargin (colScheme dflags)
281 in
282 coloured marginColour (text marginSpace) <>
283 text ("\n") <>
284 coloured marginColour (text marginRow) <>
285 text (" " ++ srcLinePre) <>
286 coloured sevColour (text srcLineSpan) <>
287 text (srcLinePost ++ "\n") <>
288 coloured marginColour (text marginSpace) <>
289 coloured sevColour (text (" " ++ caretLine))
290
291 where
292
293 -- expand tabs in a device-independent manner #13664
294 expandTabs tabWidth i s =
295 case s of
296 "" -> ""
297 '\t' : cs -> replicate effectiveWidth ' ' ++
298 expandTabs tabWidth (i + effectiveWidth) cs
299 c : cs -> c : expandTabs tabWidth (i + 1) cs
300 where effectiveWidth = tabWidth - i `mod` tabWidth
301
302 srcLine = filter (/= '\n') (expandTabs 8 0 srcLineWithNewline)
303
304 start = srcSpanStartCol span - 1
305 end | multiline = length srcLine
306 | otherwise = srcSpanEndCol span - 1
307 width = max 1 (end - start)
308
309 marginWidth = length rowStr
310 marginSpace = replicate marginWidth ' ' ++ " |"
311 marginRow = rowStr ++ " |"
312
313 (srcLinePre, srcLineRest) = splitAt start srcLine
314 (srcLineSpan, srcLinePost) = splitAt width srcLineRest
315
316 caretEllipsis | multiline = "..."
317 | otherwise = ""
318 caretLine = replicate start ' ' ++ replicate width '^' ++ caretEllipsis
319
320 makeIntoWarning :: WarnReason -> ErrMsg -> ErrMsg
321 makeIntoWarning reason err = err
322 { errMsgSeverity = SevWarning
323 , errMsgReason = reason }
324
325 -- -----------------------------------------------------------------------------
326 -- Collecting up messages for later ordering and printing.
327
328 mk_err_msg :: DynFlags -> Severity -> SrcSpan -> PrintUnqualified -> ErrDoc -> ErrMsg
329 mk_err_msg dflags sev locn print_unqual doc
330 = ErrMsg { errMsgSpan = locn
331 , errMsgContext = print_unqual
332 , errMsgDoc = doc
333 , errMsgShortString = showSDoc dflags (vcat (errDocImportant doc))
334 , errMsgSeverity = sev
335 , errMsgReason = NoReason }
336
337 mkErrDoc :: DynFlags -> SrcSpan -> PrintUnqualified -> ErrDoc -> ErrMsg
338 mkErrDoc dflags = mk_err_msg dflags SevError
339
340 mkLongErrMsg, mkLongWarnMsg :: DynFlags -> SrcSpan -> PrintUnqualified -> MsgDoc -> MsgDoc -> ErrMsg
341 -- ^ A long (multi-line) error message
342 mkErrMsg, mkWarnMsg :: DynFlags -> SrcSpan -> PrintUnqualified -> MsgDoc -> ErrMsg
343 -- ^ A short (one-line) error message
344 mkPlainErrMsg, mkPlainWarnMsg :: DynFlags -> SrcSpan -> MsgDoc -> ErrMsg
345 -- ^ Variant that doesn't care about qualified/unqualified names
346
347 mkLongErrMsg dflags locn unqual msg extra = mk_err_msg dflags SevError locn unqual (ErrDoc [msg] [] [extra])
348 mkErrMsg dflags locn unqual msg = mk_err_msg dflags SevError locn unqual (ErrDoc [msg] [] [])
349 mkPlainErrMsg dflags locn msg = mk_err_msg dflags SevError locn alwaysQualify (ErrDoc [msg] [] [])
350 mkLongWarnMsg dflags locn unqual msg extra = mk_err_msg dflags SevWarning locn unqual (ErrDoc [msg] [] [extra])
351 mkWarnMsg dflags locn unqual msg = mk_err_msg dflags SevWarning locn unqual (ErrDoc [msg] [] [])
352 mkPlainWarnMsg dflags locn msg = mk_err_msg dflags SevWarning locn alwaysQualify (ErrDoc [msg] [] [])
353
354 ----------------
355 emptyMessages :: Messages
356 emptyMessages = (emptyBag, emptyBag)
357
358 isEmptyMessages :: Messages -> Bool
359 isEmptyMessages (warns, errs) = isEmptyBag warns && isEmptyBag errs
360
361 errorsFound :: DynFlags -> Messages -> Bool
362 errorsFound _dflags (_warns, errs) = not (isEmptyBag errs)
363
364 warningsToMessages :: DynFlags -> WarningMessages -> Messages
365 warningsToMessages dflags =
366 partitionBagWith $ \warn ->
367 case isWarnMsgFatal dflags warn of
368 Nothing -> Left warn
369 Just err_reason ->
370 Right warn{ errMsgSeverity = SevError
371 , errMsgReason = ErrReason err_reason }
372
373 printBagOfErrors :: DynFlags -> Bag ErrMsg -> IO ()
374 printBagOfErrors dflags bag_of_errors
375 = sequence_ [ let style = mkErrStyle dflags unqual
376 in putLogMsg dflags reason sev s style (formatErrDoc dflags doc)
377 | ErrMsg { errMsgSpan = s,
378 errMsgDoc = doc,
379 errMsgSeverity = sev,
380 errMsgReason = reason,
381 errMsgContext = unqual } <- sortMsgBag (Just dflags)
382 bag_of_errors ]
383
384 formatErrDoc :: DynFlags -> ErrDoc -> SDoc
385 formatErrDoc dflags (ErrDoc important context supplementary)
386 = case msgs of
387 [msg] -> vcat msg
388 _ -> vcat $ map starred msgs
389 where
390 msgs = filter (not . null) $ map (filter (not . Outputable.isEmpty dflags))
391 [important, context, supplementary]
392 starred = (bullet<+>) . vcat
393
394 pprErrMsgBagWithLoc :: Bag ErrMsg -> [SDoc]
395 pprErrMsgBagWithLoc bag = [ pprLocErrMsg item | item <- sortMsgBag Nothing bag ]
396
397 pprLocErrMsg :: ErrMsg -> SDoc
398 pprLocErrMsg (ErrMsg { errMsgSpan = s
399 , errMsgDoc = doc
400 , errMsgSeverity = sev
401 , errMsgContext = unqual })
402 = sdocWithDynFlags $ \dflags ->
403 withPprStyle (mkErrStyle dflags unqual) $
404 mkLocMessage sev s (formatErrDoc dflags doc)
405
406 sortMsgBag :: Maybe DynFlags -> Bag ErrMsg -> [ErrMsg]
407 sortMsgBag dflags = maybeLimit . sortBy (maybeFlip cmp) . bagToList
408 where maybeFlip :: (a -> a -> b) -> (a -> a -> b)
409 maybeFlip
410 | fromMaybe False (fmap reverseErrors dflags) = flip
411 | otherwise = id
412 cmp = comparing errMsgSpan
413 maybeLimit = case join (fmap maxErrors dflags) of
414 Nothing -> id
415 Just err_limit -> take err_limit
416
417 ghcExit :: DynFlags -> Int -> IO ()
418 ghcExit dflags val
419 | val == 0 = exitWith ExitSuccess
420 | otherwise = do errorMsg dflags (text "\nCompilation had errors\n\n")
421 exitWith (ExitFailure val)
422
423 doIfSet :: Bool -> IO () -> IO ()
424 doIfSet flag action | flag = action
425 | otherwise = return ()
426
427 doIfSet_dyn :: DynFlags -> GeneralFlag -> IO () -> IO()
428 doIfSet_dyn dflags flag action | gopt flag dflags = action
429 | otherwise = return ()
430
431 -- -----------------------------------------------------------------------------
432 -- Dumping
433
434 dumpIfSet :: DynFlags -> Bool -> String -> SDoc -> IO ()
435 dumpIfSet dflags flag hdr doc
436 | not flag = return ()
437 | otherwise = putLogMsg dflags
438 NoReason
439 SevDump
440 noSrcSpan
441 (defaultDumpStyle dflags)
442 (mkDumpDoc hdr doc)
443
444 -- | a wrapper around 'dumpSDoc'.
445 -- First check whether the dump flag is set
446 -- Do nothing if it is unset
447 dumpIfSet_dyn :: DynFlags -> DumpFlag -> String -> SDoc -> IO ()
448 dumpIfSet_dyn dflags flag hdr doc
449 = when (dopt flag dflags) $ dumpSDoc dflags alwaysQualify flag hdr doc
450
451 -- | a wrapper around 'dumpSDoc'.
452 -- First check whether the dump flag is set
453 -- Do nothing if it is unset
454 --
455 -- Unlike 'dumpIfSet_dyn',
456 -- has a printer argument but no header argument
457 dumpIfSet_dyn_printer :: PrintUnqualified
458 -> DynFlags -> DumpFlag -> SDoc -> IO ()
459 dumpIfSet_dyn_printer printer dflags flag doc
460 = when (dopt flag dflags) $ dumpSDoc dflags printer flag "" doc
461
462 mkDumpDoc :: String -> SDoc -> SDoc
463 mkDumpDoc hdr doc
464 = vcat [blankLine,
465 line <+> text hdr <+> line,
466 doc,
467 blankLine]
468 where
469 line = text (replicate 20 '=')
470
471 -- | Run an action with the handle of a 'DumpFlag' if we are outputting to a
472 -- file, otherwise 'Nothing'.
473 withDumpFileHandle :: DynFlags -> DumpFlag -> (Maybe Handle -> IO ()) -> IO ()
474 withDumpFileHandle dflags flag action = do
475 let mFile = chooseDumpFile dflags flag
476 case mFile of
477 Just fileName -> do
478 let gdref = generatedDumps dflags
479 gd <- readIORef gdref
480 let append = Set.member fileName gd
481 mode = if append then AppendMode else WriteMode
482 unless append $
483 writeIORef gdref (Set.insert fileName gd)
484 createDirectoryIfMissing True (takeDirectory fileName)
485 withFile fileName mode $ \handle -> do
486 -- We do not want the dump file to be affected by
487 -- environment variables, but instead to always use
488 -- UTF8. See:
489 -- https://gitlab.haskell.org/ghc/ghc/issues/10762
490 hSetEncoding handle utf8
491
492 action (Just handle)
493 Nothing -> action Nothing
494
495
496 dumpSDoc, dumpSDocForUser
497 :: DynFlags -> PrintUnqualified -> DumpFlag -> String -> SDoc -> IO ()
498
499 -- | A wrapper around 'dumpSDocWithStyle' which uses 'PprDump' style.
500 dumpSDoc dflags print_unqual
501 = dumpSDocWithStyle dump_style dflags
502 where dump_style = mkDumpStyle dflags print_unqual
503
504 -- | A wrapper around 'dumpSDocWithStyle' which uses 'PprUser' style.
505 dumpSDocForUser dflags print_unqual
506 = dumpSDocWithStyle user_style dflags
507 where user_style = mkUserStyle dflags print_unqual AllTheWay
508
509 -- | Write out a dump.
510 -- If --dump-to-file is set then this goes to a file.
511 -- otherwise emit to stdout.
512 --
513 -- When @hdr@ is empty, we print in a more compact format (no separators and
514 -- blank lines)
515 --
516 -- The 'DumpFlag' is used only to choose the filename to use if @--dump-to-file@
517 -- is used; it is not used to decide whether to dump the output
518 dumpSDocWithStyle :: PprStyle -> DynFlags -> DumpFlag -> String -> SDoc -> IO ()
519 dumpSDocWithStyle sty dflags flag hdr doc =
520 withDumpFileHandle dflags flag writeDump
521 where
522 -- write dump to file
523 writeDump (Just handle) = do
524 doc' <- if null hdr
525 then return doc
526 else do t <- getCurrentTime
527 let timeStamp = if (gopt Opt_SuppressTimestamps dflags)
528 then empty
529 else text (show t)
530 let d = timeStamp
531 $$ blankLine
532 $$ doc
533 return $ mkDumpDoc hdr d
534 defaultLogActionHPrintDoc dflags handle doc' sty
535
536 -- write the dump to stdout
537 writeDump Nothing = do
538 let (doc', severity)
539 | null hdr = (doc, SevOutput)
540 | otherwise = (mkDumpDoc hdr doc, SevDump)
541 putLogMsg dflags NoReason severity noSrcSpan sty doc'
542
543
544 -- | Choose where to put a dump file based on DynFlags
545 --
546 chooseDumpFile :: DynFlags -> DumpFlag -> Maybe FilePath
547 chooseDumpFile dflags flag
548
549 | gopt Opt_DumpToFile dflags || flag == Opt_D_th_dec_file
550 , Just prefix <- getPrefix
551 = Just $ setDir (prefix ++ (beautifyDumpName flag))
552
553 | otherwise
554 = Nothing
555
556 where getPrefix
557 -- dump file location is being forced
558 -- by the --ddump-file-prefix flag.
559 | Just prefix <- dumpPrefixForce dflags
560 = Just prefix
561 -- dump file location chosen by DriverPipeline.runPipeline
562 | Just prefix <- dumpPrefix dflags
563 = Just prefix
564 -- we haven't got a place to put a dump file.
565 | otherwise
566 = Nothing
567 setDir f = case dumpDir dflags of
568 Just d -> d </> f
569 Nothing -> f
570
571 -- | Build a nice file name from name of a 'DumpFlag' constructor
572 beautifyDumpName :: DumpFlag -> String
573 beautifyDumpName Opt_D_th_dec_file = "th.hs"
574 beautifyDumpName flag
575 = let str = show flag
576 suff = case stripPrefix "Opt_D_" str of
577 Just x -> x
578 Nothing -> panic ("Bad flag name: " ++ str)
579 dash = map (\c -> if c == '_' then '-' else c) suff
580 in dash
581
582
583 -- -----------------------------------------------------------------------------
584 -- Outputting messages from the compiler
585
586 -- We want all messages to go through one place, so that we can
587 -- redirect them if necessary. For example, when GHC is used as a
588 -- library we might want to catch all messages that GHC tries to
589 -- output and do something else with them.
590
591 ifVerbose :: DynFlags -> Int -> IO () -> IO ()
592 ifVerbose dflags val act
593 | verbosity dflags >= val = act
594 | otherwise = return ()
595
596 errorMsg :: DynFlags -> MsgDoc -> IO ()
597 errorMsg dflags msg
598 = putLogMsg dflags NoReason SevError noSrcSpan (defaultErrStyle dflags) msg
599
600 warningMsg :: DynFlags -> MsgDoc -> IO ()
601 warningMsg dflags msg
602 = putLogMsg dflags NoReason SevWarning noSrcSpan (defaultErrStyle dflags) msg
603
604 fatalErrorMsg :: DynFlags -> MsgDoc -> IO ()
605 fatalErrorMsg dflags msg =
606 putLogMsg dflags NoReason SevFatal noSrcSpan (defaultErrStyle dflags) msg
607
608 fatalErrorMsg'' :: FatalMessager -> String -> IO ()
609 fatalErrorMsg'' fm msg = fm msg
610
611 compilationProgressMsg :: DynFlags -> String -> IO ()
612 compilationProgressMsg dflags msg = do
613 traceEventIO $ "GHC progress: " ++ msg
614 ifVerbose dflags 1 $
615 logOutput dflags (defaultUserStyle dflags) (text msg)
616
617 showPass :: DynFlags -> String -> IO ()
618 showPass dflags what
619 = ifVerbose dflags 2 $
620 logInfo dflags (defaultUserStyle dflags) (text "***" <+> text what <> colon)
621
622 -- | Time a compilation phase.
623 --
624 -- When timings are enabled (e.g. with the @-v2@ flag), the allocations
625 -- and CPU time used by the phase will be reported to stderr. Consider
626 -- a typical usage: @withTiming getDynFlags (text "simplify") force pass@.
627 -- When timings are enabled the following costs are included in the
628 -- produced accounting,
629 --
630 -- - The cost of executing @pass@ to a result @r@ in WHNF
631 -- - The cost of evaluating @force r@ to WHNF (e.g. @()@)
632 --
633 -- The choice of the @force@ function depends upon the amount of forcing
634 -- desired; the goal here is to ensure that the cost of evaluating the result
635 -- is, to the greatest extent possible, included in the accounting provided by
636 -- 'withTiming'. Often the pass already sufficiently forces its result during
637 -- construction; in this case @const ()@ is a reasonable choice.
638 -- In other cases, it is necessary to evaluate the result to normal form, in
639 -- which case something like @Control.DeepSeq.rnf@ is appropriate.
640 --
641 -- To avoid adversely affecting compiler performance when timings are not
642 -- requested, the result is only forced when timings are enabled.
643 --
644 -- See Note [withTiming] for more.
645 withTiming :: MonadIO m
646 => m DynFlags -- ^ A means of getting a 'DynFlags' (often
647 -- 'getDynFlags' will work here)
648 -> SDoc -- ^ The name of the phase
649 -> (a -> ()) -- ^ A function to force the result
650 -- (often either @const ()@ or 'rnf')
651 -> m a -- ^ The body of the phase to be timed
652 -> m a
653 withTiming getDFlags what force_result action
654 = do dflags <- getDFlags
655 if verbosity dflags >= 2 || dopt Opt_D_dump_timings dflags
656 then do liftIO $ logInfo dflags (defaultUserStyle dflags)
657 $ text "***" <+> what <> colon
658 liftIO $ traceEventIO $ showSDocOneLine dflags $ text "GHC:started:" <+> what
659 alloc0 <- liftIO getAllocationCounter
660 start <- liftIO getCPUTime
661 !r <- action
662 () <- pure $ force_result r
663 liftIO $ traceEventIO $ showSDocOneLine dflags $ text "GHC:finished:" <+> what
664 end <- liftIO getCPUTime
665 alloc1 <- liftIO getAllocationCounter
666 -- recall that allocation counter counts down
667 let alloc = alloc0 - alloc1
668 time = realToFrac (end - start) * 1e-9
669
670 when (verbosity dflags >= 2)
671 $ liftIO $ logInfo dflags (defaultUserStyle dflags)
672 (text "!!!" <+> what <> colon <+> text "finished in"
673 <+> doublePrec 2 time
674 <+> text "milliseconds"
675 <> comma
676 <+> text "allocated"
677 <+> doublePrec 3 (realToFrac alloc / 1024 / 1024)
678 <+> text "megabytes")
679
680 liftIO $ dumpIfSet_dyn dflags Opt_D_dump_timings ""
681 $ text $ showSDocOneLine dflags
682 $ hsep [ what <> colon
683 , text "alloc=" <> ppr alloc
684 , text "time=" <> doublePrec 3 time
685 ]
686 pure r
687 else action
688
689 debugTraceMsg :: DynFlags -> Int -> MsgDoc -> IO ()
690 debugTraceMsg dflags val msg = ifVerbose dflags val $
691 logInfo dflags (defaultDumpStyle dflags) msg
692 putMsg :: DynFlags -> MsgDoc -> IO ()
693 putMsg dflags msg = logInfo dflags (defaultUserStyle dflags) msg
694
695 printInfoForUser :: DynFlags -> PrintUnqualified -> MsgDoc -> IO ()
696 printInfoForUser dflags print_unqual msg
697 = logInfo dflags (mkUserStyle dflags print_unqual AllTheWay) msg
698
699 printOutputForUser :: DynFlags -> PrintUnqualified -> MsgDoc -> IO ()
700 printOutputForUser dflags print_unqual msg
701 = logOutput dflags (mkUserStyle dflags print_unqual AllTheWay) msg
702
703 logInfo :: DynFlags -> PprStyle -> MsgDoc -> IO ()
704 logInfo dflags sty msg
705 = putLogMsg dflags NoReason SevInfo noSrcSpan sty msg
706
707 logOutput :: DynFlags -> PprStyle -> MsgDoc -> IO ()
708 -- ^ Like 'logInfo' but with 'SevOutput' rather then 'SevInfo'
709 logOutput dflags sty msg
710 = putLogMsg dflags NoReason SevOutput noSrcSpan sty msg
711
712 prettyPrintGhcErrors :: ExceptionMonad m => DynFlags -> m a -> m a
713 prettyPrintGhcErrors dflags
714 = ghandle $ \e -> case e of
715 PprPanic str doc ->
716 pprDebugAndThen dflags panic (text str) doc
717 PprSorry str doc ->
718 pprDebugAndThen dflags sorry (text str) doc
719 PprProgramError str doc ->
720 pprDebugAndThen dflags pgmError (text str) doc
721 _ ->
722 liftIO $ throwIO e
723
724 -- | Checks if given 'WarnMsg' is a fatal warning.
725 isWarnMsgFatal :: DynFlags -> WarnMsg -> Maybe (Maybe WarningFlag)
726 isWarnMsgFatal dflags ErrMsg{errMsgReason = Reason wflag}
727 = if wopt_fatal wflag dflags
728 then Just (Just wflag)
729 else Nothing
730 isWarnMsgFatal dflags _
731 = if gopt Opt_WarnIsError dflags
732 then Just Nothing
733 else Nothing
734
735 traceCmd :: DynFlags -> String -> String -> IO a -> IO a
736 -- trace the command (at two levels of verbosity)
737 traceCmd dflags phase_name cmd_line action
738 = do { let verb = verbosity dflags
739 ; showPass dflags phase_name
740 ; debugTraceMsg dflags 3 (text cmd_line)
741 ; case flushErr dflags of
742 FlushErr io -> io
743
744 -- And run it!
745 ; action `catchIO` handle_exn verb
746 }
747 where
748 handle_exn _verb exn = do { debugTraceMsg dflags 2 (char '\n')
749 ; debugTraceMsg dflags 2
750 (text "Failed:"
751 <+> text cmd_line
752 <+> text (show exn))
753 ; throwGhcExceptionIO (ProgramError (show exn))}
754
755 {- Note [withTiming]
756 ~~~~~~~~~~~~~~~~~~~~
757
758 For reference:
759
760 withTiming
761 :: MonadIO
762 => m DynFlags -- how to get the DynFlags
763 -> SDoc -- label for the computation we're timing
764 -> (a -> ()) -- how to evaluate the result
765 -> m a -- computation we're timing
766 -> m a
767
768 withTiming lets you run an action while:
769
770 (1) measuring the CPU time it took and reporting that on stderr,
771 (2) emitting start/stop events to GHC's event log, with the label
772 given as an argument.
773
774 Evaluation of the result
775 ------------------------
776
777 'withTiming' takes as an argument a function of type 'a -> ()', whose purpose is
778 to evaluate the result "sufficiently". A given pass might return an 'm a' for
779 some monad 'm' and result type 'a', but where the 'a' is complex enough
780 that evaluating it to WHNF barely scratches its surface and leaves many
781 complex and time-consuming computations unevaluated. Those would only be
782 forced by the next pass, and the time needed to evaluate them would be
783 mis-attributed to that next pass. A more appropriate function would be
784 one that deeply evaluates the result, so as to assign the time spent doing it
785 to the pass we're timing.
786
787 Note: as hinted at above, the time spent evaluating the application of the
788 forcing function to the result is included in the timings reported by
789 'withTiming'.
790
791 How we use it
792 -------------
793
794 We measure the time and allocations of various passes in GHC's pipeline by just
795 wrapping the whole pass with 'withTiming'. This also materializes by having
796 a label for each pass in the eventlog, where each pass is executed in one go,
797 during a continuous time window.
798
799 However, from STG onwards, the pipeline uses streams to emit groups of
800 STG/Cmm/etc declarations one at a time, and process them until we get to
801 assembly code generation. This means that the execution of those last few passes
802 is interleaved and that we cannot measure how long they take by just wrapping
803 the whole thing with 'withTiming'. Instead we wrap the processing of each
804 individual stream element, all along the codegen pipeline, using the appropriate
805 label for the pass to which this processing belongs. That generates a lot more
806 data but allows us to get fine-grained timings about all the passes and we can
807 easily compute totals withh tools like ghc-events-analyze (see below).
808
809
810 Producing an eventlog for GHC
811 -----------------------------
812
813 To actually produce the eventlog, you need an eventlog-capable GHC build:
814
815 With Hadrian:
816 $ hadrian/build.sh -j "stage1.ghc-bin.ghc.link.opts += -eventlog"
817
818 With Make:
819 $ make -j GhcStage2HcOpts+=-eventlog
820
821 You can then produce an eventlog when compiling say hello.hs by simply
822 doing:
823
824 If GHC was built by Hadrian:
825 $ _build/stage1/bin/ghc -ddump-timings hello.hs -o hello +RTS -l
826
827 If GHC was built with Make:
828 $ inplace/bin/ghc-stage2 -ddump-timing hello.hs -o hello +RTS -l
829
830 You could alternatively use -v<N> (with N >= 2) instead of -ddump-timings,
831 to ask GHC to report timings (on stderr and the eventlog).
832
833 This will write the eventlog to ./ghc.eventlog in both cases. You can then
834 visualize it or look at the totals for each label by using ghc-events-analyze,
835 threadscope or any other eventlog consumer. Illustrating with
836 ghc-events-analyze:
837
838 $ ghc-events-analyze --timed --timed-txt --totals \
839 --start "GHC:started:" --stop "GHC:finished:" \
840 ghc.eventlog
841
842 This produces ghc.timed.txt (all event timestamps), ghc.timed.svg (visualisation
843 of the execution through the various labels) and ghc.totals.txt (total time
844 spent in each label).
845
846 -}