diff options
| author | Ben Gamari <ben@smart-cactus.org> | 2020-04-14 00:53:39 -0400 |
|---|---|---|
| committer | Marge Bot <ben+marge-bot@smart-cactus.org> | 2020-05-28 16:23:21 -0400 |
| commit | 1f393e1e0a2998fe67cfd06501e35f495758b98f (patch) | |
| tree | 66e12034633bac78d72b6df5450ca8326db86c28 /compiler/GHC/Utils/Error.hs | |
| parent | 28deee2872d2501a781ae5b89f1db3dbf796ee74 (diff) | |
| download | haskell-1f393e1e0a2998fe67cfd06501e35f495758b98f.tar.gz | |
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
haddock.Cabal
haddock.base
haddock.compiler
Diffstat (limited to 'compiler/GHC/Utils/Error.hs')
| -rw-r--r-- | compiler/GHC/Utils/Error.hs | 29 |
1 files changed, 20 insertions, 9 deletions
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) |