ErrUtils: Add timings to compiler phases
[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
10 module ErrUtils (
11 -- * Basic types
12 Validity(..), andValid, allValid, isValid, getInvalids,
13 Severity(..),
14
15 -- * Messages
16 MsgDoc, ErrMsg, ErrDoc, errDoc, WarnMsg,
17 Messages, ErrorMessages, WarningMessages,
18 unionMessages,
19 errMsgSpan, errMsgContext,
20 errorsFound, isEmptyMessages,
21
22 -- ** Formatting
23 pprMessageBag, pprErrMsgBagWithLoc,
24 pprLocErrMsg, printBagOfErrors,
25
26 -- ** Construction
27 emptyMessages, mkLocMessage, mkLocMessageAnn, makeIntoWarning,
28 mkErrMsg, mkPlainErrMsg, mkErrDoc, mkLongErrMsg, mkWarnMsg,
29 mkPlainWarnMsg,
30 warnIsErrorMsg, mkLongWarnMsg,
31
32 -- * Utilities
33 doIfSet, doIfSet_dyn,
34
35 -- * Dump files
36 dumpIfSet, dumpIfSet_dyn, dumpIfSet_dyn_printer,
37 mkDumpDoc, dumpSDoc,
38
39 -- * Issuing messages during compilation
40 putMsg, printInfoForUser, printOutputForUser,
41 logInfo, logOutput,
42 errorMsg, warningMsg,
43 fatalErrorMsg, fatalErrorMsg', fatalErrorMsg'',
44 compilationProgressMsg,
45 showPass, withTiming,
46 debugTraceMsg,
47 ghcExit,
48 prettyPrintGhcErrors,
49 ) where
50
51 #include "HsVersions.h"
52
53 import Bag
54 import Exception
55 import Outputable
56 import Panic
57 import SrcLoc
58 import DynFlags
59
60 import System.Directory
61 import System.Exit ( ExitCode(..), exitWith )
62 import System.FilePath ( takeDirectory, (</>) )
63 import Data.List
64 import qualified Data.Set as Set
65 import Data.IORef
66 import Data.Maybe ( fromMaybe )
67 import Data.Ord
68 import Data.Time
69 import Control.Monad
70 import Control.Monad.IO.Class
71 import System.IO
72 import GHC.Conc ( getAllocationCounter )
73 import System.CPUTime
74
75 -------------------------
76 type MsgDoc = SDoc
77
78 -------------------------
79 data Validity
80 = IsValid -- ^ Everything is fine
81 | NotValid MsgDoc -- ^ A problem, and some indication of why
82
83 isValid :: Validity -> Bool
84 isValid IsValid = True
85 isValid (NotValid {}) = False
86
87 andValid :: Validity -> Validity -> Validity
88 andValid IsValid v = v
89 andValid v _ = v
90
91 -- | If they aren't all valid, return the first
92 allValid :: [Validity] -> Validity
93 allValid [] = IsValid
94 allValid (v : vs) = v `andValid` allValid vs
95
96 getInvalids :: [Validity] -> [MsgDoc]
97 getInvalids vs = [d | NotValid d <- vs]
98
99 -- -----------------------------------------------------------------------------
100 -- Basic error messages: just render a message with a source location.
101
102 type Messages = (WarningMessages, ErrorMessages)
103 type WarningMessages = Bag WarnMsg
104 type ErrorMessages = Bag ErrMsg
105
106 unionMessages :: Messages -> Messages -> Messages
107 unionMessages (warns1, errs1) (warns2, errs2) =
108 (warns1 `unionBags` warns2, errs1 `unionBags` errs2)
109
110 data ErrMsg = ErrMsg {
111 errMsgSpan :: SrcSpan,
112 errMsgContext :: PrintUnqualified,
113 errMsgDoc :: ErrDoc,
114 -- | This has the same text as errDocImportant . errMsgDoc.
115 errMsgShortString :: String,
116 errMsgSeverity :: Severity,
117 errMsgReason :: WarnReason
118 }
119 -- The SrcSpan is used for sorting errors into line-number order
120
121 -- | Categorise error msgs by their importance. This is so each section can
122 -- be rendered visually distinct. See Note [Error report] for where these come
123 -- from.
124 data ErrDoc = ErrDoc {
125 -- | Primary error msg.
126 errDocImportant :: [MsgDoc],
127 -- | Context e.g. \"In the second argument of ...\".
128 _errDocContext :: [MsgDoc],
129 -- | Supplementary information, e.g. \"Relevant bindings include ...\".
130 _errDocSupplementary :: [MsgDoc]
131 }
132
133 errDoc :: [MsgDoc] -> [MsgDoc] -> [MsgDoc] -> ErrDoc
134 errDoc = ErrDoc
135
136 type WarnMsg = ErrMsg
137
138 data Severity
139 = SevOutput
140 | SevFatal
141 | SevInteractive
142
143 | SevDump
144 -- ^ Log messagse intended for compiler developers
145 -- No file/line/column stuff
146
147 | SevInfo
148 -- ^ Log messages intended for end users.
149 -- No file/line/column stuff.
150
151 | SevWarning
152 | SevError
153 -- ^ SevWarning and SevError are used for warnings and errors
154 -- o The message has a file/line/column heading,
155 -- plus "warning:" or "error:",
156 -- added by mkLocMessags
157 -- o Output is intended for end users
158
159
160 instance Show ErrMsg where
161 show em = errMsgShortString em
162
163 pprMessageBag :: Bag MsgDoc -> SDoc
164 pprMessageBag msgs = vcat (punctuate blankLine (bagToList msgs))
165
166 mkLocMessage :: Severity -> SrcSpan -> MsgDoc -> MsgDoc
167 mkLocMessage = mkLocMessageAnn Nothing
168
169 mkLocMessageAnn :: Maybe String -> Severity -> SrcSpan -> MsgDoc -> MsgDoc
170 -- Always print the location, even if it is unhelpful. Error messages
171 -- are supposed to be in a standard format, and one without a location
172 -- would look strange. Better to say explicitly "<no location info>".
173 mkLocMessageAnn ann severity locn msg
174 = sdocWithDynFlags $ \dflags ->
175 let locn' = if gopt Opt_ErrorSpans dflags
176 then ppr locn
177 else ppr (srcSpanStart locn)
178 in hang (locn' <> colon <+> sev_info <> opt_ann) 4 msg
179 where
180 -- Add prefixes, like Foo.hs:34: warning:
181 -- <the warning message>
182 sev_info = case severity of
183 SevWarning -> text "warning:"
184 SevError -> text "error:"
185 SevFatal -> text "fatal:"
186 _ -> empty
187
188 -- Add optional information
189 opt_ann = text $ maybe "" (\i -> " ["++i++"]") ann
190
191 makeIntoWarning :: WarnReason -> ErrMsg -> ErrMsg
192 makeIntoWarning reason err = err
193 { errMsgSeverity = SevWarning
194 , errMsgReason = reason }
195
196 -- -----------------------------------------------------------------------------
197 -- Collecting up messages for later ordering and printing.
198
199 mk_err_msg :: DynFlags -> Severity -> SrcSpan -> PrintUnqualified -> ErrDoc -> ErrMsg
200 mk_err_msg dflags sev locn print_unqual doc
201 = ErrMsg { errMsgSpan = locn
202 , errMsgContext = print_unqual
203 , errMsgDoc = doc
204 , errMsgShortString = showSDoc dflags (vcat (errDocImportant doc))
205 , errMsgSeverity = sev
206 , errMsgReason = NoReason }
207
208 mkErrDoc :: DynFlags -> SrcSpan -> PrintUnqualified -> ErrDoc -> ErrMsg
209 mkErrDoc dflags = mk_err_msg dflags SevError
210
211 mkLongErrMsg, mkLongWarnMsg :: DynFlags -> SrcSpan -> PrintUnqualified -> MsgDoc -> MsgDoc -> ErrMsg
212 -- ^ A long (multi-line) error message
213 mkErrMsg, mkWarnMsg :: DynFlags -> SrcSpan -> PrintUnqualified -> MsgDoc -> ErrMsg
214 -- ^ A short (one-line) error message
215 mkPlainErrMsg, mkPlainWarnMsg :: DynFlags -> SrcSpan -> MsgDoc -> ErrMsg
216 -- ^ Variant that doesn't care about qualified/unqualified names
217
218 mkLongErrMsg dflags locn unqual msg extra = mk_err_msg dflags SevError locn unqual (ErrDoc [msg] [] [extra])
219 mkErrMsg dflags locn unqual msg = mk_err_msg dflags SevError locn unqual (ErrDoc [msg] [] [])
220 mkPlainErrMsg dflags locn msg = mk_err_msg dflags SevError locn alwaysQualify (ErrDoc [msg] [] [])
221 mkLongWarnMsg dflags locn unqual msg extra = mk_err_msg dflags SevWarning locn unqual (ErrDoc [msg] [] [extra])
222 mkWarnMsg dflags locn unqual msg = mk_err_msg dflags SevWarning locn unqual (ErrDoc [msg] [] [])
223 mkPlainWarnMsg dflags locn msg = mk_err_msg dflags SevWarning locn alwaysQualify (ErrDoc [msg] [] [])
224
225 ----------------
226 emptyMessages :: Messages
227 emptyMessages = (emptyBag, emptyBag)
228
229 isEmptyMessages :: Messages -> Bool
230 isEmptyMessages (warns, errs) = isEmptyBag warns && isEmptyBag errs
231
232 warnIsErrorMsg :: DynFlags -> ErrMsg
233 warnIsErrorMsg dflags
234 = mkPlainErrMsg dflags noSrcSpan (text "\nFailing due to -Werror.")
235
236 errorsFound :: DynFlags -> Messages -> Bool
237 errorsFound _dflags (_warns, errs) = not (isEmptyBag errs)
238
239 printBagOfErrors :: DynFlags -> Bag ErrMsg -> IO ()
240 printBagOfErrors dflags bag_of_errors
241 = sequence_ [ let style = mkErrStyle dflags unqual
242 in log_action dflags dflags reason sev s style (formatErrDoc dflags doc)
243 | ErrMsg { errMsgSpan = s,
244 errMsgDoc = doc,
245 errMsgSeverity = sev,
246 errMsgReason = reason,
247 errMsgContext = unqual } <- sortMsgBag (Just dflags)
248 bag_of_errors ]
249
250 formatErrDoc :: DynFlags -> ErrDoc -> SDoc
251 formatErrDoc dflags (ErrDoc important context supplementary)
252 = case msgs of
253 [msg] -> vcat msg
254 _ -> vcat $ map starred msgs
255 where
256 msgs = filter (not . null) $ map (filter (not . Outputable.isEmpty dflags))
257 [important, context, supplementary]
258 starred = (bullet<+>) . vcat
259 bullet = text $ if DynFlags.useUnicode dflags then "•" else "*"
260
261 pprErrMsgBagWithLoc :: Bag ErrMsg -> [SDoc]
262 pprErrMsgBagWithLoc bag = [ pprLocErrMsg item | item <- sortMsgBag Nothing bag ]
263
264 pprLocErrMsg :: ErrMsg -> SDoc
265 pprLocErrMsg (ErrMsg { errMsgSpan = s
266 , errMsgDoc = doc
267 , errMsgSeverity = sev
268 , errMsgContext = unqual })
269 = sdocWithDynFlags $ \dflags ->
270 withPprStyle (mkErrStyle dflags unqual) $
271 mkLocMessage sev s (formatErrDoc dflags doc)
272
273 sortMsgBag :: Maybe DynFlags -> Bag ErrMsg -> [ErrMsg]
274 sortMsgBag dflags = sortBy (maybeFlip $ comparing errMsgSpan) . bagToList
275 where maybeFlip :: (a -> a -> b) -> (a -> a -> b)
276 maybeFlip
277 | fromMaybe False (fmap reverseErrors dflags) = flip
278 | otherwise = id
279
280 ghcExit :: DynFlags -> Int -> IO ()
281 ghcExit dflags val
282 | val == 0 = exitWith ExitSuccess
283 | otherwise = do errorMsg dflags (text "\nCompilation had errors\n\n")
284 exitWith (ExitFailure val)
285
286 doIfSet :: Bool -> IO () -> IO ()
287 doIfSet flag action | flag = action
288 | otherwise = return ()
289
290 doIfSet_dyn :: DynFlags -> GeneralFlag -> IO () -> IO()
291 doIfSet_dyn dflags flag action | gopt flag dflags = action
292 | otherwise = return ()
293
294 -- -----------------------------------------------------------------------------
295 -- Dumping
296
297 dumpIfSet :: DynFlags -> Bool -> String -> SDoc -> IO ()
298 dumpIfSet dflags flag hdr doc
299 | not flag = return ()
300 | otherwise = log_action dflags
301 dflags
302 NoReason
303 SevDump
304 noSrcSpan
305 defaultDumpStyle
306 (mkDumpDoc hdr doc)
307
308 -- | a wrapper around 'dumpSDoc'.
309 -- First check whether the dump flag is set
310 -- Do nothing if it is unset
311 dumpIfSet_dyn :: DynFlags -> DumpFlag -> String -> SDoc -> IO ()
312 dumpIfSet_dyn dflags flag hdr doc
313 = when (dopt flag dflags) $ dumpSDoc dflags alwaysQualify flag hdr doc
314
315 -- | a wrapper around 'dumpSDoc'.
316 -- First check whether the dump flag is set
317 -- Do nothing if it is unset
318 --
319 -- Unlike 'dumpIfSet_dyn',
320 -- has a printer argument but no header argument
321 dumpIfSet_dyn_printer :: PrintUnqualified
322 -> DynFlags -> DumpFlag -> SDoc -> IO ()
323 dumpIfSet_dyn_printer printer dflags flag doc
324 = when (dopt flag dflags) $ dumpSDoc dflags printer flag "" doc
325
326 mkDumpDoc :: String -> SDoc -> SDoc
327 mkDumpDoc hdr doc
328 = vcat [blankLine,
329 line <+> text hdr <+> line,
330 doc,
331 blankLine]
332 where
333 line = text (replicate 20 '=')
334
335
336 -- | Write out a dump.
337 -- If --dump-to-file is set then this goes to a file.
338 -- otherwise emit to stdout.
339 --
340 -- When @hdr@ is empty, we print in a more compact format (no separators and
341 -- blank lines)
342 --
343 -- The 'DumpFlag' is used only to choose the filename to use if @--dump-to-file@
344 -- is used; it is not used to decide whether to dump the output
345 dumpSDoc :: DynFlags -> PrintUnqualified -> DumpFlag -> String -> SDoc -> IO ()
346 dumpSDoc dflags print_unqual flag hdr doc
347 = do let mFile = chooseDumpFile dflags flag
348 dump_style = mkDumpStyle print_unqual
349 case mFile of
350 Just fileName
351 -> do
352 let gdref = generatedDumps dflags
353 gd <- readIORef gdref
354 let append = Set.member fileName gd
355 mode = if append then AppendMode else WriteMode
356 when (not append) $
357 writeIORef gdref (Set.insert fileName gd)
358 createDirectoryIfMissing True (takeDirectory fileName)
359 handle <- openFile fileName mode
360
361 -- We do not want the dump file to be affected by
362 -- environment variables, but instead to always use
363 -- UTF8. See:
364 -- https://ghc.haskell.org/trac/ghc/ticket/10762
365 hSetEncoding handle utf8
366
367 doc' <- if null hdr
368 then return doc
369 else do t <- getCurrentTime
370 let d = text (show t)
371 $$ blankLine
372 $$ doc
373 return $ mkDumpDoc hdr d
374 defaultLogActionHPrintDoc dflags handle doc' dump_style
375 hClose handle
376
377 -- write the dump to stdout
378 Nothing -> do
379 let (doc', severity)
380 | null hdr = (doc, SevOutput)
381 | otherwise = (mkDumpDoc hdr doc, SevDump)
382 log_action dflags dflags NoReason severity noSrcSpan dump_style doc'
383
384
385 -- | Choose where to put a dump file based on DynFlags
386 --
387 chooseDumpFile :: DynFlags -> DumpFlag -> Maybe FilePath
388 chooseDumpFile dflags flag
389
390 | gopt Opt_DumpToFile dflags || flag == Opt_D_th_dec_file
391 , Just prefix <- getPrefix
392 = Just $ setDir (prefix ++ (beautifyDumpName flag))
393
394 | otherwise
395 = Nothing
396
397 where getPrefix
398 -- dump file location is being forced
399 -- by the --ddump-file-prefix flag.
400 | Just prefix <- dumpPrefixForce dflags
401 = Just prefix
402 -- dump file location chosen by DriverPipeline.runPipeline
403 | Just prefix <- dumpPrefix dflags
404 = Just prefix
405 -- we haven't got a place to put a dump file.
406 | otherwise
407 = Nothing
408 setDir f = case dumpDir dflags of
409 Just d -> d </> f
410 Nothing -> f
411
412 -- | Build a nice file name from name of a 'DumpFlag' constructor
413 beautifyDumpName :: DumpFlag -> String
414 beautifyDumpName Opt_D_th_dec_file = "th.hs"
415 beautifyDumpName flag
416 = let str = show flag
417 suff = case stripPrefix "Opt_D_" str of
418 Just x -> x
419 Nothing -> panic ("Bad flag name: " ++ str)
420 dash = map (\c -> if c == '_' then '-' else c) suff
421 in dash
422
423
424 -- -----------------------------------------------------------------------------
425 -- Outputting messages from the compiler
426
427 -- We want all messages to go through one place, so that we can
428 -- redirect them if necessary. For example, when GHC is used as a
429 -- library we might want to catch all messages that GHC tries to
430 -- output and do something else with them.
431
432 ifVerbose :: DynFlags -> Int -> IO () -> IO ()
433 ifVerbose dflags val act
434 | verbosity dflags >= val = act
435 | otherwise = return ()
436
437 errorMsg :: DynFlags -> MsgDoc -> IO ()
438 errorMsg dflags msg
439 = log_action dflags dflags NoReason SevError noSrcSpan (defaultErrStyle dflags) msg
440
441 warningMsg :: DynFlags -> MsgDoc -> IO ()
442 warningMsg dflags msg
443 = log_action dflags dflags NoReason SevWarning noSrcSpan (defaultErrStyle dflags) msg
444
445 fatalErrorMsg :: DynFlags -> MsgDoc -> IO ()
446 fatalErrorMsg dflags msg = fatalErrorMsg' (log_action dflags) dflags msg
447
448 fatalErrorMsg' :: LogAction -> DynFlags -> MsgDoc -> IO ()
449 fatalErrorMsg' la dflags msg =
450 la dflags NoReason SevFatal noSrcSpan (defaultErrStyle dflags) msg
451
452 fatalErrorMsg'' :: FatalMessager -> String -> IO ()
453 fatalErrorMsg'' fm msg = fm msg
454
455 compilationProgressMsg :: DynFlags -> String -> IO ()
456 compilationProgressMsg dflags msg
457 = ifVerbose dflags 1 $
458 logOutput dflags defaultUserStyle (text msg)
459
460 showPass :: DynFlags -> String -> IO ()
461 showPass dflags what
462 = ifVerbose dflags 2 $
463 logInfo dflags defaultUserStyle (text "***" <+> text what <> colon)
464
465 -- | Time a compilation phase.
466 --
467 -- When timings are enabled (e.g. with the @-v2@ flag), the allocations
468 -- and CPU time used by the phase will be reported to stderr. Consider
469 -- a typical usage: @withTiming getDynFlags (text "simplify") force pass@.
470 -- When timings are enabled the following costs are included in the
471 -- produced accounting,
472 --
473 -- - The cost of executing @pass@ to a result @r@ in WHNF
474 -- - The cost of evaluating @force r@ to WHNF (e.g. @()@)
475 --
476 -- The choice of the @force@ function depends upon the amount of forcing
477 -- desired; the goal here is to ensure that the cost of evaluating the result
478 -- is, to the greatest extent possible, included in the accounting provided by
479 -- 'withTiming'. Often the pass already sufficiently forces its result during
480 -- construction; in this case @const ()@ is a reasonable choice.
481 -- In other cases, it is necessary to evaluate the result to normal form, in
482 -- which case something like @Control.DeepSeq.rnf@ is appropriate.
483 --
484 -- To avoid adversely affecting compiler performance when timings are not
485 -- requested, the result is only forced when timings are enabled.
486 withTiming :: MonadIO m
487 => m DynFlags -- ^ A means of getting a 'DynFlags' (often
488 -- 'getDynFlags' will work here)
489 -> SDoc -- ^ The name of the phase
490 -> (a -> ()) -- ^ A function to force the result
491 -- (often either @const ()@ or 'rnf')
492 -> m a -- ^ The body of the phase to be timed
493 -> m a
494 withTiming getDFlags what force_result action
495 = do dflags <- getDFlags
496 if verbosity dflags >= 2
497 then do liftIO $ logInfo dflags defaultUserStyle
498 $ text "***" <+> what <> colon
499 alloc0 <- liftIO getAllocationCounter
500 start <- liftIO getCPUTime
501 !r <- action
502 () <- pure $ force_result r
503 end <- liftIO getCPUTime
504 alloc1 <- liftIO getAllocationCounter
505 -- recall that allocation counter counts down
506 let alloc = alloc0 - alloc1
507 liftIO $ logInfo dflags defaultUserStyle
508 (text "!!!" <+> what <> colon <+> text "finished in"
509 <+> doublePrec 2 (realToFrac (end - start) * 1e-9)
510 <+> text "milliseconds"
511 <> comma
512 <+> text "allocated"
513 <+> doublePrec 3 (realToFrac alloc / 1024 / 1024)
514 <+> text "megabytes")
515 pure r
516 else action
517
518 debugTraceMsg :: DynFlags -> Int -> MsgDoc -> IO ()
519 debugTraceMsg dflags val msg = ifVerbose dflags val $
520 logInfo dflags defaultDumpStyle msg
521
522 putMsg :: DynFlags -> MsgDoc -> IO ()
523 putMsg dflags msg = logInfo dflags defaultUserStyle msg
524
525 printInfoForUser :: DynFlags -> PrintUnqualified -> MsgDoc -> IO ()
526 printInfoForUser dflags print_unqual msg
527 = logInfo dflags (mkUserStyle print_unqual AllTheWay) msg
528
529 printOutputForUser :: DynFlags -> PrintUnqualified -> MsgDoc -> IO ()
530 printOutputForUser dflags print_unqual msg
531 = logOutput dflags (mkUserStyle print_unqual AllTheWay) msg
532
533 logInfo :: DynFlags -> PprStyle -> MsgDoc -> IO ()
534 logInfo dflags sty msg
535 = log_action dflags dflags NoReason SevInfo noSrcSpan sty msg
536
537 logOutput :: DynFlags -> PprStyle -> MsgDoc -> IO ()
538 -- ^ Like 'logInfo' but with 'SevOutput' rather then 'SevInfo'
539 logOutput dflags sty msg
540 = log_action dflags dflags NoReason SevOutput noSrcSpan sty msg
541
542 prettyPrintGhcErrors :: ExceptionMonad m => DynFlags -> m a -> m a
543 prettyPrintGhcErrors dflags
544 = ghandle $ \e -> case e of
545 PprPanic str doc ->
546 pprDebugAndThen dflags panic (text str) doc
547 PprSorry str doc ->
548 pprDebugAndThen dflags sorry (text str) doc
549 PprProgramError str doc ->
550 pprDebugAndThen dflags pgmError (text str) doc
551 _ ->
552 liftIO $ throwIO e