ErrUtils: Add timings to compiler phaseswip/ghc-7.10-with-timings

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

(cherry picked from commit 8048d51be0676627b417c128af0b0c352b75c537)

16 files changed, 189 insertions, 97 deletions

diff --git a/compiler/cmm/CmmParse.y b/compiler/cmm/CmmParse.y
index fd9489b..0b04052 100644
--- a/compiler/cmm/CmmParse.y
+++ b/compiler/cmm/CmmParse.y
@@ -1362,8 +1362,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 adac6b8..9fc0098 100644
--- a/compiler/coreSyn/CoreLint.hs
+++ b/compiler/coreSyn/CoreLint.hs
@@ -15,7 +15,7 @@ module CoreLint (
     lintAnnots,
 
     -- ** Debug output
-    CoreLint.showPass, showPassIO, endPass, endPassIO,
+    endPass, endPassIO,
     dumpPassResult,
     CoreLint.dumpIfSet,
  ) where
@@ -134,13 +134,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 924dfb4..88ed789 100644
--- a/compiler/coreSyn/CorePrep.hs
+++ b/compiler/coreSyn/CorePrep.hs
@@ -164,10 +164,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
 
@@ -182,10 +184,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 e4181b9..23785b4 100644
--- a/compiler/deSugar/Desugar.hs
+++ b/compiler/deSugar/Desugar.hs
@@ -96,9 +96,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
@@ -196,7 +197,7 @@ deSugar hsc_env
                 mg_dependent_files = dep_files
               }
         ; return (msgs, Just mod_guts)
-        }}}
+        }}}}
 
 dsImpSpecs :: [LTcSpecPrag] -> DsM (OrdList (Id,CoreExpr), [CoreRule])
 dsImpSpecs imp_specs
diff --git a/compiler/ghci/ByteCodeGen.hs b/compiler/ghci/ByteCodeGen.hs
index de5b84e..a2d1fc2 100644
--- a/compiler/ghci/ByteCodeGen.hs
+++ b/compiler/ghci/ByteCodeGen.hs
@@ -75,7 +75,9 @@ byteCodeGen :: DynFlags
             -> ModBreaks
             -> IO CompiledByteCode
 byteCodeGen dflags this_mod binds tycs modBreaks
-   = do showPass dflags "ByteCodeGen"
+   = withTiming (pure dflags)
+                (text "ByteCodeGen"<+>brackets (ppr this_mod))
+                (const ()) $ do
 
         let flatBinds = [ (bndr, freeVars rhs)
                         | (bndr, rhs) <- flattenBinds binds]
@@ -102,7 +104,9 @@ coreExprToBCOs :: DynFlags
                -> CoreExpr
                -> IO UnlinkedBCO
 coreExprToBCOs dflags this_mod expr
- = do 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
diff --git a/compiler/llvmGen/LlvmCodeGen.hs b/compiler/llvmGen/LlvmCodeGen.hs
index 6120a72..6dc468c 100644
--- a/compiler/llvmGen/LlvmCodeGen.hs
+++ b/compiler/llvmGen/LlvmCodeGen.hs
@@ -41,7 +41,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 8652a89..3f838b1 100644
--- a/compiler/llvmGen/LlvmMangler.hs
+++ b/compiler/llvmGen/LlvmMangler.hs
@@ -10,8 +10,9 @@
 module LlvmMangler ( llvmFixupAsm ) where
 
 import DynFlags ( DynFlags )
-import ErrUtils ( showPass )
+import ErrUtils ( withTiming )
 import LlvmCodeGen.Ppr ( infoSection )
+import Outputable ( text )
 
 import Control.Exception
 import Control.Monad ( when )
@@ -47,8 +48,8 @@ type Section = (B.ByteString, B.ByteString)
 
 -- | 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 $ do
     r <- openBinaryFile f1 ReadMode
     w <- openBinaryFile f2 WriteMode
     ss <- readSections r w
diff --git a/compiler/main/CodeOutput.hs b/compiler/main/CodeOutput.hs
index f55a15a..2e10b23 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 SevDump noSrcSpan defaultDumpStyle err
                                        ; ghcExit dflags 1
                                        }
diff --git a/compiler/main/ErrUtils.hs b/compiler/main/ErrUtils.hs
index 2a3b4c7..7d60140 100644
--- a/compiler/main/ErrUtils.hs
+++ b/compiler/main/ErrUtils.hs
@@ -5,6 +5,7 @@
 -}
 
 {-# LANGUAGE CPP #-}
+{-# LANGUAGE BangPatterns #-}
 
 module ErrUtils (
         MsgDoc,
@@ -32,7 +33,7 @@ module ErrUtils (
         errorMsg, warningMsg,
         fatalErrorMsg, fatalErrorMsg', fatalErrorMsg'',
         compilationProgressMsg,
-        showPass,
+        showPass, withTiming,
         debugTraceMsg,
 
         prettyPrintGhcErrors,
@@ -59,6 +60,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
@@ -396,6 +399,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 5f3e315..e48e506 100644
--- a/compiler/main/GhcMake.hs
+++ b/compiler/main/GhcMake.hs
@@ -112,15 +112,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 ecc4a29..7320658 100644
--- a/compiler/main/HscMain.hs
+++ b/compiler/main/HscMain.hs
@@ -318,15 +318,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.
@@ -1212,7 +1212,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" #-}
@@ -1228,27 +1229,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
@@ -1275,7 +1277,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 dflags this_mod prepd_binds data_tycons mod_breaks
     ------------------ Create f-x-dynamic C-side stuff ---
@@ -1501,7 +1503,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 dflags this_mod
@@ -1588,9 +1590,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 a616dde..54ad242 100644
--- a/compiler/main/TidyPgm.hs
+++ b/compiler/main/TidyPgm.hs
@@ -138,12 +138,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
               ; type_env1  = mkBootTypeEnv (availsToNameSet exports)
                                            (typeEnvIds type_env) tcs fam_insts
               ; pat_syns'  = map (tidyPatSynIds   globaliseAndTidyId) pat_syns
@@ -161,6 +164,7 @@ mkBootModDetailsTc hsc_env
                              })
         }
   where
+    dflags = hsc_dflags hsc_env
 
 mkBootTypeEnv :: NameSet -> [Id] -> [TyCon] -> [FamInst] -> TypeEnv
 mkBootTypeEnv exports ids tcs fam_insts
@@ -316,12 +320,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
 
@@ -415,6 +420,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 4789160..cd91a6f 100644
--- a/compiler/simplCore/SimplCore.hs
+++ b/compiler/simplCore/SimplCore.hs
@@ -21,7 +21,7 @@ import OccurAnal        ( occurAnalysePgm, occurAnalyseExpr )
 import IdInfo
 import CoreUtils        ( coreBindsSize, coreBindsStats, exprSize,
                           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
@@ -342,11 +343,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
@@ -408,14 +413,15 @@ 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
-    liftIO $ Err.showPass dflags "RuleCheck"
-    liftIO $ log_action dflags dflags Err.SevDump noSrcSpan defaultDumpStyle
+ruleCheckPass current_phase pat guts =
+    withTiming getDynFlags
+               (text "RuleCheck"<+>brackets (ppr $ mg_module guts))
+               (const ()) $ do
+    { rb <- getRuleBase
+    ; dflags <- getDynFlags
+    ; liftIO $ log_action dflags dflags Err.SevDump noSrcSpan defaultDumpStyle
                  (ruleCheckProgram current_phase pat rb (mg_binds guts))
-    return guts
-
+    ; return guts }
 
 doPassDUM :: (DynFlags -> UniqSupply -> CoreProgram -> IO CoreProgram) -> ModGuts -> CoreM ModGuts
 doPassDUM do_pass = doPassM $ \binds -> do
@@ -483,9 +489,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 fe319d0..01681b5 100644
--- a/compiler/typecheck/TcRnDriver.hs
+++ b/compiler/typecheck/TcRnDriver.hs
@@ -124,16 +124,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 e350de9..eb30010 100644
--- a/compiler/utils/Outputable.hs
+++ b/compiler/utils/Outputable.hs
@@ -20,7 +20,7 @@ module Outputable (
         empty, 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,
@@ -101,6 +101,7 @@ import Data.Word
 import System.IO        ( Handle )
 import System.FilePath
 import Text.Printf
+import Numeric (showFFloat)
 
 import GHC.Fingerprint
 import GHC.Show         ( showMultiLineString )
@@ -476,6 +477,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.xml b/docs/users_guide/debugging.xml
index aebb928..3d820d6 100644
--- a/docs/users_guide/debugging.xml
+++ b/docs/users_guide/debugging.xml
@@ -423,7 +423,15 @@
           <indexterm><primary><option>-dshow-passes</option></primary></indexterm>
         </term>
 	<listitem>
-	  <para>Print out each pass name as it happens.</para>
+         <para>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.</para>
 	</listitem>
       </varlistentry>