ErrUtils.hs 35.9 KB
Newer Older
Austin Seipp's avatar
Austin Seipp committed
1
2
3
{-
(c) The AQUA Project, Glasgow University, 1994-1998

4
\section[ErrsUtils]{Utilities for error reporting}
Austin Seipp's avatar
Austin Seipp committed
5
-}
6

7
{-# LANGUAGE CPP #-}
8
{-# LANGUAGE BangPatterns #-}
9
{-# LANGUAGE RecordWildCards #-}
Sylvain Henry's avatar
Sylvain Henry committed
10
{-# LANGUAGE RankNTypes #-}
Sylvain Henry's avatar
Sylvain Henry committed
11
{-# LANGUAGE LambdaCase #-}
Ian Lynagh's avatar
Ian Lynagh committed
12

13
module ErrUtils (
Ben Gamari's avatar
Ben Gamari committed
14
        -- * Basic types
15
        Validity(..), andValid, allValid, isValid, getInvalids, orValid,
Ben Gamari's avatar
Ben Gamari committed
16
        Severity(..),
17

Ben Gamari's avatar
Ben Gamari committed
18
        -- * Messages
19
        ErrMsg, errMsgDoc, errMsgSeverity, errMsgReason,
20
21
        ErrDoc, errDoc, errDocImportant, errDocContext, errDocSupplementary,
        WarnMsg, MsgDoc,
22
        Messages, ErrorMessages, WarningMessages,
23
        unionMessages,
24
        errMsgSpan, errMsgContext,
Ben Gamari's avatar
Ben Gamari committed
25
        errorsFound, isEmptyMessages,
26
        isWarnMsgFatal,
27
        warningsToMessages,
28

Ben Gamari's avatar
Ben Gamari committed
29
30
31
        -- ** Formatting
        pprMessageBag, pprErrMsgBagWithLoc,
        pprLocErrMsg, printBagOfErrors,
32
        formatErrDoc,
Ben Gamari's avatar
Ben Gamari committed
33
34

        -- ** Construction
35
        emptyMessages, mkLocMessage, mkLocMessageAnn, makeIntoWarning,
36
37
        mkErrMsg, mkPlainErrMsg, mkErrDoc, mkLongErrMsg, mkWarnMsg,
        mkPlainWarnMsg,
38
        mkLongWarnMsg,
dterei's avatar
dterei committed
39

Ben Gamari's avatar
Ben Gamari committed
40
        -- * Utilities
dterei's avatar
dterei committed
41
        doIfSet, doIfSet_dyn,
Rufflewind's avatar
Rufflewind committed
42
        getCaretDiagnostic,
Ben Gamari's avatar
Ben Gamari committed
43
44

        -- * Dump files
45
        dumpIfSet, dumpIfSet_dyn, dumpIfSet_dyn_printer,
Sylvain Henry's avatar
Sylvain Henry committed
46
47
48
49
        dumpOptionsFromFlag, DumpOptions (..),
        DumpFormat (..), DumpAction, dumpAction, defaultDumpAction,
        TraceAction, traceAction, defaultTraceAction,
        touchDumpFile,
50

Ben Gamari's avatar
Ben Gamari committed
51
        -- * Issuing messages during compilation
52
53
        putMsg, printInfoForUser, printOutputForUser,
        logInfo, logOutput,
54
        errorMsg, warningMsg,
Ben Gamari's avatar
Ben Gamari committed
55
        fatalErrorMsg, fatalErrorMsg'',
dterei's avatar
dterei committed
56
        compilationProgressMsg,
57
58
        showPass,
        withTiming, withTimingSilent, withTimingD, withTimingSilentD,
dterei's avatar
dterei committed
59
        debugTraceMsg,
Ben Gamari's avatar
Ben Gamari committed
60
        ghcExit,
Ian Lynagh's avatar
Ian Lynagh committed
61
        prettyPrintGhcErrors,
Douglas Wilson's avatar
Douglas Wilson committed
62
        traceCmd
63
64
    ) where

65
#include "HsVersions.h"
66

67
68
import GhcPrelude

69
import Bag
Ian Lynagh's avatar
Ian Lynagh committed
70
import Exception
71
import Outputable
Ian Lynagh's avatar
Ian Lynagh committed
72
import Panic
Rufflewind's avatar
Rufflewind committed
73
import qualified PprColour as Col
74
import SrcLoc
Sylvain Henry's avatar
Sylvain Henry committed
75
import GHC.Driver.Session
Rufflewind's avatar
Rufflewind committed
76
import FastString (unpackFS)
77
import StringBuffer (atLine, hGetStringBuffer, len, lexemeToString)
78
import Json
Simon Marlow's avatar
Simon Marlow committed
79

80
import System.Directory
dterei's avatar
dterei committed
81
import System.Exit      ( ExitCode(..), exitWith )
82
import System.FilePath  ( takeDirectory, (</>) )
83
import Data.List
84
import qualified Data.Set as Set
85
import Data.IORef
86
import Data.Maybe       ( fromMaybe )
87
import Data.Function
88
import Data.Time
89
import Debug.Trace
90
import Control.Monad
91
import Control.Monad.IO.Class
92
import System.IO
Rufflewind's avatar
Rufflewind committed
93
import System.IO.Error  ( catchIOError )
94
95
import GHC.Conc         ( getAllocationCounter )
import System.CPUTime
sof's avatar
sof committed
96

97
98
99
100
101
-------------------------
type MsgDoc  = SDoc

-------------------------
data Validity
Ben Gamari's avatar
Ben Gamari committed
102
103
  = IsValid            -- ^ Everything is fine
  | NotValid MsgDoc    -- ^ A problem, and some indication of why
104
105
106
107
108
109
110
111
112

isValid :: Validity -> Bool
isValid IsValid       = True
isValid (NotValid {}) = False

andValid :: Validity -> Validity -> Validity
andValid IsValid v = v
andValid v _       = v

Ben Gamari's avatar
Ben Gamari committed
113
114
-- | If they aren't all valid, return the first
allValid :: [Validity] -> Validity
115
116
117
118
119
120
allValid []       = IsValid
allValid (v : vs) = v `andValid` allValid vs

getInvalids :: [Validity] -> [MsgDoc]
getInvalids vs = [d | NotValid d <- vs]

121
122
123
124
orValid :: Validity -> Validity -> Validity
orValid IsValid _ = IsValid
orValid _       v = v

125
126
127
-- -----------------------------------------------------------------------------
-- Basic error messages: just render a message with a source location.

128
129
130
type Messages        = (WarningMessages, ErrorMessages)
type WarningMessages = Bag WarnMsg
type ErrorMessages   = Bag ErrMsg
131

132
133
134
135
unionMessages :: Messages -> Messages -> Messages
unionMessages (warns1, errs1) (warns2, errs2) =
  (warns1 `unionBags` warns2, errs1 `unionBags` errs2)

136
data ErrMsg = ErrMsg {
137
138
        errMsgSpan        :: SrcSpan,
        errMsgContext     :: PrintUnqualified,
139
140
141
        errMsgDoc         :: ErrDoc,
        -- | This has the same text as errDocImportant . errMsgDoc.
        errMsgShortString :: String,
142
143
        errMsgSeverity    :: Severity,
        errMsgReason      :: WarnReason
144
145
146
        }
        -- The SrcSpan is used for sorting errors into line-number order

147

148
149
150
151
152
-- | Categorise error msgs by their importance.  This is so each section can
-- be rendered visually distinct.  See Note [Error report] for where these come
-- from.
data ErrDoc = ErrDoc {
        -- | Primary error msg.
153
        errDocImportant     :: [MsgDoc],
154
        -- | Context e.g. \"In the second argument of ...\".
155
        errDocContext       :: [MsgDoc],
156
        -- | Supplementary information, e.g. \"Relevant bindings include ...\".
157
        errDocSupplementary :: [MsgDoc]
158
159
160
161
162
        }

errDoc :: [MsgDoc] -> [MsgDoc] -> [MsgDoc] -> ErrDoc
errDoc = ErrDoc

163
type WarnMsg = ErrMsg
164

165
data Severity
166
  = SevOutput
167
  | SevFatal
168
  | SevInteractive
169
170

  | SevDump
Gabor Greif's avatar
Gabor Greif committed
171
    -- ^ Log message intended for compiler developers
172
173
    -- No file/line/column stuff

174
  | SevInfo
Ben Gamari's avatar
Ben Gamari committed
175
    -- ^ Log messages intended for end users.
176
177
    -- No file/line/column stuff.

178
179
  | SevWarning
  | SevError
Ben Gamari's avatar
Ben Gamari committed
180
    -- ^ SevWarning and SevError are used for warnings and errors
181
182
183
184
    --   o The message has a file/line/column heading,
    --     plus "warning:" or "error:",
    --     added by mkLocMessags
    --   o Output is intended for end users
185
186
187
188
189
  deriving Show


instance ToJson Severity where
  json s = JSString (show s)
190

191

192
instance Show ErrMsg where
193
    show em = errMsgShortString em
194
195
196
197

pprMessageBag :: Bag MsgDoc -> SDoc
pprMessageBag msgs = vcat (punctuate blankLine (bagToList msgs))

198
-- | Make an unannotated error message with location info.
199
mkLocMessage :: Severity -> SrcSpan -> MsgDoc -> MsgDoc
200
201
mkLocMessage = mkLocMessageAnn Nothing

202
203
204
205
206
207
208
-- | Make a possibly annotated error message with location info.
mkLocMessageAnn
  :: Maybe String                       -- ^ optional annotation
  -> Severity                           -- ^ severity
  -> SrcSpan                            -- ^ location
  -> MsgDoc                             -- ^ message
  -> MsgDoc
209
  -- Always print the location, even if it is unhelpful.  Error messages
210
211
  -- are supposed to be in a standard format, and one without a location
  -- would look strange.  Better to say explicitly "<no location info>".
212
mkLocMessageAnn ann severity locn msg
Sylvain Henry's avatar
Sylvain Henry committed
213
214
215
216
    = sdocOption sdocColScheme $ \col_scheme ->
      let locn' = sdocOption sdocErrorSpans $ \case
                     True  -> ppr locn
                     False -> ppr (srcSpanStart locn)
Rufflewind's avatar
Rufflewind committed
217

Sylvain Henry's avatar
Sylvain Henry committed
218
          sevColour = getSeverityColour severity col_scheme
Rufflewind's avatar
Rufflewind committed
219
220
221
222
223
224

          -- Add optional information
          optAnn = case ann of
            Nothing -> text ""
            Just i  -> text " [" <> coloured sevColour (text i) <> text "]"

225
226
          -- Add prefixes, like    Foo.hs:34: warning:
          --                           <the warning message>
Rufflewind's avatar
Rufflewind committed
227
          header = locn' <> colon <+>
Rufflewind's avatar
Rufflewind committed
228
229
                   coloured sevColour sevText <> optAnn

Sylvain Henry's avatar
Sylvain Henry committed
230
231
      in coloured (Col.sMessage col_scheme)
                  (hang (coloured (Col.sHeader col_scheme) header) 4
Rufflewind's avatar
Rufflewind committed
232
                        msg)
Rufflewind's avatar
Rufflewind committed
233
234

  where
Rufflewind's avatar
Rufflewind committed
235
    sevText =
236
      case severity of
Rufflewind's avatar
Rufflewind committed
237
238
239
240
        SevWarning -> text "warning:"
        SevError   -> text "error:"
        SevFatal   -> text "fatal:"
        _          -> empty
241

Rufflewind's avatar
Rufflewind committed
242
243
244
245
246
getSeverityColour :: Severity -> Col.Scheme -> Col.PprColour
getSeverityColour SevWarning = Col.sWarning
getSeverityColour SevError   = Col.sError
getSeverityColour SevFatal   = Col.sFatal
getSeverityColour _          = const mempty
Rufflewind's avatar
Rufflewind committed
247
248
249

getCaretDiagnostic :: Severity -> SrcSpan -> IO MsgDoc
getCaretDiagnostic _ (UnhelpfulSpan _) = pure empty
250
getCaretDiagnostic severity (RealSrcSpan span _) = do
251
  caretDiagnostic <$> getSrcLine (srcSpanFile span) row
Rufflewind's avatar
Rufflewind committed
252
253

  where
254
255
256
    getSrcLine fn i =
      getLine i (unpackFS fn)
        `catchIOError` \_ ->
Rufflewind's avatar
Rufflewind committed
257
258
          pure Nothing

259
    getLine i fn = do
Rufflewind's avatar
Rufflewind committed
260
261
262
263
      -- StringBuffer has advantages over readFile:
      -- (a) no lazy IO, otherwise IO exceptions may occur in pure code
      -- (b) always UTF-8, rather than some system-dependent encoding
      --     (Haskell source code must be UTF-8 anyway)
264
265
266
267
268
269
270
      content <- hGetStringBuffer fn
      case atLine i content of
        Just at_line -> pure $
          case lines (fix <$> lexemeToString at_line (len at_line)) of
            srcLine : _ -> Just srcLine
            _           -> Nothing
        _ -> pure Nothing
Rufflewind's avatar
Rufflewind committed
271
272
273
274
275
276
277
278
279
280
281
282

    -- allow user to visibly see that their code is incorrectly encoded
    -- (StringBuffer.nextChar uses \0 to represent undecodable characters)
    fix '\0' = '\xfffd'
    fix c    = c

    row = srcSpanStartLine span
    rowStr = show row
    multiline = row /= srcSpanEndLine span

    caretDiagnostic Nothing = empty
    caretDiagnostic (Just srcLineWithNewline) =
Sylvain Henry's avatar
Sylvain Henry committed
283
284
285
      sdocOption sdocColScheme$ \col_scheme ->
      let sevColour = getSeverityColour severity col_scheme
          marginColour = Col.sMargin col_scheme
Rufflewind's avatar
Rufflewind committed
286
      in
Rufflewind's avatar
Rufflewind committed
287
288
289
290
291
292
293
294
295
296
297
      coloured marginColour (text marginSpace) <>
      text ("\n") <>
      coloured marginColour (text marginRow) <>
      text (" " ++ srcLinePre) <>
      coloured sevColour (text srcLineSpan) <>
      text (srcLinePost ++ "\n") <>
      coloured marginColour (text marginSpace) <>
      coloured sevColour (text (" " ++ caretLine))

      where

298
299
300
301
302
303
304
305
306
307
        -- expand tabs in a device-independent manner #13664
        expandTabs tabWidth i s =
          case s of
            ""        -> ""
            '\t' : cs -> replicate effectiveWidth ' ' ++
                         expandTabs tabWidth (i + effectiveWidth) cs
            c    : cs -> c : expandTabs tabWidth (i + 1) cs
          where effectiveWidth = tabWidth - i `mod` tabWidth

        srcLine = filter (/= '\n') (expandTabs 8 0 srcLineWithNewline)
Rufflewind's avatar
Rufflewind committed
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323

        start = srcSpanStartCol span - 1
        end | multiline = length srcLine
            | otherwise = srcSpanEndCol span - 1
        width = max 1 (end - start)

        marginWidth = length rowStr
        marginSpace = replicate marginWidth ' ' ++ " |"
        marginRow   = rowStr ++ " |"

        (srcLinePre,  srcLineRest) = splitAt start srcLine
        (srcLineSpan, srcLinePost) = splitAt width srcLineRest

        caretEllipsis | multiline = "..."
                      | otherwise = ""
        caretLine = replicate start ' ' ++ replicate width '^' ++ caretEllipsis
324
325
326
327
328

makeIntoWarning :: WarnReason -> ErrMsg -> ErrMsg
makeIntoWarning reason err = err
    { errMsgSeverity = SevWarning
    , errMsgReason = reason }
329

330
331
332
-- -----------------------------------------------------------------------------
-- Collecting up messages for later ordering and printing.

333
334
335
336
337
338
mk_err_msg :: DynFlags -> Severity -> SrcSpan -> PrintUnqualified -> ErrDoc -> ErrMsg
mk_err_msg dflags sev locn print_unqual doc
 = ErrMsg { errMsgSpan = locn
          , errMsgContext = print_unqual
          , errMsgDoc = doc
          , errMsgShortString = showSDoc dflags (vcat (errDocImportant doc))
339
340
          , errMsgSeverity = sev
          , errMsgReason = NoReason }
341

342
343
344
mkErrDoc :: DynFlags -> SrcSpan -> PrintUnqualified -> ErrDoc -> ErrMsg
mkErrDoc dflags = mk_err_msg dflags SevError

Ian Lynagh's avatar
Ian Lynagh committed
345
mkLongErrMsg, mkLongWarnMsg   :: DynFlags -> SrcSpan -> PrintUnqualified -> MsgDoc -> MsgDoc -> ErrMsg
Ben Gamari's avatar
Ben Gamari committed
346
-- ^ A long (multi-line) error message
Ian Lynagh's avatar
Ian Lynagh committed
347
mkErrMsg, mkWarnMsg           :: DynFlags -> SrcSpan -> PrintUnqualified -> MsgDoc            -> ErrMsg
Ben Gamari's avatar
Ben Gamari committed
348
-- ^ A short (one-line) error message
Ian Lynagh's avatar
Ian Lynagh committed
349
mkPlainErrMsg, mkPlainWarnMsg :: DynFlags -> SrcSpan ->                     MsgDoc            -> ErrMsg
Ben Gamari's avatar
Ben Gamari committed
350
-- ^ Variant that doesn't care about qualified/unqualified names
351

352
353
354
355
356
357
mkLongErrMsg   dflags locn unqual msg extra = mk_err_msg dflags SevError   locn unqual        (ErrDoc [msg] [] [extra])
mkErrMsg       dflags locn unqual msg       = mk_err_msg dflags SevError   locn unqual        (ErrDoc [msg] [] [])
mkPlainErrMsg  dflags locn        msg       = mk_err_msg dflags SevError   locn alwaysQualify (ErrDoc [msg] [] [])
mkLongWarnMsg  dflags locn unqual msg extra = mk_err_msg dflags SevWarning locn unqual        (ErrDoc [msg] [] [extra])
mkWarnMsg      dflags locn unqual msg       = mk_err_msg dflags SevWarning locn unqual        (ErrDoc [msg] [] [])
mkPlainWarnMsg dflags locn        msg       = mk_err_msg dflags SevWarning locn alwaysQualify (ErrDoc [msg] [] [])
358

359
----------------
360
361
362
emptyMessages :: Messages
emptyMessages = (emptyBag, emptyBag)

363
364
365
isEmptyMessages :: Messages -> Bool
isEmptyMessages (warns, errs) = isEmptyBag warns && isEmptyBag errs

366
errorsFound :: DynFlags -> Messages -> Bool
367
errorsFound _dflags (_warns, errs) = not (isEmptyBag errs)
368

369
370
371
372
373
374
375
376
377
warningsToMessages :: DynFlags -> WarningMessages -> Messages
warningsToMessages dflags =
  partitionBagWith $ \warn ->
    case isWarnMsgFatal dflags warn of
      Nothing -> Left warn
      Just err_reason ->
        Right warn{ errMsgSeverity = SevError
                  , errMsgReason = ErrReason err_reason }

378
printBagOfErrors :: DynFlags -> Bag ErrMsg -> IO ()
379
printBagOfErrors dflags bag_of_errors
380
  = sequence_ [ let style = mkErrStyle dflags unqual
Sylvain Henry's avatar
Sylvain Henry committed
381
382
                    ctx   = initSDocContext dflags style
                in putLogMsg dflags reason sev s style (formatErrDoc ctx doc)
383
              | ErrMsg { errMsgSpan      = s,
384
                         errMsgDoc       = doc,
385
                         errMsgSeverity  = sev,
386
                         errMsgReason    = reason,
387
                         errMsgContext   = unqual } <- sortMsgBag (Just dflags)
388
389
                                                                  bag_of_errors ]

Sylvain Henry's avatar
Sylvain Henry committed
390
391
formatErrDoc :: SDocContext -> ErrDoc -> SDoc
formatErrDoc ctx (ErrDoc important context supplementary)
392
393
394
395
  = case msgs of
        [msg] -> vcat msg
        _ -> vcat $ map starred msgs
    where
Sylvain Henry's avatar
Sylvain Henry committed
396
    msgs = filter (not . null) $ map (filter (not . Outputable.isEmpty ctx))
397
398
        [important, context, supplementary]
    starred = (bullet<+>) . vcat
399

400
pprErrMsgBagWithLoc :: Bag ErrMsg -> [SDoc]
401
pprErrMsgBagWithLoc bag = [ pprLocErrMsg item | item <- sortMsgBag Nothing bag ]
402

403
pprLocErrMsg :: ErrMsg -> SDoc
404
pprLocErrMsg (ErrMsg { errMsgSpan      = s
405
                     , errMsgDoc       = doc
406
407
                     , errMsgSeverity  = sev
                     , errMsgContext   = unqual })
Sylvain Henry's avatar
Sylvain Henry committed
408
409
  = sdocWithContext $ \ctx ->
    withErrStyle unqual $ mkLocMessage sev s (formatErrDoc ctx doc)
410

411
sortMsgBag :: Maybe DynFlags -> Bag ErrMsg -> [ErrMsg]
412
413
414
415
sortMsgBag dflags = maybeLimit . sortBy (cmp `on` errMsgSpan) . bagToList
  where cmp
          | fromMaybe False (fmap reverseErrors dflags) = SrcLoc.rightmost_smallest
          | otherwise                                   = SrcLoc.leftmost_smallest
coopercm's avatar
coopercm committed
416
417
418
        maybeLimit = case join (fmap maxErrors dflags) of
          Nothing        -> id
          Just err_limit -> take err_limit
419

420
421
ghcExit :: DynFlags -> Int -> IO ()
ghcExit dflags val
422
  | val == 0  = exitWith ExitSuccess
423
  | otherwise = do errorMsg dflags (text "\nCompilation had errors\n\n")
dterei's avatar
dterei committed
424
                   exitWith (ExitFailure val)
sof's avatar
sof committed
425
426
427

doIfSet :: Bool -> IO () -> IO ()
doIfSet flag action | flag      = action
dterei's avatar
dterei committed
428
                    | otherwise = return ()
429

430
doIfSet_dyn :: DynFlags -> GeneralFlag -> IO () -> IO()
ian@well-typed.com's avatar
ian@well-typed.com committed
431
doIfSet_dyn dflags flag action | gopt flag dflags = action
dterei's avatar
dterei committed
432
                               | otherwise        = return ()
sof's avatar
sof committed
433

434
435
436
-- -----------------------------------------------------------------------------
-- Dumping

437
438
dumpIfSet :: DynFlags -> Bool -> String -> SDoc -> IO ()
dumpIfSet dflags flag hdr doc
439
  | not flag   = return ()
Ben Gamari's avatar
Ben Gamari committed
440
  | otherwise  = putLogMsg  dflags
441
442
443
                            NoReason
                            SevDump
                            noSrcSpan
Sylvain Henry's avatar
Sylvain Henry committed
444
                            (defaultDumpStyle dflags)
445
                            (mkDumpDoc hdr doc)
446

Sylvain Henry's avatar
Sylvain Henry committed
447
-- | a wrapper around 'dumpAction'.
448
449
-- First check whether the dump flag is set
-- Do nothing if it is unset
Sylvain Henry's avatar
Sylvain Henry committed
450
451
dumpIfSet_dyn :: DynFlags -> DumpFlag -> String -> DumpFormat -> SDoc -> IO ()
dumpIfSet_dyn = dumpIfSet_dyn_printer alwaysQualify
452

Sylvain Henry's avatar
Sylvain Henry committed
453
-- | a wrapper around 'dumpAction'.
454
455
456
-- First check whether the dump flag is set
-- Do nothing if it is unset
--
Sylvain Henry's avatar
Sylvain Henry committed
457
458
459
460
461
462
463
-- Unlike 'dumpIfSet_dyn', has a printer argument
dumpIfSet_dyn_printer :: PrintUnqualified -> DynFlags -> DumpFlag -> String
                         -> DumpFormat -> SDoc -> IO ()
dumpIfSet_dyn_printer printer dflags flag hdr fmt doc
  = when (dopt flag dflags) $ do
      let sty = mkDumpStyle dflags printer
      dumpAction dflags sty (dumpOptionsFromFlag flag) hdr fmt doc
464

twanvl's avatar
twanvl committed
465
mkDumpDoc :: String -> SDoc -> SDoc
dterei's avatar
dterei committed
466
mkDumpDoc hdr doc
467
   = vcat [blankLine,
dterei's avatar
dterei committed
468
469
470
471
           line <+> text hdr <+> line,
           doc,
           blankLine]
     where
sof's avatar
sof committed
472
        line = text (replicate 20 '=')
473

Sylvain Henry's avatar
Sylvain Henry committed
474
475
476
477
478

-- | Ensure that a dump file is created even if it stays empty
touchDumpFile :: DynFlags -> DumpOptions -> IO ()
touchDumpFile dflags dumpOpt = withDumpFileHandle dflags dumpOpt (const (return ()))

479
480
-- | Run an action with the handle of a 'DumpFlag' if we are outputting to a
-- file, otherwise 'Nothing'.
Sylvain Henry's avatar
Sylvain Henry committed
481
482
483
withDumpFileHandle :: DynFlags -> DumpOptions -> (Maybe Handle -> IO ()) -> IO ()
withDumpFileHandle dflags dumpOpt action = do
    let mFile = chooseDumpFile dflags dumpOpt
484
485
486
487
488
489
490
491
492
493
494
495
496
    case mFile of
      Just fileName -> do
        let gdref = generatedDumps dflags
        gd <- readIORef gdref
        let append = Set.member fileName gd
            mode = if append then AppendMode else WriteMode
        unless append $
            writeIORef gdref (Set.insert fileName gd)
        createDirectoryIfMissing True (takeDirectory fileName)
        withFile fileName mode $ \handle -> do
            -- We do not want the dump file to be affected by
            -- environment variables, but instead to always use
            -- UTF8. See:
497
            -- https://gitlab.haskell.org/ghc/ghc/issues/10762
498
499
500
501
            hSetEncoding handle utf8

            action (Just handle)
      Nothing -> action Nothing
502

503

504
-- | Write out a dump.
Ben Gamari's avatar
Ben Gamari committed
505
506
-- If --dump-to-file is set then this goes to a file.
-- otherwise emit to stdout.
507
--
Ben Gamari's avatar
Ben Gamari committed
508
-- When @hdr@ is empty, we print in a more compact format (no separators and
509
-- blank lines)
Sylvain Henry's avatar
Sylvain Henry committed
510
511
512
dumpSDocWithStyle :: PprStyle -> DynFlags -> DumpOptions -> String -> SDoc -> IO ()
dumpSDocWithStyle sty dflags dumpOpt hdr doc =
    withDumpFileHandle dflags dumpOpt writeDump
513
514
515
516
517
518
  where
    -- write dump to file
    writeDump (Just handle) = do
        doc' <- if null hdr
                then return doc
                else do t <- getCurrentTime
519
520
521
522
523
524
                        let timeStamp = if (gopt Opt_SuppressTimestamps dflags)
                                          then empty
                                          else text (show t)
                        let d = timeStamp
                                $$ blankLine
                                $$ doc
525
                        return $ mkDumpDoc hdr d
526
        defaultLogActionHPrintDoc dflags handle doc' sty
527
528
529
530
531
532

    -- write the dump to stdout
    writeDump Nothing = do
        let (doc', severity)
              | null hdr  = (doc, SevOutput)
              | otherwise = (mkDumpDoc hdr doc, SevDump)
533
        putLogMsg dflags NoReason severity noSrcSpan sty doc'
534
535
536
537


-- | Choose where to put a dump file based on DynFlags
--
Sylvain Henry's avatar
Sylvain Henry committed
538
539
chooseDumpFile :: DynFlags -> DumpOptions -> Maybe FilePath
chooseDumpFile dflags dumpOpt
540

Sylvain Henry's avatar
Sylvain Henry committed
541
        | gopt Opt_DumpToFile dflags || dumpForcedToFile dumpOpt
542
        , Just prefix <- getPrefix
Sylvain Henry's avatar
Sylvain Henry committed
543
        = Just $ setDir (prefix ++ dumpSuffix dumpOpt)
544

dterei's avatar
dterei committed
545
546
        | otherwise
        = Nothing
547

548
549
550
551
552
        where getPrefix
                 -- dump file location is being forced
                 --      by the --ddump-file-prefix flag.
               | Just prefix <- dumpPrefixForce dflags
                  = Just prefix
Sylvain Henry's avatar
Sylvain Henry committed
553
                 -- dump file location chosen by GHC.Driver.Pipeline.runPipeline
554
555
556
557
558
559
560
561
               | Just prefix <- dumpPrefix dflags
                  = Just prefix
                 -- we haven't got a place to put a dump file.
               | otherwise
                  = Nothing
              setDir f = case dumpDir dflags of
                         Just d  -> d </> f
                         Nothing ->       f
562

Sylvain Henry's avatar
Sylvain Henry committed
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
-- | Dump options
--
-- Dumps are printed on stdout by default except when the `dumpForcedToFile`
-- field is set to True.
--
-- When `dumpForcedToFile` is True or when `-ddump-to-file` is set, dumps are
-- written into a file whose suffix is given in the `dumpSuffix` field.
--
data DumpOptions = DumpOptions
   { dumpForcedToFile :: Bool   -- ^ Must be dumped into a file, even if
                                --   -ddump-to-file isn't set
   , dumpSuffix       :: String -- ^ Filename suffix used when dumped into
                                --   a file
   }

-- | Create dump options from a 'DumpFlag'
dumpOptionsFromFlag :: DumpFlag -> DumpOptions
dumpOptionsFromFlag Opt_D_th_dec_file =
   DumpOptions                        -- -dth-dec-file dumps expansions of TH
      { dumpForcedToFile = True       -- splices into MODULE.th.hs even when
      , dumpSuffix       = "th.hs"    -- -ddump-to-file isn't set
      }
dumpOptionsFromFlag flag =
   DumpOptions
      { dumpForcedToFile = False
      , dumpSuffix       = suffix -- build a suffix from the flag name
      }                           -- e.g. -ddump-asm => ".dump-asm"
   where
      str  = show flag
      suff = case stripPrefix "Opt_D_" str of
             Just x  -> x
             Nothing -> panic ("Bad flag name: " ++ str)
      suffix = map (\c -> if c == '_' then '-' else c) suff
596
597


598
599
600
601
602
603
604
605
606
607
608
609
610
-- -----------------------------------------------------------------------------
-- Outputting messages from the compiler

-- We want all messages to go through one place, so that we can
-- redirect them if necessary.  For example, when GHC is used as a
-- library we might want to catch all messages that GHC tries to
-- output and do something else with them.

ifVerbose :: DynFlags -> Int -> IO () -> IO ()
ifVerbose dflags val act
  | verbosity dflags >= val = act
  | otherwise               = return ()

611
errorMsg :: DynFlags -> MsgDoc -> IO ()
612
errorMsg dflags msg
Ben Gamari's avatar
Ben Gamari committed
613
   = putLogMsg dflags NoReason SevError noSrcSpan (defaultErrStyle dflags) msg
614

615
616
warningMsg :: DynFlags -> MsgDoc -> IO ()
warningMsg dflags msg
Ben Gamari's avatar
Ben Gamari committed
617
   = putLogMsg dflags NoReason SevWarning noSrcSpan (defaultErrStyle dflags) msg
618

619
fatalErrorMsg :: DynFlags -> MsgDoc -> IO ()
Ben Gamari's avatar
Ben Gamari committed
620
621
fatalErrorMsg dflags msg =
    putLogMsg dflags NoReason SevFatal noSrcSpan (defaultErrStyle dflags) msg
Ian Lynagh's avatar
Ian Lynagh committed
622
623
624

fatalErrorMsg'' :: FatalMessager -> String -> IO ()
fatalErrorMsg'' fm msg = fm msg
625
626

compilationProgressMsg :: DynFlags -> String -> IO ()
627
628
629
630
compilationProgressMsg dflags msg = do
    traceEventIO $ "GHC progress: " ++ msg
    ifVerbose dflags 1 $
        logOutput dflags (defaultUserStyle dflags) (text msg)
631

632
showPass :: DynFlags -> String -> IO ()
dterei's avatar
dterei committed
633
showPass dflags what
634
  = ifVerbose dflags 2 $
Sylvain Henry's avatar
Sylvain Henry committed
635
    logInfo dflags (defaultUserStyle dflags) (text "***" <+> text what <> colon)
636

637
638
639
data PrintTimings = PrintTimings | DontPrintTimings
  deriving (Eq, Show)

640
641
642
643
-- | Time a compilation phase.
--
-- When timings are enabled (e.g. with the @-v2@ flag), the allocations
-- and CPU time used by the phase will be reported to stderr. Consider
644
645
-- a typical usage:
-- @withTiming getDynFlags (text "simplify") force PrintTimings pass@.
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
-- When timings are enabled the following costs are included in the
-- produced accounting,
--
--  - The cost of executing @pass@ to a result @r@ in WHNF
--  - The cost of evaluating @force r@ to WHNF (e.g. @()@)
--
-- The choice of the @force@ function depends upon the amount of forcing
-- desired; the goal here is to ensure that the cost of evaluating the result
-- is, to the greatest extent possible, included in the accounting provided by
-- 'withTiming'. Often the pass already sufficiently forces its result during
-- construction; in this case @const ()@ is a reasonable choice.
-- In other cases, it is necessary to evaluate the result to normal form, in
-- which case something like @Control.DeepSeq.rnf@ is appropriate.
--
-- To avoid adversely affecting compiler performance when timings are not
-- requested, the result is only forced when timings are enabled.
662
663
--
-- See Note [withTiming] for more.
664
withTiming :: MonadIO m
665
           => DynFlags     -- ^ DynFlags
666
667
668
669
           -> SDoc         -- ^ The name of the phase
           -> (a -> ())    -- ^ A function to force the result
                           -- (often either @const ()@ or 'rnf')
           -> m a          -- ^ The body of the phase to be timed
670
           -> m a
671
672
673
674
675
676
677
678
679
680
681
682
683
withTiming dflags what force action =
  withTiming' dflags what force PrintTimings action

-- | Like withTiming but get DynFlags from the Monad.
withTimingD :: (MonadIO m, HasDynFlags m)
           => SDoc         -- ^ The name of the phase
           -> (a -> ())    -- ^ A function to force the result
                           -- (often either @const ()@ or 'rnf')
           -> m a          -- ^ The body of the phase to be timed
           -> m a
withTimingD what force action = do
  dflags <- getDynFlags
  withTiming' dflags what force PrintTimings action
684
685
686
687
688
689
690
691


-- | Same as 'withTiming', but doesn't print timings in the
--   console (when given @-vN@, @N >= 2@ or @-ddump-timings@).
--
--   See Note [withTiming] for more.
withTimingSilent
  :: MonadIO m
692
  => DynFlags   -- ^ DynFlags
693
694
695
696
697
  -> SDoc       -- ^ The name of the phase
  -> (a -> ())  -- ^ A function to force the result
                -- (often either @const ()@ or 'rnf')
  -> m a        -- ^ The body of the phase to be timed
  -> m a
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
withTimingSilent dflags what force action =
  withTiming' dflags what force DontPrintTimings action

-- | Same as 'withTiming', but doesn't print timings in the
--   console (when given @-vN@, @N >= 2@ or @-ddump-timings@)
--   and gets the DynFlags from the given Monad.
--
--   See Note [withTiming] for more.
withTimingSilentD
  :: (MonadIO m, HasDynFlags m)
  => SDoc       -- ^ The name of the phase
  -> (a -> ())  -- ^ A function to force the result
                -- (often either @const ()@ or 'rnf')
  -> m a        -- ^ The body of the phase to be timed
  -> m a
withTimingSilentD what force action = do
  dflags <- getDynFlags
  withTiming' dflags what force DontPrintTimings action
716
717
718

-- | Worker for 'withTiming' and 'withTimingSilent'.
withTiming' :: MonadIO m
719
            => DynFlags   -- ^ A means of getting a 'DynFlags' (often
720
721
722
723
724
725
726
                            -- 'getDynFlags' will work here)
            -> SDoc         -- ^ The name of the phase
            -> (a -> ())    -- ^ A function to force the result
                            -- (often either @const ()@ or 'rnf')
            -> PrintTimings -- ^ Whether to print the timings
            -> m a          -- ^ The body of the phase to be timed
            -> m a
727
728
withTiming' dflags what force_result prtimings action
  = do if verbosity dflags >= 2 || dopt Opt_D_dump_timings dflags
729
730
731
732
          then do whenPrintTimings $
                    logInfo dflags (defaultUserStyle dflags) $
                      text "***" <+> what <> colon
                  eventBegins dflags what
733
734
735
736
                  alloc0 <- liftIO getAllocationCounter
                  start <- liftIO getCPUTime
                  !r <- action
                  () <- pure $ force_result r
737
                  eventEnds dflags what
738
739
740
741
                  end <- liftIO getCPUTime
                  alloc1 <- liftIO getAllocationCounter
                  -- recall that allocation counter counts down
                  let alloc = alloc0 - alloc1
Ben Gamari's avatar
Ben Gamari committed
742
743
                      time = realToFrac (end - start) * 1e-9

744
                  when (verbosity dflags >= 2 && prtimings == PrintTimings)
Ben Gamari's avatar
Ben Gamari committed
745
746
747
748
749
750
751
752
753
                      $ liftIO $ logInfo dflags (defaultUserStyle dflags)
                          (text "!!!" <+> what <> colon <+> text "finished in"
                           <+> doublePrec 2 time
                           <+> text "milliseconds"
                           <> comma
                           <+> text "allocated"
                           <+> doublePrec 3 (realToFrac alloc / 1024 / 1024)
                           <+> text "megabytes")

754
                  whenPrintTimings $
Sylvain Henry's avatar
Sylvain Henry committed
755
                      dumpIfSet_dyn dflags Opt_D_dump_timings "" FormatText
756
757
758
759
760
                          $ text $ showSDocOneLine dflags
                          $ hsep [ what <> colon
                                 , text "alloc=" <> ppr alloc
                                 , text "time=" <> doublePrec 3 time
                                 ]
761
762
763
                  pure r
           else action

764
765
766
    where whenPrintTimings = liftIO . when (prtimings == PrintTimings)
          eventBegins dflags w = do
            whenPrintTimings $ traceMarkerIO (eventBeginsDoc dflags w)
767
            liftIO $ traceEventIO (eventBeginsDoc dflags w)
768
769
770
771
772
773
774
          eventEnds dflags w = do
            whenPrintTimings $ traceMarkerIO (eventEndsDoc dflags w)
            liftIO $ traceEventIO (eventEndsDoc dflags w)

          eventBeginsDoc dflags w = showSDocOneLine dflags $ text "GHC:started:" <+> w
          eventEndsDoc dflags w = showSDocOneLine dflags $ text "GHC:finished:" <+> w

775
debugTraceMsg :: DynFlags -> Int -> MsgDoc -> IO ()
776
debugTraceMsg dflags val msg = ifVerbose dflags val $
Sylvain Henry's avatar
Sylvain Henry committed
777
                               logInfo dflags (defaultDumpStyle dflags) msg
778
putMsg :: DynFlags -> MsgDoc -> IO ()
Sylvain Henry's avatar
Sylvain Henry committed
779
putMsg dflags msg = logInfo dflags (defaultUserStyle dflags) msg
780
781
782

printInfoForUser :: DynFlags -> PrintUnqualified -> MsgDoc -> IO ()
printInfoForUser dflags print_unqual msg
Sylvain Henry's avatar
Sylvain Henry committed
783
  = logInfo dflags (mkUserStyle dflags print_unqual AllTheWay) msg
784
785
786

printOutputForUser :: DynFlags -> PrintUnqualified -> MsgDoc -> IO ()
printOutputForUser dflags print_unqual msg
Sylvain Henry's avatar
Sylvain Henry committed
787
  = logOutput dflags (mkUserStyle dflags print_unqual AllTheWay) msg
788
789

logInfo :: DynFlags -> PprStyle -> MsgDoc -> IO ()
790
logInfo dflags sty msg
Ben Gamari's avatar
Ben Gamari committed
791
  = putLogMsg dflags NoReason SevInfo noSrcSpan sty msg
792
793

logOutput :: DynFlags -> PprStyle -> MsgDoc -> IO ()
Ben Gamari's avatar
Ben Gamari committed
794
-- ^ Like 'logInfo' but with 'SevOutput' rather then 'SevInfo'
795
logOutput dflags sty msg
Ben Gamari's avatar
Ben Gamari committed
796
  = putLogMsg dflags NoReason SevOutput noSrcSpan sty msg
Ian Lynagh's avatar
Ian Lynagh committed
797

798
prettyPrintGhcErrors :: ExceptionMonad m => DynFlags -> m a -> m a
799
prettyPrintGhcErrors dflags
800
801
    = ghandle $ \e -> case e of
                      PprPanic str doc ->
802
                          pprDebugAndThen dflags panic (text str) doc
803
                      PprSorry str doc ->
804
                          pprDebugAndThen dflags sorry (text str) doc
805
                      PprProgramError str doc ->
806
                          pprDebugAndThen dflags pgmError (text str) doc
807
                      _ ->
808
                          liftIO $ throwIO e
809
810

-- | Checks if given 'WarnMsg' is a fatal warning.
811
isWarnMsgFatal :: DynFlags -> WarnMsg -> Maybe (Maybe WarningFlag)
812
isWarnMsgFatal dflags ErrMsg{errMsgReason = Reason wflag}
813
814
815
816
817
818
819
  = if wopt_fatal wflag dflags
      then Just (Just wflag)
      else Nothing
isWarnMsgFatal dflags _
  = if gopt Opt_WarnIsError dflags
      then Just Nothing
      else Nothing
Douglas Wilson's avatar
Douglas Wilson committed
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839

traceCmd :: DynFlags -> String -> String -> IO a -> IO a
-- trace the command (at two levels of verbosity)
traceCmd dflags phase_name cmd_line action
 = do   { let verb = verbosity dflags
        ; showPass dflags phase_name
        ; debugTraceMsg dflags 3 (text cmd_line)
        ; case flushErr dflags of
              FlushErr io -> io

           -- And run it!
        ; action `catchIO` handle_exn verb
        }
  where
    handle_exn _verb exn = do { debugTraceMsg dflags 2 (char '\n')
                              ; debugTraceMsg dflags 2
                                (text "Failed:"
                                 <+> text cmd_line
                                 <+> text (show exn))
                              ; throwGhcExceptionIO (ProgramError (show exn))}
840
841
842
843
844
845
846
847

{- Note [withTiming]
~~~~~~~~~~~~~~~~~~~~

For reference:

  withTiming
    :: MonadIO
848
849
850
851
852
853
    => m DynFlags   -- how to get the DynFlags
    -> SDoc         -- label for the computation we're timing
    -> (a -> ())    -- how to evaluate the result
    -> PrintTimings -- whether to report the timings when passed
                    -- -v2 or -ddump-timings
    -> m a          -- computation we're timing
854
855
856
857
    -> m a

withTiming lets you run an action while:

858
859
(1) measuring the CPU time it took and reporting that on stderr
    (when PrintTimings is passed),
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
(2) emitting start/stop events to GHC's event log, with the label
    given as an argument.

Evaluation of the result
------------------------

'withTiming' takes as an argument a function of type 'a -> ()', whose purpose is
to evaluate the result "sufficiently". A given pass might return an 'm a' for
some monad 'm' and result type 'a', but where the 'a' is complex enough
that evaluating it to WHNF barely scratches its surface and leaves many
complex and time-consuming computations unevaluated. Those would only be
forced by the next pass, and the time needed to evaluate them would be
mis-attributed to that next pass. A more appropriate function would be
one that deeply evaluates the result, so as to assign the time spent doing it
to the pass we're timing.

Note: as hinted at above, the time spent evaluating the application of the
forcing function to the result is included in the timings reported by
'withTiming'.

How we use it
-------------

We measure the time and allocations of various passes in GHC's pipeline by just
wrapping the whole pass with 'withTiming'. This also materializes by having
a label for each pass in the eventlog, where each pass is executed in one go,
during a continuous time window.

However, from STG onwards, the pipeline uses streams to emit groups of
STG/Cmm/etc declarations one at a time, and process them until we get to
assembly code generation. This means that the execution of those last few passes
is interleaved and that we cannot measure how long they take by just wrapping
the whole thing with 'withTiming'. Instead we wrap the processing of each
individual stream element, all along the codegen pipeline, using the appropriate
label for the pass to which this processing belongs. That generates a lot more
data but allows us to get fine-grained timings about all the passes and we can
896
easily compute totals with tools like ghc-events-analyze (see below).
897
898
899
900
901
902
903
904


Producing an eventlog for GHC
-----------------------------

To actually produce the eventlog, you need an eventlog-capable GHC build:

  With Hadrian:
905
  $ hadrian/build -j "stage1.ghc-bin.ghc.link.opts += -eventlog"
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935

  With Make:
  $ make -j GhcStage2HcOpts+=-eventlog

You can then produce an eventlog when compiling say hello.hs by simply
doing:

  If GHC was built by Hadrian:
  $ _build/stage1/bin/ghc -ddump-timings hello.hs -o hello +RTS -l

  If GHC was built with Make:
  $ inplace/bin/ghc-stage2 -ddump-timing hello.hs -o hello +RTS -l

You could alternatively use -v<N> (with N >= 2) instead of -ddump-timings,
to ask GHC to report timings (on stderr and the eventlog).

This will write the eventlog to ./ghc.eventlog in both cases. You can then
visualize it or look at the totals for each label by using ghc-events-analyze,
threadscope or any other eventlog consumer. Illustrating with
ghc-events-analyze:

  $ ghc-events-analyze --timed --timed-txt --totals \
                       --start "GHC:started:" --stop "GHC:finished:" \
                       ghc.eventlog

This produces ghc.timed.txt (all event timestamps), ghc.timed.svg (visualisation
of the execution through the various labels) and ghc.totals.txt (total time
spent in each label).

-}
Sylvain Henry's avatar
Sylvain Henry committed
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975


-- | Format of a dump
--
-- Dump formats are loosely defined: dumps may contain various additional
-- headers and annotations and they may be partial. 'DumpFormat' is mainly a hint
-- (e.g. for syntax highlighters).
data DumpFormat
   = FormatHaskell   -- ^ Haskell
   | FormatCore      -- ^ Core
   | FormatSTG       -- ^ STG
   | FormatByteCode  -- ^ ByteCode
   | FormatCMM       -- ^ Cmm
   | FormatASM       -- ^ Assembly code
   | FormatC         -- ^ C code/header
   | FormatLLVM      -- ^ LLVM bytecode
   | FormatText      -- ^ Unstructured dump
   deriving (Show,Eq)

type DumpAction = DynFlags -> PprStyle -> DumpOptions -> String
                  -> DumpFormat -> SDoc -> IO ()

type TraceAction = forall a. DynFlags -> String -> SDoc -> a -> a

-- | Default action for 'dumpAction' hook
defaultDumpAction :: DumpAction
defaultDumpAction dflags sty dumpOpt title _fmt doc = do
   dumpSDocWithStyle sty dflags dumpOpt title doc

-- | Default action for 'traceAction' hook
defaultTraceAction :: TraceAction
defaultTraceAction dflags title doc = pprTraceWithFlags dflags title doc

-- | Helper for `dump_action`
dumpAction :: DumpAction
dumpAction dflags = dump_action dflags dflags

-- | Helper for `trace_action`
traceAction :: TraceAction
traceAction dflags = trace_action dflags dflags