summaryrefslogtreecommitdiff
path: root/compiler/main
diff options
context:
space:
mode:
Diffstat (limited to 'compiler/main')
-rw-r--r--compiler/main/CodeOutput.hs4
-rw-r--r--compiler/main/ErrUtils.hs51
-rw-r--r--compiler/main/GhcMake.hs2
-rw-r--r--compiler/main/HscMain.hs9
-rw-r--r--compiler/main/Packages.hs2
-rw-r--r--compiler/main/SysTools/Tasks.hs2
-rw-r--r--compiler/main/TidyPgm.hs4
7 files changed, 49 insertions, 25 deletions
diff --git a/compiler/main/CodeOutput.hs b/compiler/main/CodeOutput.hs
index 96a754d6f0..01d714d57a 100644
--- a/compiler/main/CodeOutput.hs
+++ b/compiler/main/CodeOutput.hs
@@ -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:
--
diff --git a/compiler/main/ErrUtils.hs b/compiler/main/ErrUtils.hs
index ba94ec0c50..f0fa1441f9 100644
--- a/compiler/main/ErrUtils.hs
+++ b/compiler/main/ErrUtils.hs
@@ -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
diff --git a/compiler/main/GhcMake.hs b/compiler/main/GhcMake.hs
index f1fb933753..6599da07f4 100644
--- a/compiler/main/GhcMake.hs
+++ b/compiler/main/GhcMake.hs
@@ -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))])
diff --git a/compiler/main/HscMain.hs b/compiler/main/HscMain.hs
index b21609bbc5..8cbc394f33 100644
--- a/compiler/main/HscMain.hs
+++ b/compiler/main/HscMain.hs
@@ -331,9 +331,8 @@ 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))
- (const ()) $ do
+ withTimingD (text "Parser"<+>brackets (ppr $ ms_mod mod_summary))
+ (const ()) $ do
dflags <- getDynFlags
let src_filename = ms_hspp_file mod_summary
maybe_src_buf = ms_hspp_buf 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
diff --git a/compiler/main/Packages.hs b/compiler/main/Packages.hs
index ccf42c588c..ca2e74dfcf 100644
--- a/compiler/main/Packages.hs
+++ b/compiler/main/Packages.hs
@@ -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
diff --git a/compiler/main/SysTools/Tasks.hs b/compiler/main/SysTools/Tasks.hs
index 838ab64717..5b0cb1cfa2 100644
--- a/compiler/main/SysTools/Tasks.hs
+++ b/compiler/main/SysTools/Tasks.hs
@@ -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 ())
diff --git a/compiler/main/TidyPgm.hs b/compiler/main/TidyPgm.hs
index c0c6ffc3c3..f0dbc6734b 100644
--- a/compiler/main/TidyPgm.hs
+++ b/compiler/main/TidyPgm.hs
@@ -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
View Lorry Controller Status