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.

7 files changed, 89 insertions, 36 deletions

diff --git a/compiler/GHC/StgToCmm.hs b/compiler/GHC/StgToCmm.hs
index 23d6ceeaa6..96fa9e5cc1 100644
--- a/compiler/GHC/StgToCmm.hs
+++ b/compiler/GHC/StgToCmm.hs
@@ -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)
 
diff --git a/compiler/cmm/CmmInfo.hs b/compiler/cmm/CmmInfo.hs
index 60814f8039..82abbb62bd 100644
--- a/compiler/cmm/CmmInfo.hs
+++ b/compiler/cmm/CmmInfo.hs
@@ -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)
diff --git a/compiler/cmm/CmmPipeline.hs b/compiler/cmm/CmmPipeline.hs
index 4ad93598aa..5ac3fddb3b 100644
--- a/compiler/cmm/CmmPipeline.hs
+++ b/compiler/cmm/CmmPipeline.hs
@@ -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
diff --git a/compiler/iface/LoadIface.hs b/compiler/iface/LoadIface.hs
index 16963dcb94..f501e0354b 100644
--- a/compiler/iface/LoadIface.hs
+++ b/compiler/iface/LoadIface.hs
@@ -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
diff --git a/compiler/main/CodeOutput.hs b/compiler/main/CodeOutput.hs
index 839999a32c..4109e50c02 100644
--- a/compiler/main/CodeOutput.hs
+++ b/compiler/main/CodeOutput.hs
@@ -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
diff --git a/compiler/main/ErrUtils.hs b/compiler/main/ErrUtils.hs
index d270533acd..ba94ec0c50 100644
--- a/compiler/main/ErrUtils.hs
+++ b/compiler/main/ErrUtils.hs
@@ -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 pass@.
+-- 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.
 
diff --git a/compiler/nativeGen/AsmCodeGen.hs b/compiler/nativeGen/AsmCodeGen.hs
index f6ccc08aee..e033a4c218 100644
--- a/compiler/nativeGen/AsmCodeGen.hs
+++ b/compiler/nativeGen/AsmCodeGen.hs
@@ -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