Make dynflag argument for withTiming pure.

19 times out of 20 we already have dynflags in scope.

We could just always use `return dflags`. But this is in fact not free.
When looking at some STG code I noticed that we always allocate a
closure for this expression in the heap. Clearly a waste in these cases.

For the other cases we can either just modify the callsite to
get dynflags or use the _D variants of withTiming I added which
will use getDynFlags under the hood.

22 files changed, 93 insertions, 71 deletions

diff --git a/compiler/GHC/StgToCmm.hs b/compiler/GHC/StgToCmm.hs
index 96fa9e5cc1..f02d361fa4 100644
--- a/compiler/GHC/StgToCmm.hs
+++ b/compiler/GHC/StgToCmm.hs
@@ -71,7 +71,7 @@ codeGen dflags this_mod data_tycons
         ; cgref <- liftIO $ newIORef =<< initC
         ; let cg :: FCode () -> Stream IO CmmGroup ()
               cg fcode = do
-                cmm <- liftIO . withTimingSilent (return dflags) (text "STG -> Cmm") (`seq` ()) $ do
+                cmm <- liftIO . withTimingSilent dflags (text "STG -> Cmm") (`seq` ()) $ do
                          st <- readIORef cgref
                          let (a,st') = runC dflags this_mod st (getCmm fcode)
 
diff --git a/compiler/cmm/CmmInfo.hs b/compiler/cmm/CmmInfo.hs
index 82abbb62bd..3ef3d5001e 100644
--- a/compiler/cmm/CmmInfo.hs
+++ b/compiler/cmm/CmmInfo.hs
@@ -74,7 +74,7 @@ cmmToRawCmm dflags cmms
        ; let do_one :: UniqSupply -> [CmmDecl] -> IO (UniqSupply, [RawCmmDecl])
              do_one uniqs cmm =
                -- NB. strictness fixes a space leak.  DO NOT REMOVE.
-               withTimingSilent (return dflags) (text "Cmm -> Raw Cmm")
+               withTimingSilent dflags (text "Cmm -> Raw Cmm")
                                 forceRes $
                  case initUs uniqs $ concatMapM (mkInfoTable dflags) cmm of
                    (b,uniqs') -> return (uniqs',b)
diff --git a/compiler/cmm/CmmParse.y b/compiler/cmm/CmmParse.y
index 319286ba5a..3cfb7ecee2 100644
--- a/compiler/cmm/CmmParse.y
+++ b/compiler/cmm/CmmParse.y
@@ -375,8 +375,8 @@ cmm     :: { CmmParse () }
 cmmtop  :: { CmmParse () }
         : cmmproc                       { $1 }
         | cmmdata                       { $1 }
-        | decl                          { $1 } 
-        | 'CLOSURE' '(' NAME ',' NAME lits ')' ';'  
+        | decl                          { $1 }
+        | 'CLOSURE' '(' NAME ',' NAME lits ')' ';'
                 {% liftP . withThisPackage $ \pkg ->
                    do lits <- sequence $6;
                       staticClosure pkg $3 $5 (map getLit lits) }
@@ -391,30 +391,30 @@ cmmtop  :: { CmmParse () }
 --      * we can derive closure and info table labels from a single NAME
 
 cmmdata :: { CmmParse () }
-        : 'section' STRING '{' data_label statics '}' 
+        : 'section' STRING '{' data_label statics '}'
                 { do lbl <- $4;
                      ss <- sequence $5;
                      code (emitDecl (CmmData (Section (section $2) lbl) (Statics lbl $ concat ss))) }
 
 data_label :: { CmmParse CLabel }
-    : NAME ':'  
+    : NAME ':'
                 {% liftP . withThisPackage $ \pkg ->
                    return (mkCmmDataLabel pkg $1) }
 
 statics :: { [CmmParse [CmmStatic]] }
         : {- empty -}                   { [] }
         | static statics                { $1 : $2 }
-    
+
 static  :: { CmmParse [CmmStatic] }
         : type expr ';' { do e <- $2;
                              return [CmmStaticLit (getLit e)] }
         | type ';'                      { return [CmmUninitialised
                                                         (widthInBytes (typeWidth $1))] }
         | 'bits8' '[' ']' STRING ';'    { return [mkString $4] }
-        | 'bits8' '[' INT ']' ';'       { return [CmmUninitialised 
+        | 'bits8' '[' INT ']' ';'       { return [CmmUninitialised
                                                         (fromIntegral $3)] }
-        | typenot8 '[' INT ']' ';'      { return [CmmUninitialised 
-                                                (widthInBytes (typeWidth $1) * 
+        | typenot8 '[' INT ']' ';'      { return [CmmUninitialised
+                                                (widthInBytes (typeWidth $1) *
                                                         fromIntegral $3)] }
         | 'CLOSURE' '(' NAME lits ')'
                 { do { lits <- sequence $4
@@ -475,7 +475,7 @@ info    :: { CmmParse (CLabel, Maybe CmmInfoTable, [LocalReg]) }
                                            , cit_rep = rep
                                            , cit_prof = prof, cit_srt = Nothing, cit_clo = Nothing },
                               []) }
-        
+
         | 'INFO_TABLE_FUN' '(' NAME ',' INT ',' INT ',' INT ',' STRING ',' STRING ',' INT ')'
                 -- ptrs, nptrs, closure type, description, type, fun type
                 {% liftP . withThisPackage $ \pkg ->
@@ -512,7 +512,7 @@ info    :: { CmmParse (CLabel, Maybe CmmInfoTable, [LocalReg]) }
 
                      -- If profiling is on, this string gets duplicated,
                      -- but that's the way the old code did it we can fix it some other time.
-        
+
         | 'INFO_TABLE_SELECTOR' '(' NAME ',' INT ',' INT ',' STRING ',' STRING ')'
                 -- selector, closure type, description, type
                 {% liftP . withThisPackage $ \pkg ->
@@ -575,7 +575,7 @@ importName
 
         -- A label imported without an explicit packageId.
         --      These are taken to come frome some foreign, unnamed package.
-        : NAME  
+        : NAME
         { ($1, mkForeignLabel $1 Nothing ForeignLabelInExternalPackage IsFunction) }
 
         -- as previous 'NAME', but 'IsData'
@@ -585,8 +585,8 @@ importName
         -- A label imported with an explicit packageId.
         | STRING NAME
         { ($2, mkCmmCodeLabel (fsToUnitId (mkFastString $1)) $2) }
-        
-        
+
+
 names   :: { [FastString] }
         : NAME                          { [$1] }
         | NAME ',' names                { $1 : $3 }
@@ -672,9 +672,9 @@ bool_expr :: { CmmParse BoolExpr }
         | expr                          { do e <- $1; return (BoolTest e) }
 
 bool_op :: { CmmParse BoolExpr }
-        : bool_expr '&&' bool_expr      { do e1 <- $1; e2 <- $3; 
+        : bool_expr '&&' bool_expr      { do e1 <- $1; e2 <- $3;
                                           return (BoolAnd e1 e2) }
-        | bool_expr '||' bool_expr      { do e1 <- $1; e2 <- $3; 
+        | bool_expr '||' bool_expr      { do e1 <- $1; e2 <- $3;
                                           return (BoolOr e1 e2)  }
         | '!' bool_expr                 { do e <- $2; return (BoolNot e) }
         | '(' bool_op ')'               { $2 }
@@ -760,7 +760,7 @@ expr    :: { CmmParse CmmExpr }
 expr0   :: { CmmParse CmmExpr }
         : INT   maybe_ty         { return (CmmLit (CmmInt $1 (typeWidth $2))) }
         | FLOAT maybe_ty         { return (CmmLit (CmmFloat $1 (typeWidth $2))) }
-        | STRING                 { do s <- code (newStringCLit $1); 
+        | STRING                 { do s <- code (newStringCLit $1);
                                       return (CmmLit s) }
         | reg                    { $1 }
         | type '[' expr ']'      { do e <- $3; return (CmmLoad e $1) }
@@ -818,14 +818,14 @@ foreign_formal :: { CmmParse (LocalReg, ForeignHint) }
 local_lreg :: { CmmParse LocalReg }
         : NAME                  { do e <- lookupName $1;
                                      return $
-                                       case e of 
+                                       case e of
                                         CmmReg (CmmLocal r) -> r
                                         other -> pprPanic "CmmParse:" (ftext $1 <> text " not a local register") }
 
 lreg    :: { CmmParse CmmReg }
         : NAME                  { do e <- lookupName $1;
                                      return $
-                                       case e of 
+                                       case e of
                                         CmmReg r -> r
                                         other -> pprPanic "CmmParse:" (ftext $1 <> text " not a register") }
         | GLOBALREG             { return (CmmGlobal $1) }
@@ -1376,7 +1376,7 @@ doSwitch :: Maybe (Integer,Integer)
 doSwitch mb_range scrut arms deflt
    = do
         -- Compile code for the default branch
-        dflt_entry <- 
+        dflt_entry <-
                 case deflt of
                   Nothing -> return Nothing
                   Just e  -> do b <- forkLabelledCode e; return (Just b)
@@ -1419,7 +1419,7 @@ initEnv dflags = listToUFM [
   ]
 
 parseCmmFile :: DynFlags -> FilePath -> IO (Messages, Maybe CmmGroup)
-parseCmmFile dflags filename = withTiming (pure dflags) (text "ParseCmm"<+>brackets (text filename)) (\_ -> ()) $ do
+parseCmmFile dflags filename = withTiming dflags (text "ParseCmm"<+>brackets (text filename)) (\_ -> ()) $ do
   buf <- hGetStringBuffer filename
   let
         init_loc = mkRealSrcLoc (mkFastString filename) 1 1
diff --git a/compiler/cmm/CmmPipeline.hs b/compiler/cmm/CmmPipeline.hs
index 5ac3fddb3b..071ec9442e 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 = withTimingSilent (return dflags) (text "Cmm pipeline") forceRes $
+cmmPipeline hsc_env srtInfo prog = withTimingSilent dflags (text "Cmm pipeline") forceRes $
   do let dflags = hsc_dflags hsc_env
 
      tops <- {-# SCC "tops" #-} mapM (cpsTop hsc_env) prog
diff --git a/compiler/coreSyn/CorePrep.hs b/compiler/coreSyn/CorePrep.hs
index 9d4044cf57..2b68c2716b 100644
--- a/compiler/coreSyn/CorePrep.hs
+++ b/compiler/coreSyn/CorePrep.hs
@@ -178,7 +178,7 @@ type CpeRhs  = CoreExpr    -- Non-terminal 'rhs'
 corePrepPgm :: HscEnv -> Module -> ModLocation -> CoreProgram -> [TyCon]
             -> IO (CoreProgram, S.Set CostCentre)
 corePrepPgm hsc_env this_mod mod_loc binds data_tycons =
-    withTiming (pure dflags)
+    withTiming dflags
                (text "CorePrep"<+>brackets (ppr this_mod))
                (const ()) $ do
     us <- mkSplitUniqSupply 's'
@@ -206,7 +206,7 @@ corePrepPgm hsc_env this_mod mod_loc binds data_tycons =
 
 corePrepExpr :: DynFlags -> HscEnv -> CoreExpr -> IO CoreExpr
 corePrepExpr dflags hsc_env expr =
-    withTiming (pure dflags) (text "CorePrep [expr]") (const ()) $ do
+    withTiming 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 5df52c3df9..5ecc4da00e 100644
--- a/compiler/deSugar/Desugar.hs
+++ b/compiler/deSugar/Desugar.hs
@@ -114,7 +114,7 @@ deSugar hsc_env
 
   = do { let dflags = hsc_dflags hsc_env
              print_unqual = mkPrintUnqualified dflags rdr_env
-        ; withTiming (pure dflags)
+        ; withTiming dflags
                      (text "Desugar"<+>brackets (ppr mod))
                      (const ()) $
      do { -- Desugar the program
diff --git a/compiler/ghci/ByteCodeGen.hs b/compiler/ghci/ByteCodeGen.hs
index 2ad089903b..b7b0d95217 100644
--- a/compiler/ghci/ByteCodeGen.hs
+++ b/compiler/ghci/ByteCodeGen.hs
@@ -86,7 +86,7 @@ byteCodeGen :: HscEnv
             -> Maybe ModBreaks
             -> IO CompiledByteCode
 byteCodeGen hsc_env this_mod binds tycs mb_modBreaks
-   = withTiming (pure dflags)
+   = withTiming dflags
                 (text "ByteCodeGen"<+>brackets (ppr this_mod))
                 (const ()) $ do
         -- Split top-level binds into strings and others.
@@ -158,7 +158,7 @@ coreExprToBCOs :: HscEnv
                -> CoreExpr
                -> IO UnlinkedBCO
 coreExprToBCOs hsc_env this_mod expr
- = withTiming (pure dflags)
+ = withTiming dflags
               (text "ByteCodeGen"<+>brackets (ppr this_mod))
               (const ()) $ do
       -- create a totally bogus name for the top-level BCO; this
diff --git a/compiler/iface/LoadIface.hs b/compiler/iface/LoadIface.hs
index 446477d018..6da6565219 100644
--- a/compiler/iface/LoadIface.hs
+++ b/compiler/iface/LoadIface.hs
@@ -400,7 +400,7 @@ loadInterface doc_str mod from
        -- Redo search for our local hole module
        loadInterface doc_str (mkModule (thisPackage dflags) (moduleName mod)) from
   | otherwise
-  = withTimingSilent getDynFlags (text "loading interface") (pure ()) $
+  = withTimingSilentD (text "loading interface") (pure ()) $
     do  {       -- Read the state
           (eps,hpt) <- getEpsAndHpt
         ; gbl_env <- getGblEnv
diff --git a/compiler/llvmGen/LlvmCodeGen.hs b/compiler/llvmGen/LlvmCodeGen.hs
index b566b99a1f..49b24e8885 100644
--- a/compiler/llvmGen/LlvmCodeGen.hs
+++ b/compiler/llvmGen/LlvmCodeGen.hs
@@ -45,7 +45,7 @@ llvmCodeGen :: DynFlags -> Handle -> UniqSupply
                -> Stream.Stream IO RawCmmGroup a
                -> IO a
 llvmCodeGen dflags h us cmm_stream
-  = withTiming (pure dflags) (text "LLVM CodeGen") (const ()) $ do
+  = withTiming dflags (text "LLVM CodeGen") (const ()) $ do
        bufh <- newBufHandle h
 
        -- Pass header
diff --git a/compiler/llvmGen/LlvmMangler.hs b/compiler/llvmGen/LlvmMangler.hs
index 114951946c..8215781860 100644
--- a/compiler/llvmGen/LlvmMangler.hs
+++ b/compiler/llvmGen/LlvmMangler.hs
@@ -25,7 +25,7 @@ import System.IO
 -- | Read in assembly file and process
 llvmFixupAsm :: DynFlags -> FilePath -> FilePath -> IO ()
 llvmFixupAsm dflags f1 f2 = {-# SCC "llvm_mangler" #-}
-    withTiming (pure dflags) (text "LLVM Mangler") id $
+    withTiming 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 96a754d6f0..01d714d57a 100644
--- a/compiler/main/CodeOutput.hs
+++ b/compiler/main/CodeOutput.hs
@@ -71,7 +71,7 @@ codeOutput dflags this_mod filenm location foreign_stubs foreign_fps pkg_deps
                     else cmm_stream
 
               do_lint cmm = withTimingSilent
-                  (pure dflags)
+                  dflags
                   (text "CmmLint"<+>brackets (ppr this_mod))
                   (const ()) $ do
                 { case cmmLint dflags cmm of
@@ -118,7 +118,7 @@ outputC :: DynFlags
 
 outputC dflags filenm cmm_stream packages
   = do
-       withTiming (return dflags) (text "C codegen") (\a -> seq a () {- FIXME -}) $ do
+       withTiming dflags (text "C codegen") (\a -> seq a () {- FIXME -}) $ do
 
          -- figure out which header files to #include in the generated .hc file:
          --
diff --git a/compiler/main/ErrUtils.hs b/compiler/main/ErrUtils.hs
index ba94ec0c50..f0fa1441f9 100644
--- a/compiler/main/ErrUtils.hs
+++ b/compiler/main/ErrUtils.hs
@@ -50,7 +50,8 @@ module ErrUtils (
         errorMsg, warningMsg,
         fatalErrorMsg, fatalErrorMsg'',
         compilationProgressMsg,
-        showPass, withTiming, withTimingSilent,
+        showPass,
+        withTiming, withTimingSilent, withTimingD, withTimingSilentD,
         debugTraceMsg,
         ghcExit,
         prettyPrintGhcErrors,
@@ -647,15 +648,25 @@ data PrintTimings = PrintTimings | DontPrintTimings
 --
 -- See Note [withTiming] for more.
 withTiming :: MonadIO m
-           => m DynFlags   -- ^ A means of getting a 'DynFlags' (often
-                           -- 'getDynFlags' will work here)
+           => DynFlags     -- ^ DynFlags
            -> 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 action =
-  withTiming' getDFlags what force PrintTimings action
+withTiming dflags what force action =
+  withTiming' dflags what force PrintTimings action
+
+-- | Like withTiming but get DynFlags from the Monad.
+withTimingD :: (MonadIO m, HasDynFlags m)
+           => 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
+withTimingD what force action = do
+  dflags <- getDynFlags
+  withTiming' dflags what force PrintTimings action
 
 
 -- | Same as 'withTiming', but doesn't print timings in the
@@ -664,19 +675,34 @@ withTiming getDFlags what force action =
 --   See Note [withTiming] for more.
 withTimingSilent
   :: MonadIO m
-  => m DynFlags -- ^ A means of getting a 'DynFlags' (often
-                -- 'getDynFlags' will work here)
+  => DynFlags   -- ^ DynFlags
   -> 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
-withTimingSilent getDFlags what force action =
-  withTiming' getDFlags what force DontPrintTimings action
+withTimingSilent dflags what force action =
+  withTiming' dflags what force DontPrintTimings action
+
+-- | Same as 'withTiming', but doesn't print timings in the
+--   console (when given @-vN@, @N >= 2@ or @-ddump-timings@)
+--   and gets the DynFlags from the given Monad.
+--
+--   See Note [withTiming] for more.
+withTimingSilentD
+  :: (MonadIO m, HasDynFlags m)
+  => 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
+withTimingSilentD what force action = do
+  dflags <- getDynFlags
+  withTiming' dflags what force DontPrintTimings action
 
 -- | Worker for 'withTiming' and 'withTimingSilent'.
 withTiming' :: MonadIO m
-            => m DynFlags   -- ^ A means of getting a 'DynFlags' (often
+            => 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
@@ -684,9 +710,8 @@ withTiming' :: MonadIO m
             -> PrintTimings -- ^ Whether to print the timings
             -> m a          -- ^ The body of the phase to be timed
             -> m a
-withTiming' getDFlags what force_result prtimings action
-  = do dflags <- getDFlags
-       if verbosity dflags >= 2 || dopt Opt_D_dump_timings dflags
+withTiming' dflags what force_result prtimings action
+  = do if verbosity dflags >= 2 || dopt Opt_D_dump_timings dflags
           then do whenPrintTimings $
                     logInfo dflags (defaultUserStyle dflags) $
                       text "***" <+> what <> colon
diff --git a/compiler/main/GhcMake.hs b/compiler/main/GhcMake.hs
index f1fb933753..6599da07f4 100644
--- a/compiler/main/GhcMake.hs
+++ b/compiler/main/GhcMake.hs
@@ -154,7 +154,7 @@ depanalPartial excluded_mods allow_dup_roots = do
          targets = hsc_targets hsc_env
          old_graph = hsc_mod_graph hsc_env
 
-  withTiming (pure dflags) (text "Chasing dependencies") (const ()) $ do
+  withTiming dflags (text "Chasing dependencies") (const ()) $ do
     liftIO $ debugTraceMsg dflags 2 (hcat [
               text "Chasing modules from: ",
               hcat (punctuate comma (map pprTarget targets))])
diff --git a/compiler/main/HscMain.hs b/compiler/main/HscMain.hs
index b21609bbc5..8cbc394f33 100644
--- a/compiler/main/HscMain.hs
+++ b/compiler/main/HscMain.hs
@@ -331,9 +331,8 @@ hscParse' :: ModSummary -> Hsc HsParsedModule
 hscParse' mod_summary
  | Just r <- ms_parsed_mod mod_summary = return r
  | otherwise = {-# SCC "Parser" #-}
-    withTiming getDynFlags
-               (text "Parser"<+>brackets (ppr $ ms_mod mod_summary))
-               (const ()) $ do
+    withTimingD (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
@@ -1454,7 +1453,7 @@ 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".
-        withTiming (pure dflags)
+        withTiming dflags
                    (text "CodeGen"<+>brackets (ppr this_mod))
                    (const ()) $ do
             cmms <- {-# SCC "StgToCmm" #-}
@@ -1851,7 +1850,7 @@ hscParseThing = hscParseThingWithLocation "<interactive>" 1
 hscParseThingWithLocation :: (Outputable thing, Data thing) => String -> Int
                           -> Lexer.P thing -> String -> Hsc thing
 hscParseThingWithLocation source linenumber parser str
-  = withTiming getDynFlags
+  = withTimingD
                (text "Parser [source]")
                (const ()) $ {-# SCC "Parser" #-} do
     dflags <- getDynFlags
diff --git a/compiler/main/Packages.hs b/compiler/main/Packages.hs
index ccf42c588c..ca2e74dfcf 100644
--- a/compiler/main/Packages.hs
+++ b/compiler/main/Packages.hs
@@ -469,7 +469,7 @@ listPackageConfigMap dflags = eltsUDFM pkg_map
 -- 'pkgState' in 'DynFlags' and return a list of packages to
 -- link in.
 initPackages :: DynFlags -> IO (DynFlags, [PreloadUnitId])
-initPackages dflags0 = withTiming (return dflags0)
+initPackages dflags0 = withTiming dflags0
                                   (text "initializing package database")
                                   forcePkgDb $ do
   dflags <- interpretPackageEnv dflags0
diff --git a/compiler/main/SysTools/Tasks.hs b/compiler/main/SysTools/Tasks.hs
index 838ab64717..5b0cb1cfa2 100644
--- a/compiler/main/SysTools/Tasks.hs
+++ b/compiler/main/SysTools/Tasks.hs
@@ -371,4 +371,4 @@ touch dflags purpose arg = traceToolCommand dflags "touch" $
 --   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 ())
+  dflags (text $ "systool:" ++ tool) (const ())
diff --git a/compiler/main/TidyPgm.hs b/compiler/main/TidyPgm.hs
index c0c6ffc3c3..f0dbc6734b 100644
--- a/compiler/main/TidyPgm.hs
+++ b/compiler/main/TidyPgm.hs
@@ -145,7 +145,7 @@ mkBootModDetailsTc hsc_env
                 }
   = -- 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)
+    Err.withTiming dflags
                    (text "CoreTidy"<+>brackets (ppr this_mod))
                    (const ()) $
     return (ModDetails { md_types         = type_env'
@@ -341,7 +341,7 @@ tidyProgram hsc_env  (ModGuts { mg_module    = mod
                               , mg_modBreaks = modBreaks
                               })
 
-  = Err.withTiming (pure dflags)
+  = Err.withTiming dflags
                    (text "CoreTidy"<+>brackets (ppr mod))
                    (const ()) $
     do  { let { omit_prags = gopt Opt_OmitInterfacePragmas dflags
diff --git a/compiler/nativeGen/AsmCodeGen.hs b/compiler/nativeGen/AsmCodeGen.hs
index c21d3e52f6..7d830d0337 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
- = withTimingSilent (return dflags) (text "NCG") (`seq` ()) $ do
+ = withTimingSilent dflags (text "NCG") (`seq` ()) $ do
         -- Write debug data and finish
         let emitDw = debugLevel dflags > 0
         us' <- if not emitDw then return us else do
@@ -404,7 +404,7 @@ cmmNativeGenStream dflags this_mod modLoc ncgImpl h us cmm_stream ngs
         Right (cmms, cmm_stream') -> do
           (us', ngs'') <-
             withTimingSilent
-                (return dflags)
+                dflags
                 ncglabel (\(a, b) -> a `seq` b `seq` ()) $ do
               -- Generate debug information
               let debugFlag = debugLevel dflags > 0
diff --git a/compiler/simplCore/SimplCore.hs b/compiler/simplCore/SimplCore.hs
index b3af87b2af..cbfa757552 100644
--- a/compiler/simplCore/SimplCore.hs
+++ b/compiler/simplCore/SimplCore.hs
@@ -36,7 +36,7 @@ import FloatIn          ( floatInwards )
 import FloatOut         ( floatOutwards )
 import FamInstEnv
 import Id
-import ErrUtils         ( withTiming )
+import ErrUtils         ( withTiming, withTimingD )
 import BasicTypes       ( CompilerPhase(..), isDefaultInlinePragma, defaultInlinePragma )
 import VarSet
 import VarEnv
@@ -410,10 +410,9 @@ runCorePasses passes guts
   where
     do_pass guts CoreDoNothing = return guts
     do_pass guts (CoreDoPasses ps) = runCorePasses ps guts
-    do_pass guts pass
-       = withTiming getDynFlags
-                    (ppr pass <+> brackets (ppr mod))
-                    (const ()) $ do
+    do_pass guts pass = do
+       withTimingD (ppr pass <+> brackets (ppr mod))
+                   (const ()) $ do
             { guts' <- lintAnnots (ppr pass) (doCorePass pass) guts
             ; endPass pass (mg_binds guts') (mg_rules guts')
             ; return guts' }
@@ -484,9 +483,8 @@ printCore dflags binds
 
 ruleCheckPass :: CompilerPhase -> String -> ModGuts -> CoreM ModGuts
 ruleCheckPass current_phase pat guts =
-    withTiming getDynFlags
-               (text "RuleCheck"<+>brackets (ppr $ mg_module guts))
-               (const ()) $ do
+    withTimingD (text "RuleCheck"<+>brackets (ppr $ mg_module guts))
+                (const ()) $ do
     { rb <- getRuleBase
     ; dflags <- getDynFlags
     ; vis_orphs <- getVisibleOrphanMods
@@ -564,7 +562,7 @@ simplifyExpr :: DynFlags -- includes spec of what core-to-core passes to do
 --
 -- Also used by Template Haskell
 simplifyExpr dflags expr
-  = withTiming (pure dflags) (text "Simplify [expr]") (const ()) $
+  = withTiming dflags (text "Simplify [expr]") (const ()) $
     do  {
         ; us <-  mkSplitUniqSupply 's'
 
diff --git a/compiler/typecheck/TcBackpack.hs b/compiler/typecheck/TcBackpack.hs
index 17c9ac7e80..fccc373368 100644
--- a/compiler/typecheck/TcBackpack.hs
+++ b/compiler/typecheck/TcBackpack.hs
@@ -331,7 +331,7 @@ tcRnCheckUnitId ::
     HscEnv -> UnitId ->
     IO (Messages, Maybe ())
 tcRnCheckUnitId hsc_env uid =
-   withTiming (pure dflags)
+   withTiming dflags
               (text "Check unit id" <+> ppr uid)
               (const ()) $
    initTc hsc_env
@@ -351,7 +351,7 @@ tcRnCheckUnitId hsc_env uid =
 tcRnMergeSignatures :: HscEnv -> HsParsedModule -> TcGblEnv {- from local sig -} -> ModIface
                     -> IO (Messages, Maybe TcGblEnv)
 tcRnMergeSignatures hsc_env hpm orig_tcg_env iface =
-  withTiming (pure dflags)
+  withTiming dflags
              (text "Signature merging" <+> brackets (ppr this_mod))
              (const ()) $
   initTc hsc_env HsigFile False this_mod real_loc $
@@ -879,7 +879,7 @@ tcRnInstantiateSignature ::
     HscEnv -> Module -> RealSrcSpan ->
     IO (Messages, Maybe TcGblEnv)
 tcRnInstantiateSignature hsc_env this_mod real_loc =
-   withTiming (pure dflags)
+   withTiming dflags
               (text "Signature instantiation"<+>brackets (ppr this_mod))
               (const ()) $
    initTc hsc_env HsigFile False this_mod real_loc $ instantiateSignature
diff --git a/compiler/typecheck/TcRnDriver.hs b/compiler/typecheck/TcRnDriver.hs
index 000455bd3f..4d1d32f8a5 100644
--- a/compiler/typecheck/TcRnDriver.hs
+++ b/compiler/typecheck/TcRnDriver.hs
@@ -165,7 +165,7 @@ tcRnModule :: HscEnv
 tcRnModule hsc_env mod_sum save_rn_syntax
    parsedModule@HsParsedModule {hpm_module= (dL->L loc this_module)}
  | RealSrcSpan real_loc <- loc
- = withTiming (pure dflags)
+ = withTiming dflags
               (text "Renamer/typechecker"<+>brackets (ppr this_mod))
               (const ()) $
    initTc hsc_env hsc_src save_rn_syntax this_mod real_loc $
diff --git a/utils/haddock b/utils/haddock
-Subproject a7c42a29f7c33f5fdbb04acc3866ec907c2e00f
+Subproject f0b5a2043ff6c527e55fab228d37ee698ce8726