ErrUtils: Add timings to compiler phases

This adds timings and allocation figures to the compiler's output when
run with `-v2` in an effort to ease performance analysis.

Todo:
  * Documentation
  * Where else should we add these?
  * Perhaps we should remove some of the now-arguably-redundant
    `showPass` occurrences where they are
  * Must we force more?
  * Perhaps we should place this behind a `-ftimings` instead of `-v2`

Test Plan: `ghc -v2 Test.hs`, look at the output

Reviewers: hvr, goldfire, simonmar, austin

Reviewed By: simonmar

Subscribers: angerman, michalt, niteria, ezyang, thomie

Differential Revision: https://phabricator.haskell.org/D1959

17 files changed, 197 insertions, 108 deletions

diff --git a/compiler/cmm/CmmParse.y b/compiler/cmm/CmmParse.y
index 2cbb7b2a59..81e62c2a29 100644
--- a/compiler/cmm/CmmParse.y
+++ b/compiler/cmm/CmmParse.y
@@ -1375,8 +1375,7 @@ initEnv dflags = listToUFM [
   ]
 
 parseCmmFile :: DynFlags -> FilePath -> IO (Messages, Maybe CmmGroup)
-parseCmmFile dflags filename = do
-  showPass dflags "ParseCmm"
+parseCmmFile dflags filename = withTiming (pure dflags) (text "ParseCmm"<+>brackets (text filename)) (\_ -> ()) $ do
   buf <- hGetStringBuffer filename
   let
         init_loc = mkRealSrcLoc (mkFastString filename) 1 1
diff --git a/compiler/coreSyn/CoreLint.hs b/compiler/coreSyn/CoreLint.hs
index 99625c91d4..9baf3fc008 100644
--- a/compiler/coreSyn/CoreLint.hs
+++ b/compiler/coreSyn/CoreLint.hs
@@ -14,7 +14,7 @@ module CoreLint (
     lintAnnots,
 
     -- ** Debug output
-    CoreLint.showPass, showPassIO, endPass, endPassIO,
+    endPass, endPassIO,
     dumpPassResult,
     CoreLint.dumpIfSet,
  ) where
@@ -176,13 +176,6 @@ be, and it makes a conveneint place.  place for them.  They print out
 stuff before and after core passes, and do Core Lint when necessary.
 -}
 
-showPass :: CoreToDo -> CoreM ()
-showPass pass = do { dflags <- getDynFlags
-                   ; liftIO $ showPassIO dflags pass }
-
-showPassIO :: DynFlags -> CoreToDo -> IO ()
-showPassIO dflags pass = Err.showPass dflags (showPpr dflags pass)
-
 endPass :: CoreToDo -> CoreProgram -> [CoreRule] -> CoreM ()
 endPass pass binds rules
   = do { hsc_env <- getHscEnv
diff --git a/compiler/coreSyn/CorePrep.hs b/compiler/coreSyn/CorePrep.hs
index e6acc2bfd3..58eda2fb5c 100644
--- a/compiler/coreSyn/CorePrep.hs
+++ b/compiler/coreSyn/CorePrep.hs
@@ -165,10 +165,12 @@ type CpeRhs  = CoreExpr    -- Non-terminal 'rhs'
 ************************************************************************
 -}
 
-corePrepPgm :: HscEnv -> ModLocation -> CoreProgram -> [TyCon] -> IO CoreProgram
-corePrepPgm hsc_env mod_loc binds data_tycons = do
-    let dflags = hsc_dflags hsc_env
-    showPass dflags "CorePrep"
+corePrepPgm :: HscEnv -> Module -> ModLocation -> CoreProgram -> [TyCon]
+            -> IO CoreProgram
+corePrepPgm hsc_env this_mod mod_loc binds data_tycons =
+    withTiming (pure dflags)
+               (text "CorePrep"<+>brackets (ppr this_mod))
+               (const ()) $ do
     us <- mkSplitUniqSupply 's'
     initialCorePrepEnv <- mkInitialCorePrepEnv dflags hsc_env
 
@@ -183,10 +185,12 @@ corePrepPgm hsc_env mod_loc binds data_tycons = do
 
     endPassIO hsc_env alwaysQualify CorePrep binds_out []
     return binds_out
+  where
+    dflags = hsc_dflags hsc_env
 
 corePrepExpr :: DynFlags -> HscEnv -> CoreExpr -> IO CoreExpr
-corePrepExpr dflags hsc_env expr = do
-    showPass dflags "CorePrep"
+corePrepExpr dflags hsc_env expr =
+    withTiming (pure dflags) (text "CorePrep [expr]") (const ()) $ do
     us <- mkSplitUniqSupply 's'
     initialCorePrepEnv <- mkInitialCorePrepEnv dflags hsc_env
     let new_expr = initUs_ us (cpeBodyNF initialCorePrepEnv expr)
diff --git a/compiler/deSugar/Desugar.hs b/compiler/deSugar/Desugar.hs
index 6f14b63b93..ff33177241 100644
--- a/compiler/deSugar/Desugar.hs
+++ b/compiler/deSugar/Desugar.hs
@@ -291,9 +291,10 @@ deSugar hsc_env
 
   = do { let dflags = hsc_dflags hsc_env
              print_unqual = mkPrintUnqualified dflags rdr_env
-        ; showPass dflags "Desugar"
-
-        -- Desugar the program
+        ; withTiming (pure dflags)
+                     (text "Desugar"<+>brackets (ppr mod))
+                     (const ()) $
+     do { -- Desugar the program
         ; let export_set = availsToNameSet exports
               target     = hscTarget dflags
               hpcInfo    = emptyHpcInfo other_hpc_info
@@ -391,7 +392,7 @@ deSugar hsc_env
                 mg_trust_pkg    = imp_trust_own_pkg imports
               }
         ; return (msgs, Just mod_guts)
-        }}}
+        }}}}
 
 mkFileSrcSpan :: ModLocation -> SrcSpan
 mkFileSrcSpan mod_loc
diff --git a/compiler/ghci/ByteCodeGen.hs b/compiler/ghci/ByteCodeGen.hs
index ecbb8e3a8a..da52b54240 100644
--- a/compiler/ghci/ByteCodeGen.hs
+++ b/compiler/ghci/ByteCodeGen.hs
@@ -74,9 +74,9 @@ byteCodeGen :: HscEnv
             -> Maybe ModBreaks
             -> IO CompiledByteCode
 byteCodeGen hsc_env this_mod binds tycs mb_modBreaks
-   = do let dflags = hsc_dflags hsc_env
-        showPass dflags "ByteCodeGen"
-
+   = withTiming (pure dflags)
+                (text "ByteCodeGen"<+>brackets (ppr this_mod))
+                (const ()) $ do
         let flatBinds = [ (bndr, simpleFreeVars rhs)
                         | (bndr, rhs) <- flattenBinds binds]
 
@@ -95,6 +95,7 @@ byteCodeGen hsc_env this_mod binds tycs mb_modBreaks
           (case modBreaks of
              Nothing -> Nothing
              Just mb -> Just mb{ modBreaks_breakInfo = breakInfo })
+  where dflags = hsc_dflags hsc_env
 
 -- -----------------------------------------------------------------------------
 -- Generating byte code for an expression
@@ -105,9 +106,9 @@ coreExprToBCOs :: HscEnv
                -> CoreExpr
                -> IO UnlinkedBCO
 coreExprToBCOs hsc_env this_mod expr
- = do let dflags = hsc_dflags hsc_env
-      showPass dflags "ByteCodeGen"
-
+ = withTiming (pure dflags)
+              (text "ByteCodeGen"<+>brackets (ppr this_mod))
+              (const ()) $ do
       -- create a totally bogus name for the top-level BCO; this
       -- should be harmless, since it's never used for anything
       let invented_name  = mkSystemVarName (mkPseudoUniqueE 0) (fsLit "ExprTopLevel")
@@ -126,7 +127,7 @@ coreExprToBCOs hsc_env this_mod expr
       dumpIfSet_dyn dflags Opt_D_dump_BCOs "Proto-BCOs" (ppr proto_bco)
 
       assembleOneBCO hsc_env proto_bco
-
+  where dflags = hsc_dflags hsc_env
 
 -- The regular freeVars function gives more information than is useful to
 -- us here. simpleFreeVars does the impedence matching.
diff --git a/compiler/llvmGen/LlvmCodeGen.hs b/compiler/llvmGen/LlvmCodeGen.hs
index 872ad8ce78..fd13de6ec6 100644
--- a/compiler/llvmGen/LlvmCodeGen.hs
+++ b/compiler/llvmGen/LlvmCodeGen.hs
@@ -42,7 +42,8 @@ llvmCodeGen :: DynFlags -> Handle -> UniqSupply
                -> Stream.Stream IO RawCmmGroup ()
                -> IO ()
 llvmCodeGen dflags h us cmm_stream
-  = do bufh <- newBufHandle h
+  = withTiming (pure dflags) (text "LLVM CodeGen") (const ()) $ do
+       bufh <- newBufHandle h
 
        -- Pass header
        showPass dflags "LLVM CodeGen"
diff --git a/compiler/llvmGen/LlvmMangler.hs b/compiler/llvmGen/LlvmMangler.hs
index 6ad62d067a..acf344fe2d 100644
--- a/compiler/llvmGen/LlvmMangler.hs
+++ b/compiler/llvmGen/LlvmMangler.hs
@@ -13,7 +13,8 @@ module LlvmMangler ( llvmFixupAsm ) where
 
 import DynFlags ( DynFlags, targetPlatform )
 import Platform ( platformArch, Arch(..) )
-import ErrUtils ( showPass )
+import ErrUtils ( withTiming )
+import Outputable ( text )
 
 import Control.Exception
 import qualified Data.ByteString.Char8 as B
@@ -21,8 +22,8 @@ import System.IO
 
 -- | Read in assembly file and process
 llvmFixupAsm :: DynFlags -> FilePath -> FilePath -> IO ()
-llvmFixupAsm dflags f1 f2 = {-# SCC "llvm_mangler" #-} do
-    showPass dflags "LLVM Mangler"
+llvmFixupAsm dflags f1 f2 = {-# SCC "llvm_mangler" #-}
+    withTiming (pure dflags) (text "LLVM Mangler") id $
     withBinaryFile f1 ReadMode $ \r -> withBinaryFile f2 WriteMode $ \w -> do
         go r w
         hClose r
diff --git a/compiler/main/CodeOutput.hs b/compiler/main/CodeOutput.hs
index 422fd4e35b..f172cf1259 100644
--- a/compiler/main/CodeOutput.hs
+++ b/compiler/main/CodeOutput.hs
@@ -64,9 +64,10 @@ codeOutput dflags this_mod filenm location foreign_stubs pkg_deps cmm_stream
                     then Stream.mapM do_lint cmm_stream
                     else cmm_stream
 
-              do_lint cmm = do
-                { showPass dflags "CmmLint"
-                ; case cmmLint dflags cmm of
+              do_lint cmm = withTiming (pure dflags)
+                                       (text "CmmLint"<+>brackets (ppr this_mod))
+                                       (const ()) $ do
+                { case cmmLint dflags cmm of
                         Just err -> do { log_action dflags
                                                    dflags
                                                    NoReason
diff --git a/compiler/main/ErrUtils.hs b/compiler/main/ErrUtils.hs
index 7e68302ba1..21fd7e8dd2 100644
--- a/compiler/main/ErrUtils.hs
+++ b/compiler/main/ErrUtils.hs
@@ -5,6 +5,7 @@
 -}
 
 {-# LANGUAGE CPP #-}
+{-# LANGUAGE BangPatterns #-}
 
 module ErrUtils (
         -- * Basic types
@@ -41,7 +42,7 @@ module ErrUtils (
         errorMsg, warningMsg,
         fatalErrorMsg, fatalErrorMsg', fatalErrorMsg'',
         compilationProgressMsg,
-        showPass,
+        showPass, withTiming,
         debugTraceMsg,
         ghcExit,
         prettyPrintGhcErrors,
@@ -68,6 +69,8 @@ import Data.Time
 import Control.Monad
 import Control.Monad.IO.Class
 import System.IO
+import GHC.Conc         ( getAllocationCounter )
+import System.CPUTime
 
 -------------------------
 type MsgDoc  = SDoc
@@ -459,6 +462,59 @@ showPass dflags what
   = ifVerbose dflags 2 $
     logInfo dflags defaultUserStyle (text "***" <+> text what <> colon)
 
+-- | 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@.
+-- When timings are enabled the following costs are included in the
+-- produced accounting,
+--
+--  - The cost of executing @pass@ to a result @r@ in WHNF
+--  - The cost of evaluating @force r@ to WHNF (e.g. @()@)
+--
+-- The choice of the @force@ function depends upon the amount of forcing
+-- desired; the goal here is to ensure that the cost of evaluating the result
+-- is, to the greatest extent possible, included in the accounting provided by
+-- 'withTiming'. Often the pass already sufficiently forces its result during
+-- construction; in this case @const ()@ is a reasonable choice.
+-- In other cases, it is necessary to evaluate the result to normal form, in
+-- which case something like @Control.DeepSeq.rnf@ is appropriate.
+--
+-- To avoid adversely affecting compiler performance when timings are not
+-- requested, the result is only forced when timings are enabled.
+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 a
+withTiming getDFlags what force_result action
+  = do dflags <- getDFlags
+       if verbosity dflags >= 2
+          then do liftIO $ logInfo dflags defaultUserStyle
+                         $ text "***" <+> what <> colon
+                  alloc0 <- liftIO getAllocationCounter
+                  start <- liftIO getCPUTime
+                  !r <- action
+                  () <- pure $ force_result r
+                  end <- liftIO getCPUTime
+                  alloc1 <- liftIO getAllocationCounter
+                  -- recall that allocation counter counts down
+                  let alloc = alloc0 - alloc1
+                  liftIO $ logInfo dflags defaultUserStyle
+                      (text "!!!" <+> what <> colon <+> text "finished in"
+                       <+> doublePrec 2 (realToFrac (end - start) * 1e-9)
+                       <+> text "milliseconds"
+                       <> comma
+                       <+> text "allocated"
+                       <+> doublePrec 3 (realToFrac alloc / 1024 / 1024)
+                       <+> text "megabytes")
+                  pure r
+           else action
+
 debugTraceMsg :: DynFlags -> Int -> MsgDoc -> IO ()
 debugTraceMsg dflags val msg = ifVerbose dflags val $
                                logInfo dflags defaultDumpStyle msg
diff --git a/compiler/main/GhcMake.hs b/compiler/main/GhcMake.hs
index 3655c0bb9f..46a49900d5 100644
--- a/compiler/main/GhcMake.hs
+++ b/compiler/main/GhcMake.hs
@@ -114,15 +114,16 @@ depanal excluded_mods allow_dup_roots = do
          targets = hsc_targets hsc_env
          old_graph = hsc_mod_graph hsc_env
 
-  liftIO $ showPass dflags "Chasing dependencies"
-  liftIO $ debugTraceMsg dflags 2 (hcat [
-             text "Chasing modules from: ",
-             hcat (punctuate comma (map pprTarget targets))])
-
-  mod_graphE <- liftIO $ downsweep hsc_env old_graph excluded_mods allow_dup_roots
-  mod_graph <- reportImportErrors mod_graphE
-  modifySession $ \_ -> hsc_env { hsc_mod_graph = mod_graph }
-  return mod_graph
+  withTiming (pure dflags) (text "Chasing dependencies") (const ()) $ do
+    liftIO $ debugTraceMsg dflags 2 (hcat [
+              text "Chasing modules from: ",
+              hcat (punctuate comma (map pprTarget targets))])
+
+    mod_graphE <- liftIO $ downsweep hsc_env old_graph
+                                     excluded_mods allow_dup_roots
+    mod_graph <- reportImportErrors mod_graphE
+    modifySession $ \_ -> hsc_env { hsc_mod_graph = mod_graph }
+    return mod_graph
 
 -- | Describes which modules of the module graph need to be loaded.
 data LoadHowMuch
diff --git a/compiler/main/HscMain.hs b/compiler/main/HscMain.hs
index aaf9a9bb87..385c9f2315 100644
--- a/compiler/main/HscMain.hs
+++ b/compiler/main/HscMain.hs
@@ -339,15 +339,15 @@ hscParse hsc_env mod_summary = runHsc hsc_env $ hscParse' mod_summary
 
 -- internal version, that doesn't fail due to -Werror
 hscParse' :: ModSummary -> Hsc HsParsedModule
-hscParse' mod_summary = do
+hscParse' mod_summary = {-# SCC "Parser" #-}
+    withTiming getDynFlags
+               (text "Parser"<+>brackets (ppr $ ms_mod mod_summary))
+               (const ()) $ do
     dflags <- getDynFlags
     let src_filename  = ms_hspp_file mod_summary
         maybe_src_buf = ms_hspp_buf  mod_summary
 
     --------------------------  Parser  ----------------
-    liftIO $ showPass dflags "Parser"
-    {-# SCC "Parser" #-} do
-
     -- sometimes we already have the buffer in memory, perhaps
     -- because we needed to parse the imports out of it, or get the
     -- module name.
@@ -1252,7 +1252,8 @@ hscGenHardCode hsc_env cgguts mod_summary output_filename = do
         -- PREPARE FOR CODE GENERATION
         -- Do saturation and convert to A-normal form
         prepd_binds <- {-# SCC "CorePrep" #-}
-                       corePrepPgm hsc_env location core_binds data_tycons ;
+                       corePrepPgm hsc_env this_mod location
+                                   core_binds data_tycons
         -----------------  Convert to STG ------------------
         (stg_binds, cost_centre_info)
             <- {-# SCC "CoreToStg" #-}
@@ -1268,27 +1269,28 @@ hscGenHardCode hsc_env cgguts mod_summary output_filename = do
         -- top-level function, so showPass isn't very useful here.
         -- Hence we have one showPass for the whole backend, the
         -- next showPass after this will be "Assembler".
-        showPass dflags "CodeGen"
-
-        cmms <- {-# SCC "StgCmm" #-}
-                         doCodeGen hsc_env this_mod data_tycons
-                             cost_centre_info
-                             stg_binds hpc_info
-
-        ------------------  Code output -----------------------
-        rawcmms0 <- {-# SCC "cmmToRawCmm" #-}
-                   cmmToRawCmm dflags cmms
-
-        let dump a = do dumpIfSet_dyn dflags Opt_D_dump_cmm_raw "Raw Cmm"
-                           (ppr a)
-                        return a
-            rawcmms1 = Stream.mapM dump rawcmms0
-
-        (output_filename, (_stub_h_exists, stub_c_exists))
-            <- {-# SCC "codeOutput" #-}
-               codeOutput dflags this_mod output_filename location
-               foreign_stubs dependencies rawcmms1
-        return (output_filename, stub_c_exists)
+        withTiming (pure dflags)
+                   (text "CodeGen"<+>brackets (ppr this_mod))
+                   (const ()) $ do
+            cmms <- {-# SCC "StgCmm" #-}
+                            doCodeGen hsc_env this_mod data_tycons
+                                cost_centre_info
+                                stg_binds hpc_info
+
+            ------------------  Code output -----------------------
+            rawcmms0 <- {-# SCC "cmmToRawCmm" #-}
+                      cmmToRawCmm dflags cmms
+
+            let dump a = do dumpIfSet_dyn dflags Opt_D_dump_cmm_raw "Raw Cmm"
+                              (ppr a)
+                            return a
+                rawcmms1 = Stream.mapM dump rawcmms0
+
+            (output_filename, (_stub_h_exists, stub_c_exists))
+                <- {-# SCC "codeOutput" #-}
+                  codeOutput dflags this_mod output_filename location
+                  foreign_stubs dependencies rawcmms1
+            return (output_filename, stub_c_exists)
 
 
 hscInteractive :: HscEnv
@@ -1315,7 +1317,7 @@ hscInteractive hsc_env cgguts mod_summary = do
     -- PREPARE FOR CODE GENERATION
     -- Do saturation and convert to A-normal form
     prepd_binds <- {-# SCC "CorePrep" #-}
-                   corePrepPgm hsc_env location core_binds data_tycons
+                   corePrepPgm hsc_env this_mod location core_binds data_tycons
     -----------------  Generate byte code ------------------
     comp_bc <- byteCodeGen hsc_env this_mod prepd_binds data_tycons mod_breaks
     ------------------ Create f-x-dynamic C-side stuff ---
@@ -1549,7 +1551,7 @@ hscDeclsWithLocation hsc_env0 str source linenumber =
     {- Prepare For Code Generation -}
     -- Do saturation and convert to A-normal form
     prepd_binds <- {-# SCC "CorePrep" #-}
-      liftIO $ corePrepPgm hsc_env iNTERACTIVELoc core_binds data_tycons
+      liftIO $ corePrepPgm hsc_env this_mod iNTERACTIVELoc core_binds data_tycons
 
     {- Generate byte code -}
     cbc <- liftIO $ byteCodeGen hsc_env this_mod
@@ -1659,9 +1661,10 @@ hscParseThing = hscParseThingWithLocation "<interactive>" 1
 hscParseThingWithLocation :: (Outputable thing) => String -> Int
                           -> Lexer.P thing -> String -> Hsc thing
 hscParseThingWithLocation source linenumber parser str
-  = {-# SCC "Parser" #-} do
+  = withTiming getDynFlags
+               (text "Parser [source]")
+               (const ()) $ {-# SCC "Parser" #-} do
     dflags <- getDynFlags
-    liftIO $ showPass dflags "Parser"
 
     let buf = stringToStringBuffer str
         loc = mkRealSrcLoc (fsLit source) linenumber 1
diff --git a/compiler/main/TidyPgm.hs b/compiler/main/TidyPgm.hs
index 5bbbdb51f6..3a3a9161f3 100644
--- a/compiler/main/TidyPgm.hs
+++ b/compiler/main/TidyPgm.hs
@@ -137,12 +137,15 @@ mkBootModDetailsTc hsc_env
                   tcg_tcs       = tcs,
                   tcg_patsyns   = pat_syns,
                   tcg_insts     = insts,
-                  tcg_fam_insts = fam_insts
+                  tcg_fam_insts = fam_insts,
+                  tcg_mod       = this_mod
                 }
-  = do  { let dflags = hsc_dflags hsc_env
-        ; showPassIO dflags CoreTidy
-
-        ; let { insts'     = map (tidyClsInstDFun globaliseAndTidyId) insts
+  = -- This timing isn't terribly useful since the result isn't forced, but
+    -- the message is useful to locating oneself in the compilation process.
+    Err.withTiming (pure dflags)
+                   (text "CoreTidy"<+>brackets (ppr this_mod))
+                   (const ()) $
+    do  { let { insts'     = map (tidyClsInstDFun globaliseAndTidyId) insts
               ; pat_syns'  = map (tidyPatSynIds   globaliseAndTidyId) pat_syns
               ; type_env1  = mkBootTypeEnv (availsToNameSet exports)
                                            (typeEnvIds type_env) tcs fam_insts
@@ -160,6 +163,7 @@ mkBootModDetailsTc hsc_env
                              })
         }
   where
+    dflags = hsc_dflags hsc_env
 
 mkBootTypeEnv :: NameSet -> [Id] -> [TyCon] -> [FamInst] -> TypeEnv
 mkBootTypeEnv exports ids tcs fam_insts
@@ -315,12 +319,13 @@ tidyProgram hsc_env  (ModGuts { mg_module    = mod
                               , mg_modBreaks = modBreaks
                               })
 
-  = do  { let { dflags     = hsc_dflags hsc_env
-              ; omit_prags = gopt Opt_OmitInterfacePragmas dflags
+  = Err.withTiming (pure dflags)
+                   (text "CoreTidy"<+>brackets (ppr mod))
+                   (const ()) $
+    do  { let { omit_prags = gopt Opt_OmitInterfacePragmas dflags
               ; expose_all = gopt Opt_ExposeAllUnfoldings  dflags
               ; print_unqual = mkPrintUnqualified dflags rdr_env
               }
-        ; showPassIO dflags CoreTidy
 
         ; let { type_env = typeEnvFromEntities [] tcs fam_insts
 
@@ -414,6 +419,8 @@ tidyProgram hsc_env  (ModGuts { mg_module    = mod
                                 md_anns      = anns      -- are already tidy
                               })
         }
+  where
+    dflags = hsc_dflags hsc_env
 
 lookup_aux_id :: TypeEnv -> Var -> Id
 lookup_aux_id type_env id
diff --git a/compiler/simplCore/SimplCore.hs b/compiler/simplCore/SimplCore.hs
index 1e7020e4d0..98bcf2ad91 100644
--- a/compiler/simplCore/SimplCore.hs
+++ b/compiler/simplCore/SimplCore.hs
@@ -21,7 +21,7 @@ import OccurAnal        ( occurAnalysePgm, occurAnalyseExpr )
 import IdInfo
 import CoreStats        ( coreBindsSize, coreBindsStats, exprSize )
 import CoreUtils        ( mkTicks, stripTicksTop )
-import CoreLint         ( showPass, endPass, lintPassResult, dumpPassResult,
+import CoreLint         ( endPass, lintPassResult, dumpPassResult,
                           lintAnnots )
 import Simplify         ( simplTopBinds, simplExpr, simplRules )
 import SimplUtils       ( simplEnvForGHCi, activeRule )
@@ -33,6 +33,7 @@ import FloatIn          ( floatInwards )
 import FloatOut         ( floatOutwards )
 import FamInstEnv
 import Id
+import ErrUtils         ( withTiming )
 import BasicTypes       ( CompilerPhase(..), isDefaultInlinePragma )
 import VarSet
 import VarEnv
@@ -357,11 +358,15 @@ runCorePasses passes guts
     do_pass guts CoreDoNothing = return guts
     do_pass guts (CoreDoPasses ps) = runCorePasses ps guts
     do_pass guts pass
-       = do { showPass pass
-            ; guts' <- lintAnnots (ppr pass) (doCorePass pass) guts
+       = withTiming getDynFlags
+                    (ppr pass <+> brackets (ppr mod))
+                    (const ()) $ do
+            { guts' <- lintAnnots (ppr pass) (doCorePass pass) guts
             ; endPass pass (mg_binds guts') (mg_rules guts')
             ; return guts' }
 
+    mod = mg_module guts
+
 doCorePass :: CoreToDo -> ModGuts -> CoreM ModGuts
 doCorePass pass@(CoreDoSimplify {})  = {-# SCC "Simplify" #-}
                                        simplifyPgm pass
@@ -423,17 +428,18 @@ printCore dflags binds
     = Err.dumpIfSet dflags True "Print Core" (pprCoreBindings binds)
 
 ruleCheckPass :: CompilerPhase -> String -> ModGuts -> CoreM ModGuts
-ruleCheckPass current_phase pat guts = do
-    rb <- getRuleBase
-    dflags <- getDynFlags
-    vis_orphs <- getVisibleOrphanMods
-    liftIO $ Err.showPass dflags "RuleCheck"
-    liftIO $ log_action dflags dflags NoReason Err.SevDump noSrcSpan
-                 defaultDumpStyle
-                 (ruleCheckProgram current_phase pat
-                    (RuleEnv rb vis_orphs) (mg_binds guts))
-    return guts
-
+ruleCheckPass current_phase pat guts =
+    withTiming getDynFlags
+               (text "RuleCheck"<+>brackets (ppr $ mg_module guts))
+               (const ()) $ do
+    { rb <- getRuleBase
+    ; dflags <- getDynFlags
+    ; vis_orphs <- getVisibleOrphanMods
+    ; liftIO $ log_action dflags dflags NoReason Err.SevDump noSrcSpan
+                   defaultDumpStyle
+                   (ruleCheckProgram current_phase pat
+                      (RuleEnv rb vis_orphs) (mg_binds guts))
+    ; return guts }
 
 doPassDUM :: (DynFlags -> UniqSupply -> CoreProgram -> IO CoreProgram) -> ModGuts -> CoreM ModGuts
 doPassDUM do_pass = doPassM $ \binds -> do
@@ -501,9 +507,8 @@ simplifyExpr :: DynFlags -- includes spec of what core-to-core passes to do
 --
 -- Also used by Template Haskell
 simplifyExpr dflags expr
-  = do  {
-        ; Err.showPass dflags "Simplify"
-
+  = withTiming (pure dflags) (text "Simplify [expr]") (const ()) $
+    do  {
         ; us <-  mkSplitUniqSupply 's'
 
         ; let sz = exprSize expr
diff --git a/compiler/typecheck/TcRnDriver.hs b/compiler/typecheck/TcRnDriver.hs
index 93da03f754..550f84fe7d 100644
--- a/compiler/typecheck/TcRnDriver.hs
+++ b/compiler/typecheck/TcRnDriver.hs
@@ -131,16 +131,18 @@ tcRnModule :: HscEnv
 tcRnModule hsc_env hsc_src save_rn_syntax
    parsedModule@HsParsedModule {hpm_module=L loc this_module}
  | RealSrcSpan real_loc <- loc
- = do { showPass (hsc_dflags hsc_env) "Renamer/typechecker" ;
-
-      ; initTc hsc_env hsc_src save_rn_syntax this_mod real_loc $
-               withTcPlugins hsc_env $
-               tcRnModuleTcRnM hsc_env hsc_src parsedModule pair }
+ = withTiming (pure dflags)
+              (text "Renamer/typechecker"<+>brackets (ppr this_mod))
+              (const ()) $
+   initTc hsc_env hsc_src save_rn_syntax this_mod real_loc $
+          withTcPlugins hsc_env $
+          tcRnModuleTcRnM hsc_env hsc_src parsedModule pair
 
   | otherwise
   = return ((emptyBag, unitBag err_msg), Nothing)
 
   where
+    dflags = hsc_dflags hsc_env
     err_msg = mkPlainErrMsg (hsc_dflags hsc_env) loc $
               text "Module does not have a RealSrcSpan:" <+> ppr this_mod
 
diff --git a/compiler/utils/Outputable.hs b/compiler/utils/Outputable.hs
index 259b554c23..64b3542706 100644
--- a/compiler/utils/Outputable.hs
+++ b/compiler/utils/Outputable.hs
@@ -22,7 +22,7 @@ module Outputable (
         empty, isEmpty, nest,
         char,
         text, ftext, ptext, ztext,
-        int, intWithCommas, integer, float, double, rational,
+        int, intWithCommas, integer, float, double, rational, doublePrec,
         parens, cparen, brackets, braces, quotes, quote,
         doubleQuotes, angleBrackets, paBrackets,
         semi, comma, colon, dcolon, space, equals, dot, vbar,
@@ -111,6 +111,7 @@ import Data.Word
 import System.IO        ( Handle )
 import System.FilePath
 import Text.Printf
+import Numeric (showFFloat)
 import Data.Graph (SCC(..))
 
 import GHC.Fingerprint
@@ -508,6 +509,11 @@ float n     = docToSDoc $ Pretty.float n
 double n    = docToSDoc $ Pretty.double n
 rational n  = docToSDoc $ Pretty.rational n
 
+-- | @doublePrec p n@ shows a floating point number @n@ with @p@
+-- digits of precision after the decimal point.
+doublePrec :: Int -> Double -> SDoc
+doublePrec p n = text (showFFloat (Just p) n "")
+
 parens, braces, brackets, quotes, quote,
         paBrackets, doubleQuotes, angleBrackets :: SDoc -> SDoc
 
diff --git a/docs/users_guide/debugging.rst b/docs/users_guide/debugging.rst
index f3d2009ad1..a865f0afb2 100644
--- a/docs/users_guide/debugging.rst
+++ b/docs/users_guide/debugging.rst
@@ -201,7 +201,15 @@ Dumping out compiler intermediate structures
 
 .. ghc-flag:: -dshow-passes
 
-    Print out each pass name as it happens.
+    Print out each pass name, its runtime and heap allocations as it happens.
+    Note that this may come at a slight performance cost as the compiler will
+    be a bit more eager in forcing pass results to more accurately account for
+    their costs.
+
+    Two types of messages are produced: Those beginning with ``***`` are
+    denote the beginning of a compilation phase whereas those starting with
+    ``!!!`` mark the end of a pass and are accompanied by allocation and
+    runtime statistics.
 
 .. ghc-flag:: -ddump-core-stats
 
diff --git a/docs/users_guide/using.rst b/docs/users_guide/using.rst
index ba0e223847..bcd641fb28 100644
--- a/docs/users_guide/using.rst
+++ b/docs/users_guide/using.rst
@@ -593,11 +593,11 @@ See also the ``--help``, ``--version``, ``--numeric-version``, and
 
     ``-v1``
         Minimal verbosity: print one line per compilation (this is the
-        default when ``--make`` or ``--interactive`` is on).
+        default when :ghc-flag:`--make` or :ghc-flag:`--interactive` is on).
 
     ``-v2``
         Print the name of each compilation phase as it is executed.
-        (equivalent to ``-dshow-passes``).
+        (equivalent to :ghc-flag:`-dshow-passes`).
 
     ``-v3``
         The same as ``-v2``, except that in addition the full command