diff options
| -rw-r--r-- | compiler/GHC/Core/Opt/Simplify/Monad.hs | 1 | ||||
| -rw-r--r-- | compiler/GHC/Core/Unfold.hs | 8 | ||||
| -rw-r--r-- | compiler/GHC/HsToCore/PmCheck/Oracle.hs | 1 | ||||
| -rw-r--r-- | compiler/GHC/Tc/Solver/Flatten.hs | 1 | ||||
| -rw-r--r-- | compiler/GHC/Tc/Solver/Monad.hs | 4 | ||||
| -rw-r--r-- | compiler/GHC/Tc/Utils/Monad.hs | 58 | ||||
| -rw-r--r-- | compiler/GHC/Utils/Error.hs | 29 |
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) |