compiler: emit finer grained codegen events to eventlog

1 files changed, 25 insertions, 20 deletions

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.