Commit b3e5c731 authored by Alp Mestanogullari's avatar Alp Mestanogullari Committed by Marge Bot

ErrUtils: split withTiming into withTiming and withTimingSilent

'withTiming' becomes a function that, when passed '-vN' (N >= 2) or
'-ddump-timings', will print timing (and possibly allocations) related
information. When additionally built with '-eventlog' and executed with
'+RTS -l', 'withTiming' will also emit both 'traceMarker' and 'traceEvent'
events to the eventlog.

'withTimingSilent' on the other hand will never print any timing information,
under any circumstance, and will only emit 'traceEvent' events to the eventlog.
As pointed out in !1672, 'traceMarker' is better suited for things that we
might want to visualize in tools like eventlog2html, while 'traceEvent'
is better suited for internal events that occur a lot more often and that we
don't necessarily want to visualize.

This addresses #17138 by using 'withTimingSilent' for all the codegen bits
that are expressed as a bunch of small computations over streams of codegen
ASTs.
parent 52173990
Pipeline #10370 passed with stages
in 306 minutes and 32 seconds
......@@ -71,7 +71,7 @@ codeGen dflags this_mod data_tycons
; cgref <- liftIO $ newIORef =<< initC
; let cg :: FCode () -> Stream IO CmmGroup ()
cg fcode = do
cmm <- liftIO . withTiming (return dflags) (text "STG -> Cmm") (`seq` ()) $ do
cmm <- liftIO . withTimingSilent (return dflags) (text "STG -> Cmm") (`seq` ()) $ do
st <- readIORef cgref
let (a,st') = runC dflags this_mod st (getCmm fcode)
......
......@@ -48,7 +48,7 @@ import Hoopl.Collections
import GHC.Platform
import Maybes
import DynFlags
import ErrUtils (withTiming)
import ErrUtils (withTimingSilent)
import Panic
import UniqSupply
import MonadUtils
......@@ -74,7 +74,8 @@ cmmToRawCmm dflags cmms
; let do_one :: UniqSupply -> [CmmDecl] -> IO (UniqSupply, [RawCmmDecl])
do_one uniqs cmm =
-- NB. strictness fixes a space leak. DO NOT REMOVE.
withTiming (return dflags) (text "Cmm -> Raw Cmm") forceRes $
withTimingSilent (return dflags) (text "Cmm -> Raw Cmm")
forceRes $
case initUs uniqs $ concatMapM (mkInfoTable dflags) cmm of
(b,uniqs') -> return (uniqs',b)
; return (snd <$> Stream.mapAccumL_ do_one uniqs cmms)
......
......@@ -39,7 +39,7 @@ cmmPipeline
-> CmmGroup -- Input C-- with Procedures
-> IO (ModuleSRTInfo, CmmGroup) -- Output CPS transformed C--
cmmPipeline hsc_env srtInfo prog = withTiming (return dflags) (text "Cmm pipeline") forceRes $
cmmPipeline hsc_env srtInfo prog = withTimingSilent (return dflags) (text "Cmm pipeline") forceRes $
do let dflags = hsc_dflags hsc_env
tops <- {-# SCC "tops" #-} mapM (cpsTop hsc_env) prog
......
......@@ -399,7 +399,7 @@ loadInterface doc_str mod from
-- Redo search for our local hole module
loadInterface doc_str (mkModule (thisPackage dflags) (moduleName mod)) from
| otherwise
= withTiming getDynFlags (text "loading interface") (pure ()) $
= withTimingSilent getDynFlags (text "loading interface") (pure ()) $
do { -- Read the state
(eps,hpt) <- getEpsAndHpt
; gbl_env <- getGblEnv
......
......@@ -70,9 +70,10 @@ codeOutput dflags this_mod filenm location foreign_stubs foreign_fps pkg_deps
then Stream.mapM do_lint cmm_stream
else cmm_stream
do_lint cmm = withTiming (pure dflags)
(text "CmmLint"<+>brackets (ppr this_mod))
(const ()) $ do
do_lint cmm = withTimingSilent
(pure dflags)
(text "CmmLint"<+>brackets (ppr this_mod))
(const ()) $ do
{ case cmmLint dflags cmm of
Just err -> do { log_action dflags
dflags
......
......@@ -50,7 +50,7 @@ module ErrUtils (
errorMsg, warningMsg,
fatalErrorMsg, fatalErrorMsg'',
compilationProgressMsg,
showPass, withTiming,
showPass, withTiming, withTimingSilent,
debugTraceMsg,
ghcExit,
prettyPrintGhcErrors,
......@@ -619,11 +619,15 @@ showPass dflags what
= ifVerbose dflags 2 $
logInfo dflags (defaultUserStyle dflags) (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,
--
......@@ -643,31 +647,62 @@ showPass dflags what
--
-- See Note [withTiming] for more.
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')
-> m a -- ^ The body of the phase to be timed
=> 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
withTiming getDFlags what force_result action
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
= do dflags <- getDFlags
if verbosity dflags >= 2 || dopt Opt_D_dump_timings dflags
then do liftIO $ logInfo dflags (defaultUserStyle dflags)
$ text "***" <+> what <> colon
liftIO $ traceEventIO $ showSDocOneLine dflags $ text "GHC:started:" <+> what
then do whenPrintTimings $
logInfo dflags (defaultUserStyle dflags) $
text "***" <+> what <> colon
eventBegins dflags what
alloc0 <- liftIO getAllocationCounter
start <- liftIO getCPUTime
!r <- action
() <- pure $ force_result r
liftIO $ traceEventIO $ showSDocOneLine dflags $ text "GHC:finished:" <+> what
eventEnds dflags what
end <- liftIO getCPUTime
alloc1 <- liftIO getAllocationCounter
-- recall that allocation counter counts down
let alloc = alloc0 - alloc1
time = realToFrac (end - start) * 1e-9
when (verbosity dflags >= 2)
when (verbosity dflags >= 2 && prtimings == PrintTimings)
$ liftIO $ logInfo dflags (defaultUserStyle dflags)
(text "!!!" <+> what <> colon <+> text "finished in"
<+> doublePrec 2 time
......@@ -677,15 +712,27 @@ withTiming getDFlags what force_result action
<+> doublePrec 3 (realToFrac alloc / 1024 / 1024)
<+> text "megabytes")
liftIO $ dumpIfSet_dyn dflags Opt_D_dump_timings ""
$ text $ showSDocOneLine dflags
$ hsep [ what <> colon
, text "alloc=" <> ppr alloc
, text "time=" <> doublePrec 3 time
]
whenPrintTimings $
dumpIfSet_dyn dflags Opt_D_dump_timings ""
$ text $ showSDocOneLine dflags
$ hsep [ what <> colon
, text "alloc=" <> ppr alloc
, text "time=" <> doublePrec 3 time
]
pure r
else action
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
debugTraceMsg :: DynFlags -> Int -> MsgDoc -> IO ()
debugTraceMsg dflags val msg = ifVerbose dflags val $
logInfo dflags (defaultDumpStyle dflags) msg
......@@ -759,15 +806,18 @@ 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
-> m a -- computation we're timing
=> 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,
(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.
......
......@@ -334,7 +334,7 @@ finishNativeGen :: Instruction instr
-> NativeGenAcc statics instr
-> IO UniqSupply
finishNativeGen dflags modLoc bufh@(BufHandle _ _ h) us ngs
= withTiming (return dflags) (text "NCG") (`seq` ()) $ do
= withTimingSilent (return dflags) (text "NCG") (`seq` ()) $ do
-- Write debug data and finish
let emitDw = debugLevel dflags > 0
us' <- if not emitDw then return us else do
......@@ -402,8 +402,9 @@ cmmNativeGenStream dflags this_mod modLoc ncgImpl h us cmm_stream ngs
a)
Right (cmms, cmm_stream') -> do
(us', ngs'') <-
withTiming (return dflags)
ncglabel (\(a, b) -> a `seq` b `seq` ()) $ do
withTimingSilent
(return dflags)
ncglabel (\(a, b) -> a `seq` b `seq` ()) $ do
-- Generate debug information
let debugFlag = debugLevel dflags > 0
!ndbgs | debugFlag = cmmDebugGen modLoc cmms
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment