path: root/compiler/GHC/Utils/Error.hs

{-# LANGUAGE BangPatterns    #-}
{-# LANGUAGE CPP             #-}
{-# LANGUAGE RankNTypes      #-}
{-# LANGUAGE ViewPatterns    #-}

{-
(c) The AQUA Project, Glasgow University, 1994-1998

\section[ErrsUtils]{Utilities for error reporting}
-}

module GHC.Utils.Error (
        -- * Basic types
        Validity(..), andValid, allValid, isValid, getInvalids, orValid,
        Severity(..),

        -- * Messages
        WarnMsg,
        MsgEnvelope(..),
        SDoc,
        DecoratedSDoc(unDecorated),
        Messages, ErrorMessages, WarningMessages,
        unionMessages,
        errorsFound, isEmptyMessages,

        -- ** Formatting
        pprMessageBag, pprMsgEnvelopeBagWithLoc,
        pprLocMsgEnvelope,
        formatBulleted,

        -- ** Construction
        emptyMessages, mkDecorated, mkLocMessage, mkLocMessageAnn, makeIntoWarning,
        mkMsgEnvelope, mkPlainMsgEnvelope, mkErr, mkLongMsgEnvelope, mkWarnMsg,
        mkPlainWarnMsg,
        mkLongWarnMsg,

        -- * Utilities
        doIfSet, doIfSet_dyn,
        getCaretDiagnostic,

        -- * Issuing messages during compilation
        putMsg, printInfoForUser, printOutputForUser,
        logInfo, logOutput,
        errorMsg, warningMsg,
        fatalErrorMsg, fatalErrorMsg'',
        compilationProgressMsg,
        showPass,
        withTiming, withTimingSilent,
        debugTraceMsg,
        ghcExit,
        prettyPrintGhcErrors,
        traceCmd,

        sortMsgBag
    ) where

#include "HsVersions.h"

import GHC.Prelude

import GHC.Driver.Session
import GHC.Driver.Ppr

import GHC.Data.Bag
import GHC.Utils.Exception
import GHC.Utils.Outputable as Outputable
import GHC.Utils.Panic
import GHC.Utils.Logger
import GHC.Types.Error
import GHC.Types.SrcLoc as SrcLoc

import System.Exit      ( ExitCode(..), exitWith )
import Data.List        ( sortBy )
import Data.Maybe       ( fromMaybe )
import Data.Function
import Debug.Trace
import Control.Monad
import Control.Monad.IO.Class
import Control.Monad.Catch as MC (handle)
import GHC.Conc         ( getAllocationCounter )
import System.CPUTime

-------------------------
data Validity
  = IsValid            -- ^ Everything is fine
  | NotValid SDoc    -- ^ A problem, and some indication of why

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

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

-- | If they aren't all valid, return the first
allValid :: [Validity] -> Validity
allValid []       = IsValid
allValid (v : vs) = v `andValid` allValid vs

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

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

-- -----------------------------------------------------------------------------
-- Collecting up messages for later ordering and printing.

----------------
-- | Formats the input list of structured document, where each element of the list gets a bullet.
formatBulleted :: SDocContext -> DecoratedSDoc -> SDoc
formatBulleted ctx (unDecorated -> docs)
  = case msgs of
        []    -> Outputable.empty
        [msg] -> msg
        _     -> vcat $ map starred msgs
    where
    msgs    = filter (not . Outputable.isEmpty ctx) docs
    starred = (bullet<+>)

pprMsgEnvelopeBagWithLoc :: Bag (MsgEnvelope DecoratedSDoc) -> [SDoc]
pprMsgEnvelopeBagWithLoc bag = [ pprLocMsgEnvelope item | item <- sortMsgBag Nothing bag ]

pprLocMsgEnvelope :: RenderableDiagnostic e => MsgEnvelope e -> SDoc
pprLocMsgEnvelope (MsgEnvelope { errMsgSpan      = s
                               , errMsgDiagnostic = e
                               , errMsgSeverity  = sev
                               , errMsgContext   = unqual })
  = sdocWithContext $ \ctx ->
    withErrStyle unqual $ mkLocMessage sev s (formatBulleted ctx $ renderDiagnostic e)

sortMsgBag :: Maybe DynFlags -> Bag (MsgEnvelope e) -> [MsgEnvelope e]
sortMsgBag dflags = maybeLimit . sortBy (cmp `on` errMsgSpan) . bagToList
  where cmp
          | fromMaybe False (fmap reverseErrors dflags) = SrcLoc.rightmost_smallest
          | otherwise                                   = SrcLoc.leftmost_smallest
        maybeLimit = case join (fmap maxErrors dflags) of
          Nothing        -> id
          Just err_limit -> take err_limit

ghcExit :: Logger -> DynFlags -> Int -> IO ()
ghcExit logger dflags val
  | val == 0  = exitWith ExitSuccess
  | otherwise = do errorMsg logger dflags (text "\nCompilation had errors\n\n")
                   exitWith (ExitFailure val)

doIfSet :: Bool -> IO () -> IO ()
doIfSet flag action | flag      = action
                    | otherwise = return ()

doIfSet_dyn :: DynFlags -> GeneralFlag -> IO () -> IO()
doIfSet_dyn dflags flag action | gopt flag dflags = action
                               | otherwise        = return ()

-- -----------------------------------------------------------------------------
-- 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 ()
{-# INLINE ifVerbose #-}  -- see Note [INLINE conditional tracing utilities]

errorMsg :: Logger -> DynFlags -> SDoc -> IO ()
errorMsg logger dflags msg
   = putLogMsg logger dflags NoReason SevError noSrcSpan $ withPprStyle defaultErrStyle msg

warningMsg :: Logger -> DynFlags -> SDoc -> IO ()
warningMsg logger dflags msg
   = putLogMsg logger dflags NoReason SevWarning noSrcSpan $ withPprStyle defaultErrStyle msg

fatalErrorMsg :: Logger -> DynFlags -> SDoc -> IO ()
fatalErrorMsg logger dflags msg =
    putLogMsg logger dflags NoReason SevFatal noSrcSpan $ withPprStyle defaultErrStyle msg

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

compilationProgressMsg :: Logger -> DynFlags -> SDoc -> IO ()
compilationProgressMsg logger dflags msg = do
    let str = showSDoc dflags msg
    traceEventIO $ "GHC progress: " ++ str
    ifVerbose dflags 1 $
        logOutput logger dflags $ withPprStyle defaultUserStyle msg

showPass :: Logger -> DynFlags -> String -> IO ()
showPass logger dflags what
  = ifVerbose dflags 2 $
    logInfo logger dflags $ withPprStyle defaultUserStyle (text "***" <+> text what <> colon)

data PrintTimings = PrintTimings | DontPrintTimings
  deriving (Eq, Show)

-- | 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
-- a typical usage:
-- @withTiming getDynFlags (text "simplify") force PrintTimings pass@.
-- 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.
--
-- See Note [withTiming] for more.
withTiming :: MonadIO m
           => Logger
           -> DynFlags     -- ^ DynFlags
           -> 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
withTiming logger dflags what force action =
  withTiming' logger dflags 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
  => Logger
  -> DynFlags   -- ^ DynFlags
  -> 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 logger dflags what force action =
  withTiming' logger dflags what force DontPrintTimings action

-- | Worker for 'withTiming' and 'withTimingSilent'.
withTiming' :: MonadIO m
            => Logger
            -> DynFlags   -- ^ 'DynFlags'
            -> 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' logger dflags what force_result prtimings action
  = if verbosity dflags >= 2 || dopt Opt_D_dump_timings dflags
    then do whenPrintTimings $
              logInfo logger dflags $ withPprStyle defaultUserStyle $
                text "***" <+> what <> colon
            let ctx = initDefaultSDocContext dflags
            alloc0 <- liftIO getAllocationCounter
            start <- liftIO getCPUTime
            eventBegins ctx what
            recordAllocs alloc0
            !r <- action
            () <- pure $ force_result r
            eventEnds ctx what
            end <- liftIO getCPUTime
            alloc1 <- liftIO getAllocationCounter
            recordAllocs alloc1
            -- recall that allocation counter counts down
            let alloc = alloc0 - alloc1
                time = realToFrac (end - start) * 1e-9

            when (verbosity dflags >= 2 && prtimings == PrintTimings)
                $ liftIO $ logInfo logger dflags $ withPprStyle defaultUserStyle
                    (text "!!!" <+> what <> colon <+> text "finished in"
                     <+> doublePrec 2 time
                     <+> text "milliseconds"
                     <> comma
                     <+> text "allocated"
                     <+> doublePrec 3 (realToFrac alloc / 1024 / 1024)
                     <+> text "megabytes")

            whenPrintTimings $
                dumpIfSet_dyn logger dflags Opt_D_dump_timings "" FormatText
                    $ text $ showSDocOneLine ctx
                    $ hsep [ what <> colon
                           , text "alloc=" <> ppr alloc
                           , text "time=" <> doublePrec 3 time
                           ]
            pure r
     else action

    where whenPrintTimings = liftIO . when (prtimings == PrintTimings)

          recordAllocs alloc =
            liftIO $ traceMarkerIO $ "GHC:allocs:" ++ show alloc

          eventBegins ctx w = do
            let doc = eventBeginsDoc ctx w
            whenPrintTimings $ traceMarkerIO doc
            liftIO $ traceEventIO doc

          eventEnds ctx w = do
            let doc = eventEndsDoc ctx w
            whenPrintTimings $ traceMarkerIO doc
            liftIO $ traceEventIO doc

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

debugTraceMsg :: Logger -> DynFlags -> Int -> SDoc -> IO ()
debugTraceMsg logger dflags val msg =
   ifVerbose dflags val $
      logInfo logger dflags (withPprStyle defaultDumpStyle msg)
{-# INLINE debugTraceMsg #-}  -- see Note [INLINE conditional tracing utilities]

putMsg :: Logger -> DynFlags -> SDoc -> IO ()
putMsg logger dflags msg = logInfo logger dflags (withPprStyle defaultUserStyle msg)

printInfoForUser :: Logger -> DynFlags -> PrintUnqualified -> SDoc -> IO ()
printInfoForUser logger dflags print_unqual msg
  = logInfo logger dflags (withUserStyle print_unqual AllTheWay msg)

printOutputForUser :: Logger -> DynFlags -> PrintUnqualified -> SDoc -> IO ()
printOutputForUser logger dflags print_unqual msg
  = logOutput logger dflags (withUserStyle print_unqual AllTheWay msg)

logInfo :: Logger -> DynFlags -> SDoc -> IO ()
logInfo logger dflags msg
  = putLogMsg logger dflags NoReason SevInfo noSrcSpan msg

-- | Like 'logInfo' but with 'SevOutput' rather then 'SevInfo'
logOutput :: Logger -> DynFlags -> SDoc -> IO ()
logOutput logger dflags msg
  = putLogMsg logger dflags NoReason SevOutput noSrcSpan msg

prettyPrintGhcErrors :: ExceptionMonad m => DynFlags -> m a -> m a
prettyPrintGhcErrors dflags
    = MC.handle $ \e -> case e of
                      PprPanic str doc ->
                          pprDebugAndThen ctx panic (text str) doc
                      PprSorry str doc ->
                          pprDebugAndThen ctx sorry (text str) doc
                      PprProgramError str doc ->
                          pprDebugAndThen ctx pgmError (text str) doc
                      _ ->
                          liftIO $ throwIO e
      where
         ctx = initSDocContext dflags defaultUserStyle

traceCmd :: Logger -> DynFlags -> String -> String -> IO a -> IO a
-- trace the command (at two levels of verbosity)
traceCmd logger dflags phase_name cmd_line action
 = do   { let verb = verbosity dflags
        ; showPass logger dflags phase_name
        ; debugTraceMsg logger 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 logger dflags 2 (char '\n')
                              ; debugTraceMsg logger dflags 2
                                (text "Failed:"
                                 <+> text cmd_line
                                 <+> text (show exn))
                              ; throwGhcExceptionIO (ProgramError (show exn))}

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

For reference:

  withTiming
    :: MonadIO
    => 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
    -> m a

withTiming lets you run an action while:

(1) measuring the CPU time it took and reporting that on stderr
    (when PrintTimings is passed),
(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 with 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 -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).

-}