{-# 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 :: Validity -> Bool
isValid Validity
IsValid       = Bool
True
isValid (NotValid {}) = Bool
False

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

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

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

orValid :: Validity -> Validity -> Validity
orValid :: Validity -> Validity -> Validity
orValid Validity
IsValid Validity
_ = Validity
IsValid
orValid Validity
_       Validity
v = Validity
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 :: SDocContext -> DecoratedSDoc -> SDoc
formatBulleted SDocContext
ctx (DecoratedSDoc -> [SDoc]
unDecorated -> [SDoc]
docs)
  = case [SDoc]
msgs of
        []    -> SDoc
Outputable.empty
        [SDoc
msg] -> SDoc
msg
        [SDoc]
_     -> [SDoc] -> SDoc
vcat forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map SDoc -> SDoc
starred [SDoc]
msgs
    where
    msgs :: [SDoc]
msgs    = forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. SDocContext -> SDoc -> Bool
Outputable.isEmpty SDocContext
ctx) [SDoc]
docs
    starred :: SDoc -> SDoc
starred = (SDoc
bulletSDoc -> SDoc -> SDoc
<+>)

pprMsgEnvelopeBagWithLoc :: Bag (MsgEnvelope DecoratedSDoc) -> [SDoc]
pprMsgEnvelopeBagWithLoc :: Bag (MsgEnvelope DecoratedSDoc) -> [SDoc]
pprMsgEnvelopeBagWithLoc Bag (MsgEnvelope DecoratedSDoc)
bag = [ forall e. RenderableDiagnostic e => MsgEnvelope e -> SDoc
pprLocMsgEnvelope MsgEnvelope DecoratedSDoc
item | MsgEnvelope DecoratedSDoc
item <- forall e. Maybe DynFlags -> Bag (MsgEnvelope e) -> [MsgEnvelope e]
sortMsgBag forall a. Maybe a
Nothing Bag (MsgEnvelope DecoratedSDoc)
bag ]

pprLocMsgEnvelope :: RenderableDiagnostic e => MsgEnvelope e -> SDoc
pprLocMsgEnvelope :: forall e. RenderableDiagnostic e => MsgEnvelope e -> SDoc
pprLocMsgEnvelope (MsgEnvelope { errMsgSpan :: forall e. MsgEnvelope e -> SrcSpan
errMsgSpan      = SrcSpan
s
                               , errMsgDiagnostic :: forall e. MsgEnvelope e -> e
errMsgDiagnostic = e
e
                               , errMsgSeverity :: forall e. MsgEnvelope e -> Severity
errMsgSeverity  = Severity
sev
                               , errMsgContext :: forall e. MsgEnvelope e -> PrintUnqualified
errMsgContext   = PrintUnqualified
unqual })
  = (SDocContext -> SDoc) -> SDoc
sdocWithContext forall a b. (a -> b) -> a -> b
$ \SDocContext
ctx ->
    PrintUnqualified -> SDoc -> SDoc
withErrStyle PrintUnqualified
unqual forall a b. (a -> b) -> a -> b
$ Severity -> SrcSpan -> SDoc -> SDoc
mkLocMessage Severity
sev SrcSpan
s (SDocContext -> DecoratedSDoc -> SDoc
formatBulleted SDocContext
ctx forall a b. (a -> b) -> a -> b
$ forall a. RenderableDiagnostic a => a -> DecoratedSDoc
renderDiagnostic e
e)

sortMsgBag :: Maybe DynFlags -> Bag (MsgEnvelope e) -> [MsgEnvelope e]
sortMsgBag :: forall e. Maybe DynFlags -> Bag (MsgEnvelope e) -> [MsgEnvelope e]
sortMsgBag Maybe DynFlags
dflags = [MsgEnvelope e] -> [MsgEnvelope e]
maybeLimit forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (SrcSpan -> SrcSpan -> Ordering
cmp forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` forall e. MsgEnvelope e -> SrcSpan
errMsgSpan) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Bag a -> [a]
bagToList
  where cmp :: SrcSpan -> SrcSpan -> Ordering
cmp
          | forall a. a -> Maybe a -> a
fromMaybe Bool
False (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap DynFlags -> Bool
reverseErrors Maybe DynFlags
dflags) = SrcSpan -> SrcSpan -> Ordering
SrcLoc.rightmost_smallest
          | Bool
otherwise                                   = SrcSpan -> SrcSpan -> Ordering
SrcLoc.leftmost_smallest
        maybeLimit :: [MsgEnvelope e] -> [MsgEnvelope e]
maybeLimit = case forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap DynFlags -> Maybe Int
maxErrors Maybe DynFlags
dflags) of
          Maybe Int
Nothing        -> forall a. a -> a
id
          Just Int
err_limit -> forall a. Int -> [a] -> [a]
take Int
err_limit

ghcExit :: Logger -> DynFlags -> Int -> IO ()
ghcExit :: Logger -> DynFlags -> Int -> IO ()
ghcExit Logger
logger DynFlags
dflags Int
val
  | Int
val forall a. Eq a => a -> a -> Bool
== Int
0  = forall a. ExitCode -> IO a
exitWith ExitCode
ExitSuccess
  | Bool
otherwise = do Logger -> DynFlags -> SDoc -> IO ()
errorMsg Logger
logger DynFlags
dflags (String -> SDoc
text String
"\nCompilation had errors\n\n")
                   forall a. ExitCode -> IO a
exitWith (Int -> ExitCode
ExitFailure Int
val)

doIfSet :: Bool -> IO () -> IO ()
doIfSet :: Bool -> IO () -> IO ()
doIfSet Bool
flag IO ()
action | Bool
flag      = IO ()
action
                    | Bool
otherwise = forall (m :: * -> *) a. Monad m => a -> m a
return ()

doIfSet_dyn :: DynFlags -> GeneralFlag -> IO () -> IO()
doIfSet_dyn :: DynFlags -> GeneralFlag -> IO () -> IO ()
doIfSet_dyn DynFlags
dflags GeneralFlag
flag IO ()
action | GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
flag DynFlags
dflags = IO ()
action
                               | Bool
otherwise        = forall (m :: * -> *) a. Monad m => a -> m a
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 :: DynFlags -> Int -> IO () -> IO ()
ifVerbose DynFlags
dflags Int
val IO ()
act
  | DynFlags -> Int
verbosity DynFlags
dflags forall a. Ord a => a -> a -> Bool
>= Int
val = IO ()
act
  | Bool
otherwise               = forall (m :: * -> *) a. Monad m => a -> m a
return ()
{-# INLINE ifVerbose #-}  -- see Note [INLINE conditional tracing utilities]

errorMsg :: Logger -> DynFlags -> SDoc -> IO ()
errorMsg :: Logger -> DynFlags -> SDoc -> IO ()
errorMsg Logger
logger DynFlags
dflags SDoc
msg
   = Logger -> LogAction
putLogMsg Logger
logger DynFlags
dflags WarnReason
NoReason Severity
SevError SrcSpan
noSrcSpan forall a b. (a -> b) -> a -> b
$ PprStyle -> SDoc -> SDoc
withPprStyle PprStyle
defaultErrStyle SDoc
msg

warningMsg :: Logger -> DynFlags -> SDoc -> IO ()
warningMsg :: Logger -> DynFlags -> SDoc -> IO ()
warningMsg Logger
logger DynFlags
dflags SDoc
msg
   = Logger -> LogAction
putLogMsg Logger
logger DynFlags
dflags WarnReason
NoReason Severity
SevWarning SrcSpan
noSrcSpan forall a b. (a -> b) -> a -> b
$ PprStyle -> SDoc -> SDoc
withPprStyle PprStyle
defaultErrStyle SDoc
msg

fatalErrorMsg :: Logger -> DynFlags -> SDoc -> IO ()
fatalErrorMsg :: Logger -> DynFlags -> SDoc -> IO ()
fatalErrorMsg Logger
logger DynFlags
dflags SDoc
msg =
    Logger -> LogAction
putLogMsg Logger
logger DynFlags
dflags WarnReason
NoReason Severity
SevFatal SrcSpan
noSrcSpan forall a b. (a -> b) -> a -> b
$ PprStyle -> SDoc -> SDoc
withPprStyle PprStyle
defaultErrStyle SDoc
msg

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

compilationProgressMsg :: Logger -> DynFlags -> SDoc -> IO ()
compilationProgressMsg :: Logger -> DynFlags -> SDoc -> IO ()
compilationProgressMsg Logger
logger DynFlags
dflags SDoc
msg = do
    let str :: String
str = DynFlags -> SDoc -> String
showSDoc DynFlags
dflags SDoc
msg
    FatalMessager
traceEventIO forall a b. (a -> b) -> a -> b
$ String
"GHC progress: " forall a. [a] -> [a] -> [a]
++ String
str
    DynFlags -> Int -> IO () -> IO ()
ifVerbose DynFlags
dflags Int
1 forall a b. (a -> b) -> a -> b
$
        Logger -> DynFlags -> SDoc -> IO ()
logOutput Logger
logger DynFlags
dflags forall a b. (a -> b) -> a -> b
$ PprStyle -> SDoc -> SDoc
withPprStyle PprStyle
defaultUserStyle SDoc
msg

showPass :: Logger -> DynFlags -> String -> IO ()
showPass :: Logger -> DynFlags -> FatalMessager
showPass Logger
logger DynFlags
dflags String
what
  = DynFlags -> Int -> IO () -> IO ()
ifVerbose DynFlags
dflags Int
2 forall a b. (a -> b) -> a -> b
$
    Logger -> DynFlags -> SDoc -> IO ()
logInfo Logger
logger DynFlags
dflags forall a b. (a -> b) -> a -> b
$ PprStyle -> SDoc -> SDoc
withPprStyle PprStyle
defaultUserStyle (String -> SDoc
text String
"***" SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
what SDoc -> SDoc -> SDoc
<> SDoc
colon)

data PrintTimings = PrintTimings | DontPrintTimings
  deriving (PrintTimings -> PrintTimings -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: PrintTimings -> PrintTimings -> Bool
$c/= :: PrintTimings -> PrintTimings -> Bool
== :: PrintTimings -> PrintTimings -> Bool
$c== :: PrintTimings -> PrintTimings -> Bool
Eq, Int -> PrintTimings -> ShowS
[PrintTimings] -> ShowS
PrintTimings -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [PrintTimings] -> ShowS
$cshowList :: [PrintTimings] -> ShowS
show :: PrintTimings -> String
$cshow :: PrintTimings -> String
showsPrec :: Int -> PrintTimings -> ShowS
$cshowsPrec :: Int -> PrintTimings -> ShowS
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 :: forall (m :: * -> *) a.
MonadIO m =>
Logger -> DynFlags -> SDoc -> (a -> ()) -> m a -> m a
withTiming Logger
logger DynFlags
dflags SDoc
what a -> ()
force m a
action =
  forall (m :: * -> *) a.
MonadIO m =>
Logger
-> DynFlags -> SDoc -> (a -> ()) -> PrintTimings -> m a -> m a
withTiming' Logger
logger DynFlags
dflags SDoc
what a -> ()
force PrintTimings
PrintTimings m a
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 :: forall (m :: * -> *) a.
MonadIO m =>
Logger -> DynFlags -> SDoc -> (a -> ()) -> m a -> m a
withTimingSilent Logger
logger DynFlags
dflags SDoc
what a -> ()
force m a
action =
  forall (m :: * -> *) a.
MonadIO m =>
Logger
-> DynFlags -> SDoc -> (a -> ()) -> PrintTimings -> m a -> m a
withTiming' Logger
logger DynFlags
dflags SDoc
what a -> ()
force PrintTimings
DontPrintTimings m a
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' :: forall (m :: * -> *) a.
MonadIO m =>
Logger
-> DynFlags -> SDoc -> (a -> ()) -> PrintTimings -> m a -> m a
withTiming' Logger
logger DynFlags
dflags SDoc
what a -> ()
force_result PrintTimings
prtimings m a
action
  = if DynFlags -> Int
verbosity DynFlags
dflags forall a. Ord a => a -> a -> Bool
>= Int
2 Bool -> Bool -> Bool
|| DumpFlag -> DynFlags -> Bool
dopt DumpFlag
Opt_D_dump_timings DynFlags
dflags
    then do IO () -> m ()
whenPrintTimings forall a b. (a -> b) -> a -> b
$
              Logger -> DynFlags -> SDoc -> IO ()
logInfo Logger
logger DynFlags
dflags forall a b. (a -> b) -> a -> b
$ PprStyle -> SDoc -> SDoc
withPprStyle PprStyle
defaultUserStyle forall a b. (a -> b) -> a -> b
$
                String -> SDoc
text String
"***" SDoc -> SDoc -> SDoc
<+> SDoc
what SDoc -> SDoc -> SDoc
<> SDoc
colon
            let ctx :: SDocContext
ctx = DynFlags -> SDocContext
initDefaultSDocContext DynFlags
dflags
            Int64
alloc0 <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO Int64
getAllocationCounter
            Integer
start <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO Integer
getCPUTime
            SDocContext -> SDoc -> m ()
eventBegins SDocContext
ctx SDoc
what
            forall {m :: * -> *} {a}. (MonadIO m, Show a) => a -> m ()
recordAllocs Int64
alloc0
            !a
r <- m a
action
            () <- forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ a -> ()
force_result a
r
            SDocContext -> SDoc -> m ()
eventEnds SDocContext
ctx SDoc
what
            Integer
end <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO Integer
getCPUTime
            Int64
alloc1 <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO Int64
getAllocationCounter
            forall {m :: * -> *} {a}. (MonadIO m, Show a) => a -> m ()
recordAllocs Int64
alloc1
            -- recall that allocation counter counts down
            let alloc :: Int64
alloc = Int64
alloc0 forall a. Num a => a -> a -> a
- Int64
alloc1
                time :: Double
time = forall a b. (Real a, Fractional b) => a -> b
realToFrac (Integer
end forall a. Num a => a -> a -> a
- Integer
start) forall a. Num a => a -> a -> a
* Double
1e-9

            forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (DynFlags -> Int
verbosity DynFlags
dflags forall a. Ord a => a -> a -> Bool
>= Int
2 Bool -> Bool -> Bool
&& PrintTimings
prtimings forall a. Eq a => a -> a -> Bool
== PrintTimings
PrintTimings)
                forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Logger -> DynFlags -> SDoc -> IO ()
logInfo Logger
logger DynFlags
dflags forall a b. (a -> b) -> a -> b
$ PprStyle -> SDoc -> SDoc
withPprStyle PprStyle
defaultUserStyle
                    (String -> SDoc
text String
"!!!" SDoc -> SDoc -> SDoc
<+> SDoc
what SDoc -> SDoc -> SDoc
<> SDoc
colon SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"finished in"
                     SDoc -> SDoc -> SDoc
<+> Int -> Double -> SDoc
doublePrec Int
2 Double
time
                     SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"milliseconds"
                     SDoc -> SDoc -> SDoc
<> SDoc
comma
                     SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"allocated"
                     SDoc -> SDoc -> SDoc
<+> Int -> Double -> SDoc
doublePrec Int
3 (forall a b. (Real a, Fractional b) => a -> b
realToFrac Int64
alloc forall a. Fractional a => a -> a -> a
/ Double
1024 forall a. Fractional a => a -> a -> a
/ Double
1024)
                     SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"megabytes")

            IO () -> m ()
whenPrintTimings forall a b. (a -> b) -> a -> b
$
                Logger
-> DynFlags -> DumpFlag -> String -> DumpFormat -> SDoc -> IO ()
dumpIfSet_dyn Logger
logger DynFlags
dflags DumpFlag
Opt_D_dump_timings String
"" DumpFormat
FormatText
                    forall a b. (a -> b) -> a -> b
$ String -> SDoc
text forall a b. (a -> b) -> a -> b
$ SDocContext -> SDoc -> String
showSDocOneLine SDocContext
ctx
                    forall a b. (a -> b) -> a -> b
$ [SDoc] -> SDoc
hsep [ SDoc
what SDoc -> SDoc -> SDoc
<> SDoc
colon
                           , String -> SDoc
text String
"alloc=" SDoc -> SDoc -> SDoc
<> forall a. Outputable a => a -> SDoc
ppr Int64
alloc
                           , String -> SDoc
text String
"time=" SDoc -> SDoc -> SDoc
<> Int -> Double -> SDoc
doublePrec Int
3 Double
time
                           ]
            forall (f :: * -> *) a. Applicative f => a -> f a
pure a
r
     else m a
action

    where whenPrintTimings :: IO () -> m ()
whenPrintTimings = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (PrintTimings
prtimings forall a. Eq a => a -> a -> Bool
== PrintTimings
PrintTimings)

          recordAllocs :: a -> m ()
recordAllocs a
alloc =
            forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ FatalMessager
traceMarkerIO forall a b. (a -> b) -> a -> b
$ String
"GHC:allocs:" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show a
alloc

          eventBegins :: SDocContext -> SDoc -> m ()
eventBegins SDocContext
ctx SDoc
w = do
            let doc :: String
doc = SDocContext -> SDoc -> String
eventBeginsDoc SDocContext
ctx SDoc
w
            IO () -> m ()
whenPrintTimings forall a b. (a -> b) -> a -> b
$ FatalMessager
traceMarkerIO String
doc
            forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ FatalMessager
traceEventIO String
doc

          eventEnds :: SDocContext -> SDoc -> m ()
eventEnds SDocContext
ctx SDoc
w = do
            let doc :: String
doc = SDocContext -> SDoc -> String
eventEndsDoc SDocContext
ctx SDoc
w
            IO () -> m ()
whenPrintTimings forall a b. (a -> b) -> a -> b
$ FatalMessager
traceMarkerIO String
doc
            forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ FatalMessager
traceEventIO String
doc

          eventBeginsDoc :: SDocContext -> SDoc -> String
eventBeginsDoc SDocContext
ctx SDoc
w = SDocContext -> SDoc -> String
showSDocOneLine SDocContext
ctx forall a b. (a -> b) -> a -> b
$ String -> SDoc
text String
"GHC:started:" SDoc -> SDoc -> SDoc
<+> SDoc
w
          eventEndsDoc :: SDocContext -> SDoc -> String
eventEndsDoc   SDocContext
ctx SDoc
w = SDocContext -> SDoc -> String
showSDocOneLine SDocContext
ctx forall a b. (a -> b) -> a -> b
$ String -> SDoc
text String
"GHC:finished:" SDoc -> SDoc -> SDoc
<+> SDoc
w

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

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

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

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

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

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

prettyPrintGhcErrors :: ExceptionMonad m => DynFlags -> m a -> m a
prettyPrintGhcErrors :: forall (m :: * -> *) a. ExceptionMonad m => DynFlags -> m a -> m a
prettyPrintGhcErrors DynFlags
dflags
    = forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
(e -> m a) -> m a -> m a
MC.handle forall a b. (a -> b) -> a -> b
$ \GhcException
e -> case GhcException
e of
                      PprPanic String
str SDoc
doc ->
                          forall a. SDocContext -> (String -> a) -> SDoc -> SDoc -> a
pprDebugAndThen SDocContext
ctx forall a. String -> a
panic (String -> SDoc
text String
str) SDoc
doc
                      PprSorry String
str SDoc
doc ->
                          forall a. SDocContext -> (String -> a) -> SDoc -> SDoc -> a
pprDebugAndThen SDocContext
ctx forall a. String -> a
sorry (String -> SDoc
text String
str) SDoc
doc
                      PprProgramError String
str SDoc
doc ->
                          forall a. SDocContext -> (String -> a) -> SDoc -> SDoc -> a
pprDebugAndThen SDocContext
ctx forall a. String -> a
pgmError (String -> SDoc
text String
str) SDoc
doc
                      GhcException
_ ->
                          forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall e a. Exception e => e -> IO a
throwIO GhcException
e
      where
         ctx :: SDocContext
ctx = DynFlags -> PprStyle -> SDocContext
initSDocContext DynFlags
dflags PprStyle
defaultUserStyle

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

           -- And run it!
        ; IO a
action forall a. IO a -> (IOException -> IO a) -> IO a
`catchIO` Int -> IOException -> IO a
handle_exn Int
verb
        }
  where
    handle_exn :: Int -> IOException -> IO a
handle_exn Int
_verb IOException
exn = do { Logger -> DynFlags -> Int -> SDoc -> IO ()
debugTraceMsg Logger
logger DynFlags
dflags Int
2 (Char -> SDoc
char Char
'\n')
                              ; Logger -> DynFlags -> Int -> SDoc -> IO ()
debugTraceMsg Logger
logger DynFlags
dflags Int
2
                                (String -> SDoc
text String
"Failed:"
                                 SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
cmd_line
                                 SDoc -> SDoc -> SDoc
<+> String -> SDoc
text (forall a. Show a => a -> String
show IOException
exn))
                              ; forall a. GhcException -> IO a
throwGhcExceptionIO (String -> GhcException
ProgramError (forall a. Show a => a -> String
show IOException
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).

-}