[Git][ghc/ghc][wip/lower-tc-tracing-cost] Avoid unnecessary allocations due to tracing utilities
Ben Gamari
gitlab at gitlab.haskell.org
Mon May 11 00:46:47 UTC 2020
Ben Gamari pushed to branch wip/lower-tc-tracing-cost at Glasgow Haskell Compiler / GHC
Commits:
8be2fb78 by Ben Gamari at 2020-05-10T20:46:27-04:00
Avoid unnecessary allocations due to tracing utilities
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
- - - - -
7 changed files:
- compiler/GHC/Core/Opt/Simplify/Monad.hs
- compiler/GHC/Core/Unfold.hs
- compiler/GHC/HsToCore/PmCheck/Oracle.hs
- compiler/GHC/Tc/Solver/Flatten.hs
- compiler/GHC/Tc/Solver/Monad.hs
- compiler/GHC/Tc/Utils/Monad.hs
- compiler/GHC/Utils/Error.hs
Changes:
=====================================
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]
{-
************************************************************************
=====================================
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
=====================================
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
=====================================
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
=====================================
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)
=====================================
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]
{-
************************************************************************
=====================================
compiler/GHC/Utils/Error.hs
=====================================
@@ -438,20 +438,27 @@ 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
+ where
+ -- Explicitly bind this so it can float out and we don't duplicate this code
+ -- needlessly due to the INLINE below.
+ doDump dflags hdr doc =
+ putLogMsg dflags
+ NoReason
+ SevDump
+ noSrcSpan
+ (withPprStyle defaultDumpStyle
+ (mkDumpDoc hdr doc))
+{-# INLINE dumpIfSet #-} -- see Note [INLINE conditional tracing utilities]
+
+-- | 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 +469,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 +616,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 +787,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)
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/8be2fb78b08d8a5741f07588cef65100d32a455c
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/8be2fb78b08d8a5741f07588cef65100d32a455c
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20200510/0f5e342f/attachment-0001.html>
More information about the ghc-commits
mailing list