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 ...@@ -71,7 +71,7 @@ codeGen dflags this_mod data_tycons
; cgref <- liftIO $ newIORef =<< initC ; cgref <- liftIO $ newIORef =<< initC
; let cg :: FCode () -> Stream IO CmmGroup () ; let cg :: FCode () -> Stream IO CmmGroup ()
cg fcode = do 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 st <- readIORef cgref
let (a,st') = runC dflags this_mod st (getCmm fcode) let (a,st') = runC dflags this_mod st (getCmm fcode)
......
...@@ -74,7 +74,7 @@ cmmToRawCmm dflags cmms ...@@ -74,7 +74,7 @@ cmmToRawCmm dflags cmms
; let do_one :: UniqSupply -> [CmmDecl] -> IO (UniqSupply, [RawCmmDecl]) ; let do_one :: UniqSupply -> [CmmDecl] -> IO (UniqSupply, [RawCmmDecl])
do_one uniqs cmm = do_one uniqs cmm =
-- NB. strictness fixes a space leak. DO NOT REMOVE. -- NB. strictness fixes a space leak. DO NOT REMOVE.
withTimingSilent (return dflags) (text "Cmm -> Raw Cmm") withTimingSilent dflags (text "Cmm -> Raw Cmm")
forceRes $ forceRes $
case initUs uniqs $ concatMapM (mkInfoTable dflags) cmm of case initUs uniqs $ concatMapM (mkInfoTable dflags) cmm of
(b,uniqs') -> return (uniqs',b) (b,uniqs') -> return (uniqs',b)
......
...@@ -375,8 +375,8 @@ cmm :: { CmmParse () } ...@@ -375,8 +375,8 @@ cmm :: { CmmParse () }
cmmtop :: { CmmParse () } cmmtop :: { CmmParse () }
: cmmproc { $1 } : cmmproc { $1 }
| cmmdata { $1 } | cmmdata { $1 }
| decl { $1 } | decl { $1 }
| 'CLOSURE' '(' NAME ',' NAME lits ')' ';' | 'CLOSURE' '(' NAME ',' NAME lits ')' ';'
{% liftP . withThisPackage $ \pkg -> {% liftP . withThisPackage $ \pkg ->
do lits <- sequence $6; do lits <- sequence $6;
staticClosure pkg $3 $5 (map getLit lits) } staticClosure pkg $3 $5 (map getLit lits) }
...@@ -391,30 +391,30 @@ cmmtop :: { CmmParse () } ...@@ -391,30 +391,30 @@ cmmtop :: { CmmParse () }
-- * we can derive closure and info table labels from a single NAME -- * we can derive closure and info table labels from a single NAME
cmmdata :: { CmmParse () } cmmdata :: { CmmParse () }
: 'section' STRING '{' data_label statics '}' : 'section' STRING '{' data_label statics '}'
{ do lbl <- $4; { do lbl <- $4;
ss <- sequence $5; ss <- sequence $5;
code (emitDecl (CmmData (Section (section $2) lbl) (Statics lbl $ concat ss))) } code (emitDecl (CmmData (Section (section $2) lbl) (Statics lbl $ concat ss))) }
data_label :: { CmmParse CLabel } data_label :: { CmmParse CLabel }
: NAME ':' : NAME ':'
{% liftP . withThisPackage $ \pkg -> {% liftP . withThisPackage $ \pkg ->
return (mkCmmDataLabel pkg $1) } return (mkCmmDataLabel pkg $1) }
statics :: { [CmmParse [CmmStatic]] } statics :: { [CmmParse [CmmStatic]] }
: {- empty -} { [] } : {- empty -} { [] }
| static statics { $1 : $2 } | static statics { $1 : $2 }
static :: { CmmParse [CmmStatic] } static :: { CmmParse [CmmStatic] }
: type expr ';' { do e <- $2; : type expr ';' { do e <- $2;
return [CmmStaticLit (getLit e)] } return [CmmStaticLit (getLit e)] }
| type ';' { return [CmmUninitialised | type ';' { return [CmmUninitialised
(widthInBytes (typeWidth $1))] } (widthInBytes (typeWidth $1))] }
| 'bits8' '[' ']' STRING ';' { return [mkString $4] } | 'bits8' '[' ']' STRING ';' { return [mkString $4] }
| 'bits8' '[' INT ']' ';' { return [CmmUninitialised | 'bits8' '[' INT ']' ';' { return [CmmUninitialised
(fromIntegral $3)] } (fromIntegral $3)] }
| typenot8 '[' INT ']' ';' { return [CmmUninitialised | typenot8 '[' INT ']' ';' { return [CmmUninitialised
(widthInBytes (typeWidth $1) * (widthInBytes (typeWidth $1) *
fromIntegral $3)] } fromIntegral $3)] }
| 'CLOSURE' '(' NAME lits ')' | 'CLOSURE' '(' NAME lits ')'
{ do { lits <- sequence $4 { do { lits <- sequence $4
...@@ -475,7 +475,7 @@ info :: { CmmParse (CLabel, Maybe CmmInfoTable, [LocalReg]) } ...@@ -475,7 +475,7 @@ info :: { CmmParse (CLabel, Maybe CmmInfoTable, [LocalReg]) }
, cit_rep = rep , cit_rep = rep
, cit_prof = prof, cit_srt = Nothing, cit_clo = Nothing }, , cit_prof = prof, cit_srt = Nothing, cit_clo = Nothing },
[]) } []) }
| 'INFO_TABLE_FUN' '(' NAME ',' INT ',' INT ',' INT ',' STRING ',' STRING ',' INT ')' | 'INFO_TABLE_FUN' '(' NAME ',' INT ',' INT ',' INT ',' STRING ',' STRING ',' INT ')'
-- ptrs, nptrs, closure type, description, type, fun type -- ptrs, nptrs, closure type, description, type, fun type
{% liftP . withThisPackage $ \pkg -> {% liftP . withThisPackage $ \pkg ->
...@@ -512,7 +512,7 @@ info :: { CmmParse (CLabel, Maybe CmmInfoTable, [LocalReg]) } ...@@ -512,7 +512,7 @@ info :: { CmmParse (CLabel, Maybe CmmInfoTable, [LocalReg]) }
-- If profiling is on, this string gets duplicated, -- If profiling is on, this string gets duplicated,
-- but that's the way the old code did it we can fix it some other time. -- but that's the way the old code did it we can fix it some other time.
| 'INFO_TABLE_SELECTOR' '(' NAME ',' INT ',' INT ',' STRING ',' STRING ')' | 'INFO_TABLE_SELECTOR' '(' NAME ',' INT ',' INT ',' STRING ',' STRING ')'
-- selector, closure type, description, type -- selector, closure type, description, type
{% liftP . withThisPackage $ \pkg -> {% liftP . withThisPackage $ \pkg ->
...@@ -575,7 +575,7 @@ importName ...@@ -575,7 +575,7 @@ importName
-- A label imported without an explicit packageId. -- A label imported without an explicit packageId.
-- These are taken to come frome some foreign, unnamed package. -- These are taken to come frome some foreign, unnamed package.
: NAME : NAME
{ ($1, mkForeignLabel $1 Nothing ForeignLabelInExternalPackage IsFunction) } { ($1, mkForeignLabel $1 Nothing ForeignLabelInExternalPackage IsFunction) }
-- as previous 'NAME', but 'IsData' -- as previous 'NAME', but 'IsData'
...@@ -585,8 +585,8 @@ importName ...@@ -585,8 +585,8 @@ importName
-- A label imported with an explicit packageId. -- A label imported with an explicit packageId.
| STRING NAME | STRING NAME
{ ($2, mkCmmCodeLabel (fsToUnitId (mkFastString $1)) $2) } { ($2, mkCmmCodeLabel (fsToUnitId (mkFastString $1)) $2) }
names :: { [FastString] } names :: { [FastString] }
: NAME { [$1] } : NAME { [$1] }
| NAME ',' names { $1 : $3 } | NAME ',' names { $1 : $3 }
...@@ -672,9 +672,9 @@ bool_expr :: { CmmParse BoolExpr } ...@@ -672,9 +672,9 @@ bool_expr :: { CmmParse BoolExpr }
| expr { do e <- $1; return (BoolTest e) } | expr { do e <- $1; return (BoolTest e) }
bool_op :: { CmmParse BoolExpr } bool_op :: { CmmParse BoolExpr }
: bool_expr '&&' bool_expr { do e1 <- $1; e2 <- $3; : bool_expr '&&' bool_expr { do e1 <- $1; e2 <- $3;
return (BoolAnd e1 e2) } return (BoolAnd e1 e2) }
| bool_expr '||' bool_expr { do e1 <- $1; e2 <- $3; | bool_expr '||' bool_expr { do e1 <- $1; e2 <- $3;
return (BoolOr e1 e2) } return (BoolOr e1 e2) }
| '!' bool_expr { do e <- $2; return (BoolNot e) } | '!' bool_expr { do e <- $2; return (BoolNot e) }
| '(' bool_op ')' { $2 } | '(' bool_op ')' { $2 }
...@@ -760,7 +760,7 @@ expr :: { CmmParse CmmExpr } ...@@ -760,7 +760,7 @@ expr :: { CmmParse CmmExpr }
expr0 :: { CmmParse CmmExpr } expr0 :: { CmmParse CmmExpr }
: INT maybe_ty { return (CmmLit (CmmInt $1 (typeWidth $2))) } : INT maybe_ty { return (CmmLit (CmmInt $1 (typeWidth $2))) }
| FLOAT maybe_ty { return (CmmLit (CmmFloat $1 (typeWidth $2))) } | FLOAT maybe_ty { return (CmmLit (CmmFloat $1 (typeWidth $2))) }
| STRING { do s <- code (newStringCLit $1); | STRING { do s <- code (newStringCLit $1);
return (CmmLit s) } return (CmmLit s) }
| reg { $1 } | reg { $1 }
| type '[' expr ']' { do e <- $3; return (CmmLoad e $1) } | type '[' expr ']' { do e <- $3; return (CmmLoad e $1) }
...@@ -818,14 +818,14 @@ foreign_formal :: { CmmParse (LocalReg, ForeignHint) } ...@@ -818,14 +818,14 @@ foreign_formal :: { CmmParse (LocalReg, ForeignHint) }
local_lreg :: { CmmParse LocalReg } local_lreg :: { CmmParse LocalReg }
: NAME { do e <- lookupName $1; : NAME { do e <- lookupName $1;
return $ return $
case e of case e of
CmmReg (CmmLocal r) -> r CmmReg (CmmLocal r) -> r
other -> pprPanic "CmmParse:" (ftext $1 <> text " not a local register") } other -> pprPanic "CmmParse:" (ftext $1 <> text " not a local register") }
lreg :: { CmmParse CmmReg } lreg :: { CmmParse CmmReg }
: NAME { do e <- lookupName $1; : NAME { do e <- lookupName $1;
return $ return $
case e of case e of
CmmReg r -> r CmmReg r -> r
other -> pprPanic "CmmParse:" (ftext $1 <> text " not a register") } other -> pprPanic "CmmParse:" (ftext $1 <> text " not a register") }
| GLOBALREG { return (CmmGlobal $1) } | GLOBALREG { return (CmmGlobal $1) }
...@@ -1376,7 +1376,7 @@ doSwitch :: Maybe (Integer,Integer) ...@@ -1376,7 +1376,7 @@ doSwitch :: Maybe (Integer,Integer)
doSwitch mb_range scrut arms deflt doSwitch mb_range scrut arms deflt
= do = do
-- Compile code for the default branch -- Compile code for the default branch
dflt_entry <- dflt_entry <-
case deflt of case deflt of
Nothing -> return Nothing Nothing -> return Nothing
Just e -> do b <- forkLabelledCode e; return (Just b) Just e -> do b <- forkLabelledCode e; return (Just b)
...@@ -1419,7 +1419,7 @@ initEnv dflags = listToUFM [ ...@@ -1419,7 +1419,7 @@ initEnv dflags = listToUFM [
] ]
parseCmmFile :: DynFlags -> FilePath -> IO (Messages, Maybe CmmGroup) 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 buf <- hGetStringBuffer filename
let let
init_loc = mkRealSrcLoc (mkFastString filename) 1 1 init_loc = mkRealSrcLoc (mkFastString filename) 1 1
......
...@@ -39,7 +39,7 @@ cmmPipeline ...@@ -39,7 +39,7 @@ cmmPipeline
-> CmmGroup -- Input C-- with Procedures -> CmmGroup -- Input C-- with Procedures
-> IO (ModuleSRTInfo, CmmGroup) -- Output CPS transformed C-- -> 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 do let dflags = hsc_dflags hsc_env
tops <- {-# SCC "tops" #-} mapM (cpsTop hsc_env) prog tops <- {-# SCC "tops" #-} mapM (cpsTop hsc_env) prog
......
...@@ -178,7 +178,7 @@ type CpeRhs = CoreExpr -- Non-terminal 'rhs' ...@@ -178,7 +178,7 @@ type CpeRhs = CoreExpr -- Non-terminal 'rhs'
corePrepPgm :: HscEnv -> Module -> ModLocation -> CoreProgram -> [TyCon] corePrepPgm :: HscEnv -> Module -> ModLocation -> CoreProgram -> [TyCon]
-> IO (CoreProgram, S.Set CostCentre) -> IO (CoreProgram, S.Set CostCentre)
corePrepPgm hsc_env this_mod mod_loc binds data_tycons = corePrepPgm hsc_env this_mod mod_loc binds data_tycons =
withTiming (pure dflags) withTiming dflags
(text "CorePrep"<+>brackets (ppr this_mod)) (text "CorePrep"<+>brackets (ppr this_mod))
(const ()) $ do (const ()) $ do
us <- mkSplitUniqSupply 's' us <- mkSplitUniqSupply 's'
...@@ -206,7 +206,7 @@ corePrepPgm hsc_env this_mod mod_loc binds data_tycons = ...@@ -206,7 +206,7 @@ corePrepPgm hsc_env this_mod mod_loc binds data_tycons =
corePrepExpr :: DynFlags -> HscEnv -> CoreExpr -> IO CoreExpr corePrepExpr :: DynFlags -> HscEnv -> CoreExpr -> IO CoreExpr
corePrepExpr dflags hsc_env expr = corePrepExpr dflags hsc_env expr =
withTiming (pure dflags) (text "CorePrep [expr]") (const ()) $ do withTiming dflags (text "CorePrep [expr]") (const ()) $ do
us <- mkSplitUniqSupply 's' us <- mkSplitUniqSupply 's'
initialCorePrepEnv <- mkInitialCorePrepEnv dflags hsc_env initialCorePrepEnv <- mkInitialCorePrepEnv dflags hsc_env
let new_expr = initUs_ us (cpeBodyNF initialCorePrepEnv expr) let new_expr = initUs_ us (cpeBodyNF initialCorePrepEnv expr)
......
...@@ -114,7 +114,7 @@ deSugar hsc_env ...@@ -114,7 +114,7 @@ deSugar hsc_env
= do { let dflags = hsc_dflags hsc_env = do { let dflags = hsc_dflags hsc_env
print_unqual = mkPrintUnqualified dflags rdr_env print_unqual = mkPrintUnqualified dflags rdr_env
; withTiming (pure dflags) ; withTiming dflags
(text "Desugar"<+>brackets (ppr mod)) (text "Desugar"<+>brackets (ppr mod))
(const ()) $ (const ()) $
do { -- Desugar the program do { -- Desugar the program
......
...@@ -86,7 +86,7 @@ byteCodeGen :: HscEnv ...@@ -86,7 +86,7 @@ byteCodeGen :: HscEnv
-> Maybe ModBreaks -> Maybe ModBreaks
-> IO CompiledByteCode -> IO CompiledByteCode
byteCodeGen hsc_env this_mod binds tycs mb_modBreaks byteCodeGen hsc_env this_mod binds tycs mb_modBreaks
= withTiming (pure dflags) = withTiming dflags
(text "ByteCodeGen"<+>brackets (ppr this_mod)) (text "ByteCodeGen"<+>brackets (ppr this_mod))
(const ()) $ do (const ()) $ do
-- Split top-level binds into strings and others. -- Split top-level binds into strings and others.
...@@ -158,7 +158,7 @@ coreExprToBCOs :: HscEnv ...@@ -158,7 +158,7 @@ coreExprToBCOs :: HscEnv
-> CoreExpr -> CoreExpr
-> IO UnlinkedBCO -> IO UnlinkedBCO
coreExprToBCOs hsc_env this_mod expr coreExprToBCOs hsc_env this_mod expr
= withTiming (pure dflags) = withTiming dflags
(text "ByteCodeGen"<+>brackets (ppr this_mod)) (text "ByteCodeGen"<+>brackets (ppr this_mod))
(const ()) $ do (const ()) $ do
-- create a totally bogus name for the top-level BCO; this -- create a totally bogus name for the top-level BCO; this
......
...@@ -400,7 +400,7 @@ loadInterface doc_str mod from ...@@ -400,7 +400,7 @@ loadInterface doc_str mod from
-- Redo search for our local hole module -- Redo search for our local hole module
loadInterface doc_str (mkModule (thisPackage dflags) (moduleName mod)) from loadInterface doc_str (mkModule (thisPackage dflags) (moduleName mod)) from
| otherwise | otherwise
= withTimingSilent getDynFlags (text "loading interface") (pure ()) $ = withTimingSilentD (text "loading interface") (pure ()) $
do { -- Read the state do { -- Read the state
(eps,hpt) <- getEpsAndHpt (eps,hpt) <- getEpsAndHpt
; gbl_env <- getGblEnv ; gbl_env <- getGblEnv
......
...@@ -45,7 +45,7 @@ llvmCodeGen :: DynFlags -> Handle -> UniqSupply ...@@ -45,7 +45,7 @@ llvmCodeGen :: DynFlags -> Handle -> UniqSupply
-> Stream.Stream IO RawCmmGroup a -> Stream.Stream IO RawCmmGroup a
-> IO a -> IO a
llvmCodeGen dflags h us cmm_stream llvmCodeGen dflags h us cmm_stream
= withTiming (pure dflags) (text "LLVM CodeGen") (const ()) $ do = withTiming dflags (text "LLVM CodeGen") (const ()) $ do
bufh <- newBufHandle h bufh <- newBufHandle h
-- Pass header -- Pass header
......
...@@ -25,7 +25,7 @@ import System.IO ...@@ -25,7 +25,7 @@ import System.IO
-- | Read in assembly file and process -- | Read in assembly file and process
llvmFixupAsm :: DynFlags -> FilePath -> FilePath -> IO () llvmFixupAsm :: DynFlags -> FilePath -> FilePath -> IO ()
llvmFixupAsm dflags f1 f2 = {-# SCC "llvm_mangler" #-} 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 withBinaryFile f1 ReadMode $ \r -> withBinaryFile f2 WriteMode $ \w -> do
go r w go r w
hClose r hClose r
......
...@@ -71,7 +71,7 @@ codeOutput dflags this_mod filenm location foreign_stubs foreign_fps pkg_deps ...@@ -71,7 +71,7 @@ codeOutput dflags this_mod filenm location foreign_stubs foreign_fps pkg_deps
else cmm_stream else cmm_stream
do_lint cmm = withTimingSilent do_lint cmm = withTimingSilent
(pure dflags) dflags
(text "CmmLint"<+>brackets (ppr this_mod)) (text "CmmLint"<+>brackets (ppr this_mod))
(const ()) $ do (const ()) $ do
{ case cmmLint dflags cmm of { case cmmLint dflags cmm of
...@@ -118,7 +118,7 @@ outputC :: DynFlags ...@@ -118,7 +118,7 @@ outputC :: DynFlags
outputC dflags filenm cmm_stream packages outputC dflags filenm cmm_stream packages
= do = 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: -- figure out which header files to #include in the generated .hc file:
-- --
......
...@@ -50,7 +50,8 @@ module ErrUtils ( ...@@ -50,7 +50,8 @@ module ErrUtils (
errorMsg, warningMsg, errorMsg, warningMsg,
fatalErrorMsg, fatalErrorMsg'', fatalErrorMsg, fatalErrorMsg'',
compilationProgressMsg, compilationProgressMsg,
showPass, withTiming, withTimingSilent, showPass,
withTiming, withTimingSilent, withTimingD, withTimingSilentD,
debugTraceMsg, debugTraceMsg,
ghcExit, ghcExit,
prettyPrintGhcErrors, prettyPrintGhcErrors,
...@@ -647,15 +648,25 @@ data PrintTimings = PrintTimings | DontPrintTimings ...@@ -647,15 +648,25 @@ data PrintTimings = PrintTimings | DontPrintTimings
-- --
-- See Note [withTiming] for more. -- See Note [withTiming] for more.
withTiming :: MonadIO m withTiming :: MonadIO m
=> m DynFlags -- ^ A means of getting a 'DynFlags' (often => DynFlags -- ^ DynFlags
-- 'getDynFlags' will work here)
-> SDoc -- ^ The name of the phase -> SDoc -- ^ The name of the phase
-> (a -> ()) -- ^ A function to force the result -> (a -> ()) -- ^ A function to force the result
-- (often either @const ()@ or 'rnf') -- (often either @const ()@ or 'rnf')
-> m a -- ^ The body of the phase to be timed -> m a -- ^ The body of the phase to be timed
-> m a -> m a
withTiming getDFlags what force action = withTiming dflags what force action =
withTiming' getDFlags what force PrintTimings 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 -- | Same as 'withTiming', but doesn't print timings in the
...@@ -664,19 +675,34 @@ withTiming getDFlags what force action = ...@@ -664,19 +675,34 @@ withTiming getDFlags what force action =
-- See Note [withTiming] for more. -- See Note [withTiming] for more.
withTimingSilent withTimingSilent
:: MonadIO m :: MonadIO m
=> m DynFlags -- ^ A means of getting a 'DynFlags' (often => DynFlags -- ^ DynFlags
-- 'getDynFlags' will work here)
-> SDoc -- ^ The name of the phase -> SDoc -- ^ The name of the phase
-> (a -> ()) -- ^ A function to force the result -> (a -> ()) -- ^ A function to force the result
-- (often either @const ()@ or 'rnf') -- (often either @const ()@ or 'rnf')
-> m a -- ^ The body of the phase to be timed -> m a -- ^ The body of the phase to be timed
-> m a -> m a
withTimingSilent getDFlags what force action = withTimingSilent dflags what force action =
withTiming' getDFlags what force DontPrintTimings 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'. -- | Worker for 'withTiming' and 'withTimingSilent'.
withTiming' :: MonadIO m withTiming' :: MonadIO m
=> m DynFlags -- ^ A means of getting a 'DynFlags' (often => DynFlags -- ^ A means of getting a 'DynFlags' (often
-- 'getDynFlags' will work here) -- 'getDynFlags' will work here)
-> SDoc -- ^ The name of the phase -> SDoc -- ^ The name of the phase
-> (a -> ()) -- ^ A function to force the result -> (a -> ()) -- ^ A function to force the result
...@@ -684,9 +710,8 @@ withTiming' :: MonadIO m ...@@ -684,9 +710,8 @@ withTiming' :: MonadIO m
-> PrintTimings -- ^ Whether to print the timings -> PrintTimings -- ^ Whether to print the timings
-> m a -- ^ The body of the phase to be timed -> m a -- ^ The body of the phase to be timed
-> m a -> m a
withTiming' getDFlags what force_result prtimings action withTiming' dflags what force_result prtimings action
= do dflags <- getDFlags = do if verbosity dflags >= 2 || dopt Opt_D_dump_timings dflags
if verbosity dflags >= 2 || dopt Opt_D_dump_timings dflags
then do whenPrintTimings $ then do whenPrintTimings $
logInfo dflags (defaultUserStyle dflags) $ logInfo dflags (defaultUserStyle dflags) $
text "***" <+> what <> colon text "***" <+> what <> colon
......
...@@ -154,7 +154,7 @@ depanalPartial excluded_mods allow_dup_roots = do ...@@ -154,7 +154,7 @@ depanalPartial excluded_mods allow_dup_roots = do
targets = hsc_targets hsc_env targets = hsc_targets hsc_env
old_graph = hsc_mod_graph 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 [ liftIO $ debugTraceMsg dflags 2 (hcat [
text "Chasing modules from: ", text "Chasing modules from: ",
hcat (punctuate comma (map pprTarget targets))]) hcat (punctuate comma (map pprTarget targets))])
......
...@@ -331,9 +331,8 @@ hscParse' :: ModSummary -> Hsc HsParsedModule ...@@ -331,9 +331,8 @@ hscParse' :: ModSummary -> Hsc HsParsedModule
hscParse' mod_summary hscParse' mod_summary
| Just r <- ms_parsed_mod mod_summary = return r | Just r <- ms_parsed_mod mod_summary = return r
| otherwise = {-# SCC "Parser" #-} | otherwise = {-# SCC "Parser" #-}
withTiming getDynFlags withTimingD (text "Parser"<+>brackets (ppr $ ms_mod mod_summary))
(text "Parser"<+>brackets (ppr $ ms_mod mod_summary)) (const ()) $ do
(const ()) $ do
dflags <- getDynFlags dflags <- getDynFlags
let src_filename = ms_hspp_file mod_summary let src_filename = ms_hspp_file mod_summary
maybe_src_buf = ms_hspp_buf mod_summary maybe_src_buf = ms_hspp_buf mod_summary
...@@ -1454,7 +1453,7 @@ hscGenHardCode hsc_env cgguts mod_summary output_filename = do ...@@ -1454,7 +1453,7 @@ hscGenHardCode hsc_env cgguts mod_summary output_filename = do
-- top-level function, so showPass isn't very useful here. -- top-level function, so showPass isn't very useful here.
-- Hence we have one showPass for the whole backend, the -- Hence we have one showPass for the whole backend, the
-- next showPass after this will be "Assembler". -- next showPass after this will be "Assembler".
withTiming (pure dflags) withTiming dflags
(text "CodeGen"<+>brackets (ppr this_mod)) (text "CodeGen"<+>brackets (ppr this_mod))
(const ()) $ do (const ()) $ do
cmms <- {-# SCC "StgToCmm" #-} cmms <- {-# SCC "StgToCmm" #-}
...@@ -1851,7 +1850,7 @@ hscParseThing = hscParseThingWithLocation "<interactive>" 1 ...@@ -1851,7 +1850,7 @@ hscParseThing = hscParseThingWithLocation "<interactive>" 1
hscParseThingWithLocation :: (Outputable thing, Data thing) => String -> Int hscParseThingWithLocation :: (Outputable thing, Data thing) => String -> Int
-> Lexer.P thing -> String -> Hsc thing -> Lexer.P thing -> String -> Hsc thing
hscParseThingWithLocation source linenumber parser str hscParseThingWithLocation source linenumber parser str
= withTiming getDynFlags = withTimingD
(text "Parser [source]") (text "Parser [source]")
(const ()) $ {-# SCC "Parser" #-} do (const ()) $ {-# SCC "Parser" #-} do
dflags <- getDynFlags dflags <- getDynFlags
......
...@@ -469,7 +469,7 @@ listPackageConfigMap dflags = eltsUDFM pkg_map ...@@ -469,7 +469,7 @@ listPackageConfigMap dflags = eltsUDFM pkg_map
-- 'pkgState' in 'DynFlags' and return a list of packages to -- 'pkgState' in 'DynFlags' and return a list of packages to
-- link in. -- link in.
initPackages :: DynFlags -> IO (DynFlags, [PreloadUnitId]) initPackages :: DynFlags -> IO (DynFlags, [PreloadUnitId])
initPackages dflags0 = withTiming (return dflags0) initPackages dflags0 = withTiming dflags0
(text "initializing package database") (text "initializing package database")
forcePkgDb $ do forcePkgDb $ do
dflags <- interpretPackageEnv dflags0 dflags <- interpretPackageEnv dflags0
......
...@@ -371,4 +371,4 @@ touch dflags purpose arg = traceToolCommand dflags "touch" $ ...@@ -371,4 +371,4 @@ touch dflags purpose arg = traceToolCommand dflags "touch" $
-- to run GHC with @-v2@ or @-ddump-timings@. -- to run GHC with @-v2@ or @-ddump-timings@.
traceToolCommand :: DynFlags -> String -> IO a -> IO a traceToolCommand :: DynFlags -> String -> IO a -> IO a
traceToolCommand dflags tool = withTiming traceToolCommand dflags tool = withTiming
(return dflags) (text $ "systool:" ++ tool) (const ()) dflags (text $ "systool:" ++ tool) (const ())
...@@ -145,7 +145,7 @@ mkBootModDetailsTc hsc_env ...@@ -145,7 +145,7 @@ mkBootModDetailsTc hsc_env
} }
= -- This timing isn't terribly useful since the result isn't forced, but = -- This timing isn't terribly useful since the result isn't forced, but
-- the message is useful to locating oneself in the compilation process. -- the message is useful to locating oneself in the compilation process.
Err.withTiming (pure dflags) Err.withTiming dflags
(text "CoreTidy"<+>brackets (ppr this_mod)) (text "CoreTidy"<+>brackets (ppr this_mod))
(const ()) $ (const ()) $
return (ModDetails { md_types = type_env' return (ModDetails { md_types = type_env'
...@@ -341,7 +341,7 @@ tidyProgram hsc_env (ModGuts { mg_module = mod ...@@ -341,7 +341,7 @@ tidyProgram hsc_env (ModGuts { mg_module = mod
, mg_modBreaks = modBreaks , mg_modBreaks = modBreaks
}) })
= Err.withTiming (pure dflags) = Err.withTiming dflags
(text "CoreTidy"<+>brackets (ppr mod)) (text "CoreTidy"<+>brackets (ppr mod))
(const ()) $ (const ()) $
do { let { omit_prags = gopt Opt_OmitInterfacePragmas dflags do { let { omit_prags = gopt Opt_OmitInterfacePragmas dflags
......
...@@ -335,7 +335,7 @@ finishNativeGen :: Instruction instr ...@@ -335,7 +335,7 @@ finishNativeGen :: Instruction instr
-> NativeGenAcc statics instr -> NativeGenAcc statics instr
-> IO UniqSupply -> IO UniqSupply
finishNativeGen dflags modLoc bufh@(BufHandle _ _ h) us ngs 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 -- Write debug data and finish
let emitDw = debugLevel dflags > 0 let emitDw = debugLevel dflags > 0
us' <- if not emitDw then return us else do us' <- if not emitDw then return us else do
...@@ -404,7 +404,7 @@ cmmNativeGenStream dflags this_mod modLoc ncgImpl h us cmm_stream ngs ...@@ -404,7 +404,7 @@ cmmNativeGenStream dflags this_mod modLoc ncgImpl h us cmm_stream ngs
Right (cmms, cmm_stream') -> do Right (cmms, cmm_stream') -> do
(us', ngs'') <- (us', ngs'') <-
withTimingSilent withTimingSilent
(return dflags) dflags
ncglabel (\(a, b) -> a `seq` b `seq` ()) $ do ncglabel (\(a, b) -> a `seq` b `seq` ()) $ do
-- Generate debug information -- Generate debug information
let debugFlag = debugLevel dflags > 0 let debugFlag = debugLevel dflags > 0
......
...@@ -36,7 +36,7 @@ import FloatIn ( floatInwards ) ...@@ -36,7 +36,7 @@ import FloatIn ( floatInwards )
import FloatOut ( floatOutwards ) import FloatOut ( floatOutwards )
import FamInstEnv import FamInstEnv
import Id import Id
import ErrUtils ( withTiming ) import ErrUtils ( withTiming, withTimingD )
import BasicTypes ( CompilerPhase(..), isDefaultInlinePragma, defaultInlinePragma ) import BasicTypes ( CompilerPhase(..), isDefaultInlinePragma, defaultInlinePragma )
import VarSet import VarSet
import VarEnv import VarEnv
...@@ -410,10 +410,9 @@ runCorePasses passes guts ...@@ -410,10 +410,9 @@ runCorePasses passes guts
where where
do_pass guts CoreDoNothing = return guts do_pass guts CoreDoNothing = return guts
do_pass guts (CoreDoPasses ps) = runCorePasses ps guts do_pass guts (CoreDoPasses ps) = runCorePasses ps guts
do_pass guts pass do_pass guts pass = do
= withTiming getDynFlags withTimingD (ppr pass <+> brackets (ppr mod))
(ppr pass <+> brackets (ppr mod)) (const ()) $ do
(const ()) $ do
{ guts' <- lintAnnots (ppr pass) (doCorePass pass) guts { guts' <- lintAnnots (ppr pass) (doCorePass pass) guts
; endPass pass (mg_binds guts') (mg_rules guts') ; endPass pass (mg_binds guts') (mg_rules guts')
; return guts' } ; return guts' }
...@@ -484,9 +483,8 @@ printCore dflags binds ...@@ -484,9 +483,8 @@ printCore dflags binds
ruleCheckPass :: CompilerPhase -> String -> ModGuts -> CoreM ModGuts ruleCheckPass :: CompilerPhase -> String -> ModGuts -> CoreM ModGuts
ruleCheckPass current_phase pat guts = ruleCheckPass current_phase pat guts =
withTiming getDynFlags withTimingD (text "RuleCheck"<+>brackets (ppr $ mg_module guts))
(text "RuleCheck"<+>brackets (ppr $ mg_module guts)) (const ()) $ do
(const ()) $ do
{ rb <- getRuleBase { rb <- getRuleBase
; dflags <- getDynFlags ; dflags <- getDynFlags
; vis_orphs <- getVisibleOrphanMods ; vis_orphs <- getVisibleOrphanMods
...@@ -564,7 +562,7 @@ simplifyExpr :: DynFlags -- includes spec of what core-to-core passes to do ...@@ -564,7 +562,7 @@ simplifyExpr :: DynFlags -- includes spec of what core-to-core passes to do
-- --
-- Also used by Template Haskell -- Also used by Template Haskell
simplifyExpr dflags expr simplifyExpr dflags expr
= withTiming (pure dflags) (text "Simplify [expr]") (const ()) $ = withTiming dflags (text "Simplify [expr]") (const ()) $
do { do {
; us <- mkSplitUniqSupply 's' ; us <- mkSplitUniqSupply 's'
......
...@@ -331,7 +331,7 @@ tcRnCheckUnitId :: ...@@ -331,7 +331,7 @@ tcRnCheckUnitId ::
HscEnv -> UnitId -> HscEnv -> UnitId ->