ErrUtils.hs 33 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 #-}
Ian Lynagh's avatar
Ian Lynagh committed
10

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

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

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

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

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

        -- * Dump files
43
        dumpIfSet, dumpIfSet_dyn, dumpIfSet_dyn_printer,
44 45
        mkDumpDoc, dumpSDoc, dumpSDocForUser,
        dumpSDocWithStyle,
46

Ben Gamari's avatar
Ben Gamari committed
47
        -- * Issuing messages during compilation
48 49
        putMsg, printInfoForUser, printOutputForUser,
        logInfo, logOutput,
50
        errorMsg, warningMsg,
Ben Gamari's avatar
Ben Gamari committed
51
        fatalErrorMsg, fatalErrorMsg'',
dterei's avatar
dterei committed
52
        compilationProgressMsg,
53
        showPass, withTiming, withTimingSilent,
dterei's avatar
dterei committed
54
        debugTraceMsg,
Ben Gamari's avatar
Ben Gamari committed
55
        ghcExit,
Ian Lynagh's avatar
Ian Lynagh committed
56
        prettyPrintGhcErrors,
duog's avatar
duog committed
57
        traceCmd
58 59
    ) where

60
#include "HsVersions.h"
61

62 63
import GhcPrelude

64
import Bag
Ian Lynagh's avatar
Ian Lynagh committed
65
import Exception
66
import Outputable
Ian Lynagh's avatar
Ian Lynagh committed
67
import Panic
Rufflewind's avatar
Rufflewind committed
68
import qualified PprColour as Col
69
import SrcLoc
70
import DynFlags
Rufflewind's avatar
Rufflewind committed
71
import FastString (unpackFS)
72
import StringBuffer (atLine, hGetStringBuffer, len, lexemeToString)
73
import Json
Simon Marlow's avatar
Simon Marlow committed
74

75
import System.Directory
dterei's avatar
dterei committed
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 )
Ian Lynagh's avatar
Ian Lynagh committed
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
Rufflewind's avatar
Rufflewind committed
88
import System.IO.Error  ( catchIOError )
89 90
import GHC.Conc         ( getAllocationCounter )
import System.CPUTime
sof's avatar
sof committed
91

92 93 94 95 96
-------------------------
type MsgDoc  = SDoc

-------------------------
data Validity
Ben Gamari's avatar
Ben Gamari committed
97 98
  = IsValid            -- ^ Everything is fine
  | NotValid MsgDoc    -- ^ A problem, and some indication of why
99 100 101 102 103 104 105 106 107

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
108 109
-- | If they aren't all valid, return the first
allValid :: [Validity] -> Validity
110 111 112 113 114 115
allValid []       = IsValid
allValid (v : vs) = v `andValid` allValid vs

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

116 117 118 119
orValid :: Validity -> Validity -> Validity
orValid IsValid _ = IsValid
orValid _       v = v

120 121 122
-- -----------------------------------------------------------------------------
-- Basic error messages: just render a message with a source location.

123 124 125
type Messages        = (WarningMessages, ErrorMessages)
type WarningMessages = Bag WarnMsg
type ErrorMessages   = Bag ErrMsg
126

127 128 129 130
unionMessages :: Messages -> Messages -> Messages
unionMessages (warns1, errs1) (warns2, errs2) =
  (warns1 `unionBags` warns2, errs1 `unionBags` errs2)

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

142

143 144 145 146 147
-- | 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.
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 156 157
        }

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

158
type WarnMsg = ErrMsg
159

160
data Severity
161
  = SevOutput
162
  | SevFatal
163
  | SevInteractive
164 165

  | SevDump
Gabor Greif's avatar
Gabor Greif committed
166
    -- ^ Log message intended for compiler developers
167 168
    -- No file/line/column stuff

169
  | SevInfo
Ben Gamari's avatar
Ben Gamari committed
170
    -- ^ Log messages intended for end users.
171 172
    -- No file/line/column stuff.

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


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

186

187
instance Show ErrMsg where
188
    show em = errMsgShortString em
189 190 191 192

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

193
-- | Make an unannotated error message with location info.
194
mkLocMessage :: Severity -> SrcSpan -> MsgDoc -> MsgDoc
195 196
mkLocMessage = mkLocMessageAnn Nothing

197 198 199 200 201 202 203
-- | Make a possibly annotated error message with location info.
mkLocMessageAnn
  :: Maybe String                       -- ^ optional annotation
  -> Severity                           -- ^ severity
  -> SrcSpan                            -- ^ location
  -> MsgDoc                             -- ^ message
  -> MsgDoc
204
  -- Always print the location, even if it is unhelpful.  Error messages
205 206
  -- are supposed to be in a standard format, and one without a location
  -- would look strange.  Better to say explicitly "<no location info>".
207
mkLocMessageAnn ann severity locn msg
208
    = sdocWithDynFlags $ \dflags ->
ian@well-typed.com's avatar
ian@well-typed.com committed
209
      let locn' = if gopt Opt_ErrorSpans dflags
210 211
                  then ppr locn
                  else ppr (srcSpanStart locn)
Rufflewind's avatar
Rufflewind committed
212 213 214 215 216 217 218 219

          sevColour = getSeverityColour severity (colScheme dflags)

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

220 221
          -- Add prefixes, like    Foo.hs:34: warning:
          --                           <the warning message>
Rufflewind's avatar
Rufflewind committed
222
          header = locn' <> colon <+>
Rufflewind's avatar
Rufflewind committed
223 224
                   coloured sevColour sevText <> optAnn

Rufflewind's avatar
Rufflewind committed
225 226 227
      in coloured (Col.sMessage (colScheme dflags))
                  (hang (coloured (Col.sHeader (colScheme dflags)) header) 4
                        msg)
Rufflewind's avatar
Rufflewind committed
228 229

  where
Rufflewind's avatar
Rufflewind committed
230
    sevText =
231
      case severity of
Rufflewind's avatar
Rufflewind committed
232 233 234 235
        SevWarning -> text "warning:"
        SevError   -> text "error:"
        SevFatal   -> text "fatal:"
        _          -> empty
236

Rufflewind's avatar
Rufflewind committed
237 238 239 240 241
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
242 243 244 245

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

  where
249 250 251
    getSrcLine fn i =
      getLine i (unpackFS fn)
        `catchIOError` \_ ->
Rufflewind's avatar
Rufflewind committed
252 253
          pure Nothing

254
    getLine i fn = do
Rufflewind's avatar
Rufflewind committed
255 256 257 258
      -- 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)
259 260 261 262 263 264 265
      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
266 267 268 269 270 271 272 273 274 275 276 277

    -- 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) =
Rufflewind's avatar
Rufflewind committed
278 279 280 281
      sdocWithDynFlags $ \ dflags ->
      let sevColour = getSeverityColour severity (colScheme dflags)
          marginColour = Col.sMargin (colScheme dflags)
      in
Rufflewind's avatar
Rufflewind committed
282 283 284 285 286 287 288 289 290 291 292
      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

293 294 295 296 297 298 299 300 301 302
        -- 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
303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318

        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
319 320 321 322 323

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

325 326 327
-- -----------------------------------------------------------------------------
-- Collecting up messages for later ordering and printing.

328 329 330 331 332 333
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))
334 335
          , errMsgSeverity = sev
          , errMsgReason = NoReason }
336

337 338 339
mkErrDoc :: DynFlags -> SrcSpan -> PrintUnqualified -> ErrDoc -> ErrMsg
mkErrDoc dflags = mk_err_msg dflags SevError

340
mkLongErrMsg, mkLongWarnMsg   :: DynFlags -> SrcSpan -> PrintUnqualified -> MsgDoc -> MsgDoc -> ErrMsg
Ben Gamari's avatar
Ben Gamari committed
341
-- ^ A long (multi-line) error message
342
mkErrMsg, mkWarnMsg           :: DynFlags -> SrcSpan -> PrintUnqualified -> MsgDoc            -> ErrMsg
Ben Gamari's avatar
Ben Gamari committed
343
-- ^ A short (one-line) error message
344
mkPlainErrMsg, mkPlainWarnMsg :: DynFlags -> SrcSpan ->                     MsgDoc            -> ErrMsg
Ben Gamari's avatar
Ben Gamari committed
345
-- ^ Variant that doesn't care about qualified/unqualified names
346

347 348 349 350 351 352
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] [] [])
353

354
----------------
355 356 357
emptyMessages :: Messages
emptyMessages = (emptyBag, emptyBag)

358 359 360
isEmptyMessages :: Messages -> Bool
isEmptyMessages (warns, errs) = isEmptyBag warns && isEmptyBag errs

361
errorsFound :: DynFlags -> Messages -> Bool
362
errorsFound _dflags (_warns, errs) = not (isEmptyBag errs)
363

364 365 366 367 368 369 370 371 372
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 }

373
printBagOfErrors :: DynFlags -> Bag ErrMsg -> IO ()
374
printBagOfErrors dflags bag_of_errors
375
  = sequence_ [ let style = mkErrStyle dflags unqual
Ben Gamari's avatar
Ben Gamari committed
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 383 384 385 386 387 388 389 390 391 392
                                                                  bag_of_errors ]

formatErrDoc :: DynFlags -> ErrDoc -> SDoc
formatErrDoc dflags (ErrDoc important context supplementary)
  = case msgs of
        [msg] -> vcat msg
        _ -> vcat $ map starred msgs
    where
    msgs = filter (not . null) $ map (filter (not . Outputable.isEmpty dflags))
        [important, context, supplementary]
    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 401
                     , errMsgSeverity  = sev
                     , 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]
coopercm's avatar
coopercm committed
407
sortMsgBag dflags = maybeLimit . sortBy (maybeFlip cmp) . bagToList
408 409 410
  where maybeFlip :: (a -> a -> b) -> (a -> a -> b)
        maybeFlip
          | fromMaybe False (fmap reverseErrors dflags) = flip
411
          | otherwise                                   = id
coopercm's avatar
coopercm committed
412 413 414 415
        cmp = comparing errMsgSpan
        maybeLimit = case join (fmap maxErrors dflags) of
          Nothing        -> id
          Just err_limit -> take err_limit
416

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

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

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

431 432 433
-- -----------------------------------------------------------------------------
-- Dumping

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

444 445 446
-- | a wrapper around 'dumpSDoc'.
-- First check whether the dump flag is set
-- Do nothing if it is unset
447
dumpIfSet_dyn :: DynFlags -> DumpFlag -> String -> SDoc -> IO ()
448
dumpIfSet_dyn dflags flag hdr doc
449 450 451 452 453 454 455 456 457 458 459 460
  = when (dopt flag dflags) $ dumpSDoc dflags alwaysQualify flag hdr doc

-- | a wrapper around 'dumpSDoc'.
-- First check whether the dump flag is set
-- Do nothing if it is unset
--
-- Unlike 'dumpIfSet_dyn',
-- has a printer argument but no header argument
dumpIfSet_dyn_printer :: PrintUnqualified
                      -> DynFlags -> DumpFlag -> SDoc -> IO ()
dumpIfSet_dyn_printer printer dflags flag doc
  = when (dopt flag dflags) $ dumpSDoc dflags printer flag "" doc
461

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

471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488
-- | Run an action with the handle of a 'DumpFlag' if we are outputting to a
-- file, otherwise 'Nothing'.
withDumpFileHandle :: DynFlags -> DumpFlag -> (Maybe Handle -> IO ()) -> IO ()
withDumpFileHandle dflags flag action = do
    let mFile = chooseDumpFile dflags flag
    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:
489
            -- https://gitlab.haskell.org/ghc/ghc/issues/10762
490 491 492 493
            hSetEncoding handle utf8

            action (Just handle)
      Nothing -> action Nothing
494

495 496 497 498 499 500 501 502 503 504 505 506 507 508

dumpSDoc, dumpSDocForUser
  :: DynFlags -> PrintUnqualified -> DumpFlag -> String -> SDoc -> IO ()

-- | A wrapper around 'dumpSDocWithStyle' which uses 'PprDump' style.
dumpSDoc dflags print_unqual
  = dumpSDocWithStyle dump_style dflags
  where dump_style = mkDumpStyle dflags print_unqual

-- | A wrapper around 'dumpSDocWithStyle' which uses 'PprUser' style.
dumpSDocForUser dflags print_unqual
  = dumpSDocWithStyle user_style dflags
  where user_style = mkUserStyle dflags print_unqual AllTheWay

509
-- | Write out a dump.
Ben Gamari's avatar
Ben Gamari committed
510 511
-- If --dump-to-file is set then this goes to a file.
-- otherwise emit to stdout.
512
--
Ben Gamari's avatar
Ben Gamari committed
513
-- When @hdr@ is empty, we print in a more compact format (no separators and
514
-- blank lines)
515
--
Ben Gamari's avatar
Ben Gamari committed
516 517
-- The 'DumpFlag' is used only to choose the filename to use if @--dump-to-file@
-- is used; it is not used to decide whether to dump the output
518 519
dumpSDocWithStyle :: PprStyle -> DynFlags -> DumpFlag -> String -> SDoc -> IO ()
dumpSDocWithStyle sty dflags flag hdr doc =
520 521 522 523 524 525 526
    withDumpFileHandle dflags flag writeDump
  where
    -- write dump to file
    writeDump (Just handle) = do
        doc' <- if null hdr
                then return doc
                else do t <- getCurrentTime
527 528 529 530 531 532
                        let timeStamp = if (gopt Opt_SuppressTimestamps dflags)
                                          then empty
                                          else text (show t)
                        let d = timeStamp
                                $$ blankLine
                                $$ doc
533
                        return $ mkDumpDoc hdr d
534
        defaultLogActionHPrintDoc dflags handle doc' sty
535 536 537 538 539 540

    -- write the dump to stdout
    writeDump Nothing = do
        let (doc', severity)
              | null hdr  = (doc, SevOutput)
              | otherwise = (mkDumpDoc hdr doc, SevDump)
541
        putLogMsg dflags NoReason severity noSrcSpan sty doc'
542 543 544 545


-- | Choose where to put a dump file based on DynFlags
--
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

dterei's avatar
dterei committed
553 554
        | otherwise
        = Nothing
555

556 557 558 559 560 561 562 563 564 565 566 567 568 569
        where getPrefix
                 -- dump file location is being forced
                 --      by the --ddump-file-prefix flag.
               | Just prefix <- dumpPrefixForce dflags
                  = Just prefix
                 -- dump file location chosen by DriverPipeline.runPipeline
               | 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
570

Edward Z. Yang's avatar
Edward Z. Yang committed
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 576 577 578 579
 = let str = show flag
       suff = case stripPrefix "Opt_D_" str of
              Just x -> x
              Nothing -> panic ("Bad flag name: " ++ str)
       dash = map (\c -> if c == '_' then '-' else c) suff
dterei's avatar
dterei committed
580
   in dash
581 582


583 584 585 586 587 588 589 590 591 592 593 594 595
-- -----------------------------------------------------------------------------
-- 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 ()

596
errorMsg :: DynFlags -> MsgDoc -> IO ()
597
errorMsg dflags msg
Ben Gamari's avatar
Ben Gamari committed
598
   = putLogMsg dflags NoReason SevError noSrcSpan (defaultErrStyle dflags) msg
599

600 601
warningMsg :: DynFlags -> MsgDoc -> IO ()
warningMsg dflags msg
Ben Gamari's avatar
Ben Gamari committed
602
   = putLogMsg dflags NoReason SevWarning noSrcSpan (defaultErrStyle dflags) msg
603

604
fatalErrorMsg :: DynFlags -> MsgDoc -> IO ()
Ben Gamari's avatar
Ben Gamari committed
605 606
fatalErrorMsg dflags msg =
    putLogMsg dflags NoReason SevFatal noSrcSpan (defaultErrStyle dflags) msg
Ian Lynagh's avatar
Ian Lynagh committed
607 608 609

fatalErrorMsg'' :: FatalMessager -> String -> IO ()
fatalErrorMsg'' fm msg = fm msg
610 611

compilationProgressMsg :: DynFlags -> String -> IO ()
612 613 614 615
compilationProgressMsg dflags msg = do
    traceEventIO $ "GHC progress: " ++ msg
    ifVerbose dflags 1 $
        logOutput dflags (defaultUserStyle dflags) (text msg)
616

617
showPass :: DynFlags -> String -> IO ()
dterei's avatar
dterei committed
618
showPass dflags what
619
  = ifVerbose dflags 2 $
Sylvain Henry's avatar
Sylvain Henry committed
620
    logInfo dflags (defaultUserStyle dflags) (text "***" <+> text what <> colon)
621

622 623 624
data PrintTimings = PrintTimings | DontPrintTimings
  deriving (Eq, Show)

625 626 627 628
-- | 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
629 630
-- a typical usage:
-- @withTiming getDynFlags (text "simplify") force PrintTimings pass@.
631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646
-- 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.
647 648
--
-- See Note [withTiming] for more.
649
withTiming :: MonadIO m
650 651 652 653 654 655
           => m DynFlags   -- ^ A means of getting a 'DynFlags' (often
                           -- 'getDynFlags' will work here)
           -> 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
656
           -> m a
657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687
withTiming getDFlags what force action =
  withTiming' getDFlags what force PrintTimings action


-- | 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
  => m DynFlags -- ^ A means of getting a 'DynFlags' (often
                -- 'getDynFlags' will work here)
  -> 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
withTimingSilent getDFlags what force action =
  withTiming' getDFlags what force DontPrintTimings action

-- | Worker for 'withTiming' and 'withTimingSilent'.
withTiming' :: MonadIO m
            => m DynFlags   -- ^ A means of getting a 'DynFlags' (often
                            -- '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
withTiming' getDFlags what force_result prtimings action
688
  = do dflags <- getDFlags
Ben Gamari's avatar
Ben Gamari committed
689
       if verbosity dflags >= 2 || dopt Opt_D_dump_timings dflags
690 691 692 693
          then do whenPrintTimings $
                    logInfo dflags (defaultUserStyle dflags) $
                      text "***" <+> what <> colon
                  eventBegins dflags what
694 695 696 697
                  alloc0 <- liftIO getAllocationCounter
                  start <- liftIO getCPUTime
                  !r <- action
                  () <- pure $ force_result r
698
                  eventEnds dflags what
699 700 701 702
                  end <- liftIO getCPUTime
                  alloc1 <- liftIO getAllocationCounter
                  -- recall that allocation counter counts down
                  let alloc = alloc0 - alloc1
Ben Gamari's avatar
Ben Gamari committed
703 704
                      time = realToFrac (end - start) * 1e-9

705
                  when (verbosity dflags >= 2 && prtimings == PrintTimings)
Ben Gamari's avatar
Ben Gamari committed
706 707 708 709 710 711 712 713 714
                      $ 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")

715 716 717 718 719 720 721
                  whenPrintTimings $
                      dumpIfSet_dyn dflags Opt_D_dump_timings ""
                          $ text $ showSDocOneLine dflags
                          $ hsep [ what <> colon
                                 , text "alloc=" <> ppr alloc
                                 , text "time=" <> doublePrec 3 time
                                 ]
722 723 724
                  pure r
           else action

725 726 727 728 729 730 731 732 733 734 735
    where whenPrintTimings = liftIO . when (prtimings == PrintTimings)
          eventBegins dflags w = do
            whenPrintTimings $ traceMarkerIO (eventBeginsDoc dflags w)
            liftIO $ traceEventIO (eventEndsDoc dflags w)
          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

736
debugTraceMsg :: DynFlags -> Int -> MsgDoc -> IO ()
737
debugTraceMsg dflags val msg = ifVerbose dflags val $
Sylvain Henry's avatar
Sylvain Henry committed
738
                               logInfo dflags (defaultDumpStyle dflags) msg
739
putMsg :: DynFlags -> MsgDoc -> IO ()
Sylvain Henry's avatar
Sylvain Henry committed
740
putMsg dflags msg = logInfo dflags (defaultUserStyle dflags) msg
741 742 743

printInfoForUser :: DynFlags -> PrintUnqualified -> MsgDoc -> IO ()
printInfoForUser dflags print_unqual msg
Sylvain Henry's avatar
Sylvain Henry committed
744
  = logInfo dflags (mkUserStyle dflags print_unqual AllTheWay) msg
745 746 747

printOutputForUser :: DynFlags -> PrintUnqualified -> MsgDoc -> IO ()
printOutputForUser dflags print_unqual msg
Sylvain Henry's avatar
Sylvain Henry committed
748
  = logOutput dflags (mkUserStyle dflags print_unqual AllTheWay) msg
749 750

logInfo :: DynFlags -> PprStyle -> MsgDoc -> IO ()
751
logInfo dflags sty msg
Ben Gamari's avatar
Ben Gamari committed
752
  = putLogMsg dflags NoReason SevInfo noSrcSpan sty msg
753 754

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

759
prettyPrintGhcErrors :: ExceptionMonad m => DynFlags -> m a -> m a
760
prettyPrintGhcErrors dflags
761 762
    = ghandle $ \e -> case e of
                      PprPanic str doc ->
763
                          pprDebugAndThen dflags panic (text str) doc
764
                      PprSorry str doc ->
765
                          pprDebugAndThen dflags sorry (text str) doc
766
                      PprProgramError str doc ->
767
                          pprDebugAndThen dflags pgmError (text str) doc
768
                      _ ->
769
                          liftIO $ throwIO e
770 771

-- | Checks if given 'WarnMsg' is a fatal warning.
772
isWarnMsgFatal :: DynFlags -> WarnMsg -> Maybe (Maybe WarningFlag)
773
isWarnMsgFatal dflags ErrMsg{errMsgReason = Reason wflag}
774 775 776 777 778 779 780
  = if wopt_fatal wflag dflags
      then Just (Just wflag)
      else Nothing
isWarnMsgFatal dflags _
  = if gopt Opt_WarnIsError dflags
      then Just Nothing
      else Nothing
duog's avatar
duog committed
781 782 783 784 785 786 787 788 789 790 791 792 793 794 795 796 797 798 799 800

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))}
801 802 803 804 805 806 807 808

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

For reference:

  withTiming
    :: MonadIO
809 810 811 812 813 814
    => 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
815 816 817 818
    -> m a

withTiming lets you run an action while:

819 820
(1) measuring the CPU time it took and reporting that on stderr
    (when PrintTimings is passed),
821 822 823 824 825 826 827 828 829 830 831 832 833 834 835 836 837 838 839 840 841 842 843 844 845 846 847 848 849 850 851 852 853 854 855 856 857 858 859 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 896
(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
easily compute totals withh tools like ghc-events-analyze (see below).


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

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

  With Hadrian:
  $ hadrian/build.sh -j "stage1.ghc-bin.ghc.link.opts += -eventlog"

  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).

-}