compiler: emit finer grained codegen events to eventlog

5 files changed, 64 insertions, 48 deletions

diff --git a/compiler/cmm/CmmInfo.hs b/compiler/cmm/CmmInfo.hs
index 16ab6ed587..2f54aca74e 100644
--- a/compiler/cmm/CmmInfo.hs
+++ b/compiler/cmm/CmmInfo.hs
@@ -48,6 +48,7 @@ import Hoopl.Collections
 import GHC.Platform
 import Maybes
 import DynFlags
+import ErrUtils (withTiming)
 import Panic
 import UniqSupply
 import MonadUtils
@@ -70,13 +71,17 @@ cmmToRawCmm :: DynFlags -> Stream IO CmmGroup ()
             -> IO (Stream IO RawCmmGroup ())
 cmmToRawCmm dflags cmms
   = do { uniqs <- mkSplitUniqSupply 'i'
-       ; let do_one uniqs cmm = do
-                case initUs uniqs $ concatMapM (mkInfoTable dflags) cmm of
-                  (b,uniqs') -> return (uniqs',b)
-                  -- NB. strictness fixes a space leak.  DO NOT REMOVE.
+       ; let do_one uniqs cmm =
+               -- NB. strictness fixes a space leak.  DO NOT REMOVE.
+               withTiming (return dflags) (text "Cmm -> Raw Cmm") forceRes $
+                 case initUs uniqs $ concatMapM (mkInfoTable dflags) cmm of
+                   (b,uniqs') -> return (uniqs',b)
        ; return (Stream.mapAccumL do_one uniqs cmms >> return ())
        }
 
+    where forceRes (uniqs, rawcmms) =
+            uniqs `seq` foldr (\decl r -> decl `seq` r) () rawcmms
+
 -- Make a concrete info table, represented as a list of CmmStatic
 -- (it can't be simply a list of Word, because the SRT field is
 -- represented by a label+offset expression).
diff --git a/compiler/cmm/CmmPipeline.hs b/compiler/cmm/CmmPipeline.hs
index a6d981a7f9..4ad93598aa 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 =
+cmmPipeline hsc_env srtInfo prog = withTiming (return dflags) (text "Cmm pipeline") forceRes $
   do let dflags = hsc_dflags hsc_env
 
      tops <- {-# SCC "tops" #-} mapM (cpsTop hsc_env) prog
@@ -49,6 +49,10 @@ cmmPipeline hsc_env srtInfo prog =
 
      return (srtInfo, cmms)
 
+  where forceRes (info, group) =
+          info `seq` foldr (\decl r -> decl `seq` r) () group
+
+        dflags = hsc_dflags hsc_env
 
 cpsTop :: HscEnv -> CmmDecl -> IO (CAFEnv, [CmmDecl])
 cpsTop _ p@(CmmData {}) = return (mapEmpty, [p])
diff --git a/compiler/codeGen/StgCmm.hs b/compiler/codeGen/StgCmm.hs
index 6cdb14880a..83409b6b24 100644
--- a/compiler/codeGen/StgCmm.hs
+++ b/compiler/codeGen/StgCmm.hs
@@ -32,6 +32,7 @@ import CLabel
 
 import StgSyn
 import DynFlags
+import ErrUtils
 
 import HscTypes
 import CostCentre
@@ -70,7 +71,7 @@ codeGen dflags this_mod data_tycons
         ; cgref <- liftIO $ newIORef =<< initC
         ; let cg :: FCode () -> Stream IO CmmGroup ()
               cg fcode = do
-                cmm <- liftIO $ do
+                cmm <- liftIO . withTiming (return dflags) (text "STG -> Cmm") (`seq` ()) $ do
                          st <- readIORef cgref
                          let (a,st') = runC dflags this_mod st (getCmm fcode)
 
diff --git a/compiler/main/CodeOutput.hs b/compiler/main/CodeOutput.hs
index 6f80df9676..4133526532 100644
--- a/compiler/main/CodeOutput.hs
+++ b/compiler/main/CodeOutput.hs
@@ -120,28 +120,29 @@ outputC dflags filenm cmm_stream packages
        -- ToDo: make the C backend consume the C-- incrementally, by
        -- pushing the cmm_stream inside (c.f. nativeCodeGen)
        rawcmms <- Stream.collect cmm_stream
-
-       -- figure out which header files to #include in the generated .hc file:
-       --
-       --   * extra_includes from packages
-       --   * -#include options from the cmdline and OPTIONS pragmas
-       --   * the _stub.h file, if there is one.
-       --
-       let rts = getPackageDetails dflags rtsUnitId
-
-       let cc_injects = unlines (map mk_include (includes rts))
-           mk_include h_file =
-            case h_file of
-               '"':_{-"-} -> "#include "++h_file
-               '<':_      -> "#include "++h_file
-               _          -> "#include \""++h_file++"\""
-
-       let pkg_names = map installedUnitIdString packages
-
-       doOutput filenm $ \ h -> do
-          hPutStr h ("/* GHC_PACKAGES " ++ unwords pkg_names ++ "\n*/\n")
-          hPutStr h cc_injects
-          writeCs dflags h rawcmms
+       withTiming (return dflags) (text "C codegen") id $ do
+
+         -- figure out which header files to #include in the generated .hc file:
+         --
+         --   * extra_includes from packages
+         --   * -#include options from the cmdline and OPTIONS pragmas
+         --   * the _stub.h file, if there is one.
+         --
+         let rts = getPackageDetails dflags rtsUnitId
+
+         let cc_injects = unlines (map mk_include (includes rts))
+             mk_include h_file =
+              case h_file of
+                 '"':_{-"-} -> "#include "++h_file
+                 '<':_      -> "#include "++h_file
+                 _          -> "#include \""++h_file++"\""
+
+         let pkg_names = map installedUnitIdString packages
+
+         doOutput filenm $ \ h -> do
+            hPutStr h ("/* GHC_PACKAGES " ++ unwords pkg_names ++ "\n*/\n")
+            hPutStr h cc_injects
+            writeCs dflags h rawcmms
 
 {-
 ************************************************************************
diff --git a/compiler/nativeGen/AsmCodeGen.hs b/compiler/nativeGen/AsmCodeGen.hs
index 6e9450fd85..40a1e0b067 100644
--- a/compiler/nativeGen/AsmCodeGen.hs
+++ b/compiler/nativeGen/AsmCodeGen.hs
@@ -335,7 +335,7 @@ finishNativeGen :: Instruction instr
                 -> NativeGenAcc statics instr
                 -> IO UniqSupply
 finishNativeGen dflags modLoc bufh@(BufHandle _ _ h) us ngs
- = do
+ = withTiming (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
@@ -401,29 +401,34 @@ cmmNativeGenStream dflags this_mod modLoc ncgImpl h us cmm_stream ngs
                       },
                   us)
         Right (cmms, cmm_stream') -> do
-
-          -- Generate debug information
-          let debugFlag = debugLevel dflags > 0
-              !ndbgs | debugFlag = cmmDebugGen modLoc cmms
-                     | otherwise = []
-              dbgMap = debugToMap ndbgs
-
-          -- Generate native code
-          (ngs',us') <- cmmNativeGens dflags this_mod modLoc ncgImpl h
-                                             dbgMap us cmms ngs 0
-
-          -- Link native code information into debug blocks
-          -- See Note [What is this unwinding business?] in Debug.
-          let !ldbgs = cmmDebugLink (ngs_labels ngs') (ngs_unwinds ngs') ndbgs
-          dumpIfSet_dyn dflags Opt_D_dump_debug "Debug Infos"
-            (vcat $ map ppr ldbgs)
-
-          -- Accumulate debug information for emission in finishNativeGen.
-          let ngs'' = ngs' { ngs_debug = ngs_debug ngs' ++ ldbgs, ngs_labels = [] }
+          (us', ngs'') <-
+            withTiming (return dflags)
+                       ncglabel (\(a, b) -> a `seq` b `seq` ()) $ do
+              -- Generate debug information
+              let debugFlag = debugLevel dflags > 0
+                  !ndbgs | debugFlag = cmmDebugGen modLoc cmms
+                         | otherwise = []
+                  dbgMap = debugToMap ndbgs
+
+              -- Generate native code
+              (ngs',us') <- cmmNativeGens dflags this_mod modLoc ncgImpl h
+                                               dbgMap us cmms ngs 0
+
+              -- Link native code information into debug blocks
+              -- See Note [What is this unwinding business?] in Debug.
+              let !ldbgs = cmmDebugLink (ngs_labels ngs') (ngs_unwinds ngs') ndbgs
+              dumpIfSet_dyn dflags Opt_D_dump_debug "Debug Infos"
+                (vcat $ map ppr ldbgs)
+
+              -- Accumulate debug information for emission in finishNativeGen.
+              let ngs'' = ngs' { ngs_debug = ngs_debug ngs' ++ ldbgs, ngs_labels = [] }
+              return (us', ngs'')
 
           cmmNativeGenStream dflags this_mod modLoc ncgImpl h us'
               cmm_stream' ngs''
 
+    where ncglabel = text "NCG"
+
 -- | Do native code generation on all these cmms.
 --
 cmmNativeGens :: forall statics instr jumpDest.