Commit 6beea836 authored by Andreas Klebinger's avatar Andreas Klebinger Committed by Marge Bot

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.
parent 9c1f0f7c
......@@ -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)
......
......@@ -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)
......
......@@ -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
......
......@@ -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
......
......@@ -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)
......
......@@ -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
......
......@@ -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
......
......@@ -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
......
......@@ -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
......
......@@ -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
......
......@@ -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:
--
......
......@@ -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
......
......@@ -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))])
......
......@@ -331,8 +331,7 @@ 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))
withTimingD (text "Parser"<+>brackets (ppr $ ms_mod mod_summary))
(const ()) $ do
dflags <- getDynFlags
let src_filename = ms_hspp_file 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
......
......@@ -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
......
......@@ -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 ())
......@@ -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
......
......@@ -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
......
......@@ -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,9 +410,8 @@ 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))
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')
......@@ -484,8 +483,7 @@ printCore dflags binds
ruleCheckPass :: CompilerPhase -> String -> ModGuts -> CoreM ModGuts
ruleCheckPass current_phase pat guts =
withTiming getDynFlags
(text "RuleCheck"<+>brackets (ppr $ mg_module guts))
withTimingD (text "RuleCheck"<+>brackets (ppr $ mg_module guts))
(const ()) $ do
{ rb <- getRuleBase
; dflags <- getDynFlags
......@@ -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'
......
......@@ -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
......
......@@ -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 $
......
Subproject commit a7c42a29f7c33f5fdbb04acc3866ec907c2e00f3
Subproject commit f0b5a2043ff6c527e55fab228d37ee698ce87262
Markdown is supported
0%
or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment