compiler: trace SysTools commands to emit start/stop eventlog markers

This patch was motivated by some performance characterization work done
for #16822, where we suspected that GHC was spending a lot of time waiting
on the linker to be done. (That turned out to be true.)

The tracing is taken care of by ErrUtils.withTiming, so this patch just defines
and uses a little wrapper around that function in all the helpers for
calling the various systools (C compiler, linker, unlit, ...).

With this patch, assuming a GHC executable linked against an eventlog-capable
RTS (RTS ways that contain the debug, profiling or eventlog way units), we can
measure how much time is spent in each of the SysTools when building hello.hs
by simply doing:

  ghc hello.hs -ddump-timings +RTS -l

The event names are "systool:{cc, linker, as, unlit, ...}".

1 files changed, 31 insertions, 18 deletions

diff --git a/compiler/main/SysTools/Tasks.hs b/compiler/main/SysTools/Tasks.hs
index 0310bd8eb2..eeaadfa5b8 100644
--- a/compiler/main/SysTools/Tasks.hs
+++ b/compiler/main/SysTools/Tasks.hs
@@ -37,14 +37,14 @@ import SysTools.Info
 -}
 
 runUnlit :: DynFlags -> [Option] -> IO ()
-runUnlit dflags args = do
+runUnlit dflags args = traceToolCommand dflags "unlit" $ do
   let prog = pgm_L dflags
       opts = getOpts dflags opt_L
   runSomething dflags "Literate pre-processor" prog
                (map Option opts ++ args)
 
 runCpp :: DynFlags -> [Option] -> IO ()
-runCpp dflags args =   do
+runCpp dflags args = traceToolCommand dflags "cpp" $ do
   let (p,args0) = pgm_P dflags
       args1 = map Option (getOpts dflags opt_P)
       args2 = [Option "-Werror" | gopt Opt_WarnIsError dflags]
@@ -54,14 +54,14 @@ runCpp dflags args =   do
                        (args0 ++ args1 ++ args2 ++ args) Nothing mb_env
 
 runPp :: DynFlags -> [Option] -> IO ()
-runPp dflags args =   do
+runPp dflags args = traceToolCommand dflags "pp" $ do
   let prog = pgm_F dflags
       opts = map Option (getOpts dflags opt_F)
   runSomething dflags "Haskell pre-processor" prog (args ++ opts)
 
 -- | Run compiler of C-like languages and raw objects (such as gcc or clang).
 runCc :: Maybe ForeignSrcLang -> DynFlags -> [Option] -> IO ()
-runCc mLanguage dflags args =   do
+runCc mLanguage dflags args = traceToolCommand dflags "cc" $ do
   let p = pgm_c dflags
       args1 = map Option userOpts
       args2 = languageOptions ++ args ++ args1
@@ -144,7 +144,7 @@ xs `isContainedIn` ys = any (xs `isPrefixOf`) (tails ys)
 
 -- | Run the linker with some arguments and return the output
 askLd :: DynFlags -> [Option] -> IO String
-askLd dflags args = do
+askLd dflags args = traceToolCommand dflags "linker" $ do
   let (p,args0) = pgm_l dflags
       args1     = map Option (getOpts dflags opt_l)
       args2     = args0 ++ args1 ++ args
@@ -153,7 +153,7 @@ askLd dflags args = do
     readCreateProcessWithExitCode' (proc p real_args){ env = mb_env }
 
 runAs :: DynFlags -> [Option] -> IO ()
-runAs dflags args = do
+runAs dflags args = traceToolCommand dflags "as" $ do
   let (p,args0) = pgm_a dflags
       args1 = map Option (getOpts dflags opt_a)
       args2 = args0 ++ args1 ++ args
@@ -162,7 +162,7 @@ runAs dflags args = do
 
 -- | Run the LLVM Optimiser
 runLlvmOpt :: DynFlags -> [Option] -> IO ()
-runLlvmOpt dflags args = do
+runLlvmOpt dflags args = traceToolCommand dflags "opt" $ do
   let (p,args0) = pgm_lo dflags
       args1 = map Option (getOpts dflags opt_lo)
       -- We take care to pass -optlo flags (e.g. args0) last to ensure that the
@@ -171,7 +171,7 @@ runLlvmOpt dflags args = do
 
 -- | Run the LLVM Compiler
 runLlvmLlc :: DynFlags -> [Option] -> IO ()
-runLlvmLlc dflags args = do
+runLlvmLlc dflags args = traceToolCommand dflags "llc" $ do
   let (p,args0) = pgm_lc dflags
       args1 = map Option (getOpts dflags opt_lc)
   runSomething dflags "LLVM Compiler" p (args0 ++ args1 ++ args)
@@ -180,7 +180,7 @@ runLlvmLlc dflags args = do
 -- backend on OS X as LLVM doesn't support the OS X system
 -- assembler)
 runClang :: DynFlags -> [Option] -> IO ()
-runClang dflags args = do
+runClang dflags args = traceToolCommand dflags "clang" $ do
   let (clang,_) = pgm_lcc dflags
       -- be careful what options we call clang with
       -- see #5903 and #7617 for bugs caused by this.
@@ -201,7 +201,7 @@ runClang dflags args = do
 
 -- | Figure out which version of LLVM we are running this session
 figureLlvmVersion :: DynFlags -> IO (Maybe LlvmVersion)
-figureLlvmVersion dflags = do
+figureLlvmVersion dflags = traceToolCommand dflags "llc" $ do
   let (pgm,opts) = pgm_lc dflags
       args = filter notNull (map showOpt opts)
       -- we grab the args even though they should be useless just in
@@ -246,7 +246,7 @@ figureLlvmVersion dflags = do
 
 
 runLink :: DynFlags -> [Option] -> IO ()
-runLink dflags args = do
+runLink dflags args = traceToolCommand dflags "linker" $ do
   -- See Note [Run-time linker info]
   linkargs <- neededLinkArgs `fmap` getLinkerInfo dflags
   let (p,args0) = pgm_l dflags
@@ -306,7 +306,7 @@ ld: warning: symbol referencing errors
 
 
 runLibtool :: DynFlags -> [Option] -> IO ()
-runLibtool dflags args = do
+runLibtool dflags args = traceToolCommand dflags "libtool" $ do
   linkargs <- neededLinkArgs `fmap` getLinkerInfo dflags
   let args1      = map Option (getOpts dflags opt_l)
       args2      = [Option "-static"] ++ args1 ++ args ++ linkargs
@@ -315,30 +315,30 @@ runLibtool dflags args = do
   runSomethingFiltered dflags id "Linker" libtool args2 Nothing mb_env
 
 runAr :: DynFlags -> Maybe FilePath -> [Option] -> IO ()
-runAr dflags cwd args = do
+runAr dflags cwd args = traceToolCommand dflags "ar" $ do
   let ar = pgm_ar dflags
   runSomethingFiltered dflags id "Ar" ar args cwd Nothing
 
 askAr :: DynFlags -> Maybe FilePath -> [Option] -> IO String
-askAr dflags mb_cwd args = do
+askAr dflags mb_cwd args = traceToolCommand dflags "ar" $ do
   let ar = pgm_ar dflags
   runSomethingWith dflags "Ar" ar args $ \real_args ->
     readCreateProcessWithExitCode' (proc ar real_args){ cwd = mb_cwd }
 
 runRanlib :: DynFlags -> [Option] -> IO ()
-runRanlib dflags args = do
+runRanlib dflags args = traceToolCommand dflags "ranlib" $ do
   let ranlib = pgm_ranlib dflags
   runSomethingFiltered dflags id "Ranlib" ranlib args Nothing Nothing
 
 runMkDLL :: DynFlags -> [Option] -> IO ()
-runMkDLL dflags args = do
+runMkDLL dflags args = traceToolCommand dflags "mkdll" $ do
   let (p,args0) = pgm_dll dflags
       args1 = args0 ++ args
   mb_env <- getGccEnv (args0++args)
   runSomethingFiltered dflags id "Make DLL" p args1 Nothing mb_env
 
 runWindres :: DynFlags -> [Option] -> IO ()
-runWindres dflags args = do
+runWindres dflags args = traceToolCommand dflags "windres" $ do
   let cc = pgm_c dflags
       cc_args = map Option (sOpt_c (settings dflags))
       windres = pgm_windres dflags
@@ -361,5 +361,18 @@ runWindres dflags args = do
   runSomethingFiltered dflags id "Windres" windres args' Nothing mb_env
 
 touch :: DynFlags -> String -> String -> IO ()
-touch dflags purpose arg =
+touch dflags purpose arg = traceToolCommand dflags "touch" $
   runSomething dflags purpose (pgm_T dflags) [FileOption "" arg]
+
+-- * Tracing utility
+
+-- | Record in the eventlog when the given tool command starts
+--   and finishes, prepending the given 'String' with
+--   \"systool:\", to easily be able to collect and process
+--   all the systool events.
+--
+--   For those events to show up in the eventlog, you need
+--   to run GHC with @-v2@ or @-ddump-timings@.
+traceToolCommand :: DynFlags -> String -> IO a -> IO a
+traceToolCommand dflags tool = withTiming
+  (return dflags) (text $ "systool:" ++ tool) (const ())