Avoid unnecessary allocations due to tracing utilitieswip/lower-tc-tracing-cost

While ticky-profiling the typechecker I noticed that hundreds of
millions of SDocs are being allocated just in case -ddump-*-trace is
enabled. This is awful.

We avoid this by ensuring that the dump flag check is inlined into the
call site, ensuring that the tracing document needn't be allocated
unless it's actually needed.

See Note [INLINE conditional tracing utilities] for details.

Fixes #18168.

Metric Decrease:
  T9961
  haddock.Cabal
  haddock.base
  haddock.compiler

7 files changed, 80 insertions, 22 deletions

diff --git a/compiler/GHC/Core/Opt/Simplify/Monad.hs b/compiler/GHC/Core/Opt/Simplify/Monad.hs
index b36d440402..d0096e1a7e 100644
--- a/compiler/GHC/Core/Opt/Simplify/Monad.hs
+++ b/compiler/GHC/Core/Opt/Simplify/Monad.hs
@@ -143,6 +143,7 @@ traceSmpl herald doc
        ; liftIO $ Err.dumpIfSet_dyn dflags Opt_D_dump_simpl_trace "Simpl Trace"
            FormatText
            (hang (text herald) 2 doc) }
+{-# INLINE traceSmpl #-}  -- see Note [INLINE conditional tracing utilities]
 
 {-
 ************************************************************************
diff --git a/compiler/GHC/Core/Unfold.hs b/compiler/GHC/Core/Unfold.hs
index 369f3282fd..bcba4b51ca 100644
--- a/compiler/GHC/Core/Unfold.hs
+++ b/compiler/GHC/Core/Unfold.hs
@@ -1279,7 +1279,10 @@ callSiteInline dflags id active_unfolding lone_variable arg_infos cont_info
 
 -- | Report the inlining of an identifier's RHS to the user, if requested.
 traceInline :: DynFlags -> Id -> String -> SDoc -> a -> a
-traceInline dflags inline_id str doc result =
+traceInline dflags inline_id str doc result
+  -- We take care to ensure that doc is used in only one branch, ensuring that
+  -- the simplifier can push its allocation into the branch. See Note [INLINE
+  -- conditional tracing utilities].
   | enable    = traceAction dflags str doc result
   | otherwise = result
   where
@@ -1288,6 +1291,9 @@ traceInline dflags inline_id str doc result =
       = True
       | Just prefix <- inlineCheck dflags
       = prefix `isPrefixOf` occNameString (getOccName inline_id)
+      | otherwise
+      = False
+{-# INLINE traceInline #-} -- see Note [INLINE conditional tracing utilities]
 
 tryUnfolding :: DynFlags -> Id -> Bool -> [ArgSummary] -> CallCtxt
              -> CoreExpr -> Bool -> Bool -> UnfoldingGuidance
diff --git a/compiler/GHC/HsToCore/PmCheck/Oracle.hs b/compiler/GHC/HsToCore/PmCheck/Oracle.hs
index 3a26dd5a7f..633bfea12d 100644
--- a/compiler/GHC/HsToCore/PmCheck/Oracle.hs
+++ b/compiler/GHC/HsToCore/PmCheck/Oracle.hs
@@ -89,6 +89,7 @@ tracePm herald doc = do
   printer <- mkPrintUnqualifiedDs
   liftIO $ dumpIfSet_dyn_printer printer dflags
             Opt_D_dump_ec_trace "" FormatText (text herald $$ (nest 2 doc))
+{-# INLINE tracePm #-}  -- see Note [INLINE conditional tracing utilities]
 
 -- | Generate a fresh `Id` of a given type
 mkPmId :: Type -> DsM Id
diff --git a/compiler/GHC/Tc/Solver/Flatten.hs b/compiler/GHC/Tc/Solver/Flatten.hs
index 4dff585840..ecfa9afa3a 100644
--- a/compiler/GHC/Tc/Solver/Flatten.hs
+++ b/compiler/GHC/Tc/Solver/Flatten.hs
@@ -543,6 +543,7 @@ runFlatten mode loc flav eq_rel thing_inside
 
 traceFlat :: String -> SDoc -> FlatM ()
 traceFlat herald doc = liftTcS $ traceTcS herald doc
+{-# INLINE traceFlat #-}  -- see Note [INLINE conditional tracing utilities]
 
 getFlatEnvField :: (FlattenEnv -> a) -> FlatM a
 getFlatEnvField accessor
diff --git a/compiler/GHC/Tc/Solver/Monad.hs b/compiler/GHC/Tc/Solver/Monad.hs
index f053868bdb..20f4d4ea07 100644
--- a/compiler/GHC/Tc/Solver/Monad.hs
+++ b/compiler/GHC/Tc/Solver/Monad.hs
@@ -2733,6 +2733,7 @@ panicTcS doc = pprPanic "GHC.Tc.Solver.Canonical" doc
 
 traceTcS :: String -> SDoc -> TcS ()
 traceTcS herald doc = wrapTcS (TcM.traceTc herald doc)
+{-# INLINE traceTcS #-}  -- see Note [INLINE conditional tracing utilities]
 
 runTcPluginTcS :: TcPluginM a -> TcS a
 runTcPluginTcS m = wrapTcS . runTcPluginM m =<< getTcEvBindsVar
@@ -2751,6 +2752,7 @@ bumpStepCountTcS = TcS $ \env -> do { let ref = tcs_count env
 csTraceTcS :: SDoc -> TcS ()
 csTraceTcS doc
   = wrapTcS $ csTraceTcM (return doc)
+{-# INLINE csTraceTcS #-}  -- see Note [INLINE conditional tracing utilities]
 
 traceFireTcS :: CtEvidence -> SDoc -> TcS ()
 -- Dump a rule-firing trace
@@ -2763,6 +2765,7 @@ traceFireTcS ev doc
                                     text "d:" <> ppr (ctLocDepth (ctEvLoc ev)))
                        <+> doc <> colon)
                      4 (ppr ev)) }
+{-# INLINE traceFireTcS #-}  -- see Note [INLINE conditional tracing utilities]
 
 csTraceTcM :: TcM SDoc -> TcM ()
 -- Constraint-solver tracing, -ddump-cs-trace
@@ -2775,6 +2778,7 @@ csTraceTcM mk_doc
                        (dumpOptionsFromFlag Opt_D_dump_cs_trace)
                        "" FormatText
                        msg }) }
+{-# INLINE csTraceTcM #-}  -- see Note [INLINE conditional tracing utilities]
 
 runTcS :: TcS a                -- What to run
        -> TcM (a, EvBindMap)
diff --git a/compiler/GHC/Tc/Utils/Monad.hs b/compiler/GHC/Tc/Utils/Monad.hs
index 4f14d7b251..85b3ad2e96 100644
--- a/compiler/GHC/Tc/Utils/Monad.hs
+++ b/compiler/GHC/Tc/Utils/Monad.hs
@@ -490,22 +490,28 @@ unsetWOptM flag =
 whenDOptM :: DumpFlag -> TcRnIf gbl lcl () -> TcRnIf gbl lcl ()
 whenDOptM flag thing_inside = do b <- doptM flag
                                  when b thing_inside
+{-# INLINE whenDOptM #-} -- see Note [INLINE conditional tracing utilities]
+
 
 whenGOptM :: GeneralFlag -> TcRnIf gbl lcl () -> TcRnIf gbl lcl ()
 whenGOptM flag thing_inside = do b <- goptM flag
                                  when b thing_inside
+{-# INLINE whenGOptM #-} -- see Note [INLINE conditional tracing utilities]
 
 whenWOptM :: WarningFlag -> TcRnIf gbl lcl () -> TcRnIf gbl lcl ()
 whenWOptM flag thing_inside = do b <- woptM flag
                                  when b thing_inside
+{-# INLINE whenWOptM #-} -- see Note [INLINE conditional tracing utilities]
 
 whenXOptM :: LangExt.Extension -> TcRnIf gbl lcl () -> TcRnIf gbl lcl ()
 whenXOptM flag thing_inside = do b <- xoptM flag
                                  when b thing_inside
+{-# INLINE whenXOptM #-} -- see Note [INLINE conditional tracing utilities]
 
 unlessXOptM :: LangExt.Extension -> TcRnIf gbl lcl () -> TcRnIf gbl lcl ()
 unlessXOptM flag thing_inside = do b <- xoptM flag
                                    unless b thing_inside
+{-# INLINE unlessXOptM #-} -- see Note [INLINE conditional tracing utilities]
 
 getGhcMode :: TcRnIf gbl lcl GhcMode
 getGhcMode = do { env <- getTopEnv; return (ghcMode (hsc_dflags env)) }
@@ -662,39 +668,64 @@ updTcRef ref fn = liftIO $ do { old <- readIORef ref
 ************************************************************************
 -}
 
+-- Note [INLINE conditional tracing utilities]
+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~
+-- In general we want to optimise for the case where tracing is not enabled.
+-- To ensure this happens, we ensure that traceTc and friends are inlined; this
+-- ensures that the allocation of the document can be pushed into the tracing
+-- path, keeping the non-traced path free of this extraneous work. For
+-- instance, instead of
+--
+--     let thunk = ...
+--     in if doTracing
+--          then emitTraceMsg thunk
+--          else return ()
+--
+-- where the conditional is buried in a non-inlined utility function (e.g.
+-- traceTc), we would rather have:
+--
+--     if doTracing
+--       then let thunk = ...
+--            in emitTraceMsg thunk
+--       else return ()
+--
+-- See #18168.
+--
 
 -- Typechecker trace
 traceTc :: String -> SDoc -> TcRn ()
-traceTc =
-  labelledTraceOptTcRn Opt_D_dump_tc_trace
+traceTc herald doc =
+    labelledTraceOptTcRn Opt_D_dump_tc_trace herald doc
+{-# INLINE traceTc #-} -- see Note [INLINE conditional tracing utilities]
 
 -- Renamer Trace
 traceRn :: String -> SDoc -> TcRn ()
-traceRn =
-  labelledTraceOptTcRn Opt_D_dump_rn_trace
+traceRn herald doc =
+    labelledTraceOptTcRn Opt_D_dump_rn_trace herald doc
+{-# INLINE traceRn #-} -- see Note [INLINE conditional tracing utilities]
 
 -- | Trace when a certain flag is enabled. This is like `traceOptTcRn`
 -- but accepts a string as a label and formats the trace message uniformly.
 labelledTraceOptTcRn :: DumpFlag -> String -> SDoc -> TcRn ()
-labelledTraceOptTcRn flag herald doc = do
-   traceOptTcRn flag (formatTraceMsg herald doc)
+labelledTraceOptTcRn flag herald doc =
+  traceOptTcRn flag (formatTraceMsg herald doc)
+{-# INLINE labelledTraceOptTcRn #-} -- see Note [INLINE conditional tracing utilities]
 
 formatTraceMsg :: String -> SDoc -> SDoc
 formatTraceMsg herald doc = hang (text herald) 2 doc
 
--- | Trace if the given 'DumpFlag' is set.
 traceOptTcRn :: DumpFlag -> SDoc -> TcRn ()
 traceOptTcRn flag doc = do
-  dflags <- getDynFlags
-  when (dopt flag dflags) $
+  whenDOptM flag $
     dumpTcRn False (dumpOptionsFromFlag flag) "" FormatText doc
+{-# INLINE traceOptTcRn #-} -- see Note [INLINE conditional tracing utilities]
 
 -- | Dump if the given 'DumpFlag' is set.
 dumpOptTcRn :: DumpFlag -> String -> DumpFormat -> SDoc -> TcRn ()
 dumpOptTcRn flag title fmt doc = do
-  dflags <- getDynFlags
-  when (dopt flag dflags) $
+  whenDOptM flag $
     dumpTcRn False (dumpOptionsFromFlag flag) title fmt doc
+{-# INLINE dumpOptTcRn #-} -- see Note [INLINE conditional tracing utilities]
 
 -- | Unconditionally dump some trace output
 --
@@ -746,13 +777,16 @@ e.g. are unaffected by -dump-to-file.
 traceIf, traceHiDiffs :: SDoc -> TcRnIf m n ()
 traceIf      = traceOptIf Opt_D_dump_if_trace
 traceHiDiffs = traceOptIf Opt_D_dump_hi_diffs
-
+{-# INLINE traceIf #-}
+{-# INLINE traceHiDiffs #-}
+  -- see Note [INLINE conditional tracing utilities]
 
 traceOptIf :: DumpFlag -> SDoc -> TcRnIf m n ()
 traceOptIf flag doc
   = whenDOptM flag $    -- No RdrEnv available, so qualify everything
     do { dflags <- getDynFlags
        ; liftIO (putMsg dflags doc) }
+{-# INLINE traceOptIf #-}  -- see Note [INLINE conditional tracing utilities]
 
 {-
 ************************************************************************
diff --git a/compiler/GHC/Utils/Error.hs b/compiler/GHC/Utils/Error.hs
index eb775aa4a3..6854846a81 100644
--- a/compiler/GHC/Utils/Error.hs
+++ b/compiler/GHC/Utils/Error.hs
@@ -438,20 +438,28 @@ doIfSet_dyn dflags flag action | gopt flag dflags = action
 dumpIfSet :: DynFlags -> Bool -> String -> SDoc -> IO ()
 dumpIfSet dflags flag hdr doc
   | not flag   = return ()
-  | otherwise  = putLogMsg  dflags
-                            NoReason
-                            SevDump
-                            noSrcSpan
-                            (withPprStyle defaultDumpStyle
-                              (mkDumpDoc hdr doc))
-
--- | a wrapper around 'dumpAction'.
+  | otherwise  = doDump dflags hdr doc
+{-# INLINE dumpIfSet #-}  -- see Note [INLINE conditional tracing utilities]
+
+-- | This is a helper for 'dumpIfSet' to ensure that it's not duplicated
+-- despite the fact that 'dumpIfSet' has an @INLINE@.
+doDump :: DynFlags -> String -> SDoc -> IO ()
+doDump dflags hdr doc =
+  putLogMsg dflags
+            NoReason
+            SevDump
+            noSrcSpan
+            (withPprStyle defaultDumpStyle
+              (mkDumpDoc hdr doc))
+
+-- | A wrapper around 'dumpAction'.
 -- First check whether the dump flag is set
 -- Do nothing if it is unset
 dumpIfSet_dyn :: DynFlags -> DumpFlag -> String -> DumpFormat -> SDoc -> IO ()
 dumpIfSet_dyn = dumpIfSet_dyn_printer alwaysQualify
+{-# INLINE dumpIfSet_dyn #-}  -- see Note [INLINE conditional tracing utilities]
 
--- | a wrapper around 'dumpAction'.
+-- | A wrapper around 'dumpAction'.
 -- First check whether the dump flag is set
 -- Do nothing if it is unset
 --
@@ -462,6 +470,7 @@ dumpIfSet_dyn_printer printer dflags flag hdr fmt doc
   = when (dopt flag dflags) $ do
       let sty = mkDumpStyle printer
       dumpAction dflags sty (dumpOptionsFromFlag flag) hdr fmt doc
+{-# INLINE dumpIfSet_dyn_printer #-}  -- see Note [INLINE conditional tracing utilities]
 
 mkDumpDoc :: String -> SDoc -> SDoc
 mkDumpDoc hdr doc
@@ -608,6 +617,7 @@ ifVerbose :: DynFlags -> Int -> IO () -> IO ()
 ifVerbose dflags val act
   | verbosity dflags >= val = act
   | otherwise               = return ()
+{-# INLINE ifVerbose #-}  -- see Note [INLINE conditional tracing utilities]
 
 errorMsg :: DynFlags -> MsgDoc -> IO ()
 errorMsg dflags msg
@@ -778,6 +788,7 @@ debugTraceMsg :: DynFlags -> Int -> MsgDoc -> IO ()
 debugTraceMsg dflags val msg =
    ifVerbose dflags val $
       logInfo dflags (withPprStyle defaultDumpStyle msg)
+{-# INLINE debugTraceMsg #-}  -- see Note [INLINE conditional tracing utilities]
 
 putMsg :: DynFlags -> MsgDoc -> IO ()
 putMsg dflags msg = logInfo dflags (withPprStyle defaultUserStyle msg)