summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--compiler/GHC/StgToCmm.hs2
-rw-r--r--compiler/cmm/CmmInfo.hs2
-rw-r--r--compiler/cmm/CmmParse.y40
-rw-r--r--compiler/cmm/CmmPipeline.hs2
-rw-r--r--compiler/coreSyn/CorePrep.hs4
-rw-r--r--compiler/deSugar/Desugar.hs2
-rw-r--r--compiler/ghci/ByteCodeGen.hs4
-rw-r--r--compiler/iface/LoadIface.hs2
-rw-r--r--compiler/llvmGen/LlvmCodeGen.hs2
-rw-r--r--compiler/llvmGen/LlvmMangler.hs2
-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
-rw-r--r--compiler/nativeGen/AsmCodeGen.hs4
-rw-r--r--compiler/simplCore/SimplCore.hs16
-rw-r--r--compiler/typecheck/TcBackpack.hs6
-rw-r--r--compiler/typecheck/TcRnDriver.hs2
m---------utils/haddock0
22 files changed, 93 insertions, 71 deletions
diff --git a/compiler/GHC/StgToCmm.hs b/compiler/GHC/StgToCmm.hs
index 96fa9e5cc1..f02d361fa4 100644
--- a/compiler/GHC/StgToCmm.hs
+++ b/compiler/GHC/StgToCmm.hs
@@ -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)
diff --git a/compiler/cmm/CmmInfo.hs b/compiler/cmm/CmmInfo.hs
index 82abbb62bd..3ef3d5001e 100644
--- a/compiler/cmm/CmmInfo.hs
+++ b/compiler/cmm/CmmInfo.hs
@@ -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)
diff --git a/compiler/cmm/CmmParse.y b/compiler/cmm/CmmParse.y
index 319286ba5a..3cfb7ecee2 100644
--- a/compiler/cmm/CmmParse.y
+++ b/compiler/cmm/CmmParse.y
@@ -375,8 +375,8 @@ cmm :: { CmmParse () }
cmmtop :: { CmmParse () }
: cmmproc { $1 }
| cmmdata { $1 }
- | decl { $1 }
- | 'CLOSURE' '(' NAME ',' NAME lits ')' ';'
+ | decl { $1 }
+ | 'CLOSURE' '(' NAME ',' NAME lits ')' ';'
{% liftP . withThisPackage $ \pkg ->
do lits <- sequence $6;
staticClosure pkg $3 $5 (map getLit lits) }
@@ -391,30 +391,30 @@ cmmtop :: { CmmParse () }
-- * we can derive closure and info table labels from a single NAME
cmmdata :: { CmmParse () }
- : 'section' STRING '{' data_label statics '}'
+ : 'section' STRING '{' data_label statics '}'
{ do lbl <- $4;
ss <- sequence $5;
code (emitDecl (CmmData (Section (section $2) lbl) (Statics lbl $ concat ss))) }
data_label :: { CmmParse CLabel }
- : NAME ':'
+ : NAME ':'
{% liftP . withThisPackage $ \pkg ->
return (mkCmmDataLabel pkg $1) }
statics :: { [CmmParse [CmmStatic]] }
: {- empty -} { [] }
| static statics { $1 : $2 }
-
+
static :: { CmmParse [CmmStatic] }
: type expr ';' { do e <- $2;
return [CmmStaticLit (getLit e)] }
| type ';' { return [CmmUninitialised
(widthInBytes (typeWidth $1))] }
| 'bits8' '[' ']' STRING ';' { return [mkString $4] }
- | 'bits8' '[' INT ']' ';' { return [CmmUninitialised
+ | 'bits8' '[' INT ']' ';' { return [CmmUninitialised
(fromIntegral $3)] }
- | typenot8 '[' INT ']' ';' { return [CmmUninitialised
- (widthInBytes (typeWidth $1) *
+ | typenot8 '[' INT ']' ';' { return [CmmUninitialised
+ (widthInBytes (typeWidth $1) *
fromIntegral $3)] }
| 'CLOSURE' '(' NAME lits ')'
{ do { lits <- sequence $4
@@ -475,7 +475,7 @@ info :: { CmmParse (CLabel, Maybe CmmInfoTable, [LocalReg]) }
, cit_rep = rep
, cit_prof = prof, cit_srt = Nothing, cit_clo = Nothing },
[]) }
-
+
| 'INFO_TABLE_FUN' '(' NAME ',' INT ',' INT ',' INT ',' STRING ',' STRING ',' INT ')'
-- ptrs, nptrs, closure type, description, type, fun type
{% liftP . withThisPackage $ \pkg ->
@@ -512,7 +512,7 @@ info :: { CmmParse (CLabel, Maybe CmmInfoTable, [LocalReg]) }
-- 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.
-
+
| 'INFO_TABLE_SELECTOR' '(' NAME ',' INT ',' INT ',' STRING ',' STRING ')'
-- selector, closure type, description, type
{% liftP . withThisPackage $ \pkg ->
@@ -575,7 +575,7 @@ importName
-- A label imported without an explicit packageId.
-- These are taken to come frome some foreign, unnamed package.
- : NAME
+ : NAME
{ ($1, mkForeignLabel $1 Nothing ForeignLabelInExternalPackage IsFunction) }
-- as previous 'NAME', but 'IsData'
@@ -585,8 +585,8 @@ importName
-- A label imported with an explicit packageId.
| STRING NAME
{ ($2, mkCmmCodeLabel (fsToUnitId (mkFastString $1)) $2) }
-
-
+
+
names :: { [FastString] }
: NAME { [$1] }
| NAME ',' names { $1 : $3 }
@@ -672,9 +672,9 @@ bool_expr :: { CmmParse BoolExpr }
| expr { do e <- $1; return (BoolTest e) }
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) }
- | bool_expr '||' bool_expr { do e1 <- $1; e2 <- $3;
+ | bool_expr '||' bool_expr { do e1 <- $1; e2 <- $3;
return (BoolOr e1 e2) }
| '!' bool_expr { do e <- $2; return (BoolNot e) }
| '(' bool_op ')' { $2 }
@@ -760,7 +760,7 @@ expr :: { CmmParse CmmExpr }
expr0 :: { CmmParse CmmExpr }
: INT maybe_ty { return (CmmLit (CmmInt $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) }
| reg { $1 }
| type '[' expr ']' { do e <- $3; return (CmmLoad e $1) }
@@ -818,14 +818,14 @@ foreign_formal :: { CmmParse (LocalReg, ForeignHint) }
local_lreg :: { CmmParse LocalReg }
: NAME { do e <- lookupName $1;
return $
- case e of
+ case e of
CmmReg (CmmLocal r) -> r
other -> pprPanic "CmmParse:" (ftext $1 <> text " not a local register") }
lreg :: { CmmParse CmmReg }
: NAME { do e <- lookupName $1;
return $
- case e of
+ case e of
CmmReg r -> r
other -> pprPanic "CmmParse:" (ftext $1 <> text " not a register") }
| GLOBALREG { return (CmmGlobal $1) }
@@ -1376,7 +1376,7 @@ doSwitch :: Maybe (Integer,Integer)
doSwitch mb_range scrut arms deflt
= do
-- Compile code for the default branch
- dflt_entry <-
+ dflt_entry <-
case deflt of
Nothing -> return Nothing
Just e -> do b <- forkLabelledCode e; return (Just 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
diff --git a/compiler/cmm/CmmPipeline.hs b/compiler/cmm/CmmPipeline.hs
index 5ac3fddb3b..071ec9442e 100644
--- a/compiler/cmm/CmmPipeline.hs
+++ b/compiler/cmm/CmmPipeline.hs
@@ -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
diff --git a/compiler/coreSyn/CorePrep.hs b/compiler/coreSyn/CorePrep.hs
index 9d4044cf57..2b68c2716b 100644
--- a/compiler/coreSyn/CorePrep.hs
+++ b/compiler/coreSyn/CorePrep.hs
@@ -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)
diff --git a/compiler/deSugar/Desugar.hs b/compiler/deSugar/Desugar.hs
index 5df52c3df9..5ecc4da00e 100644
--- a/compiler/deSugar/Desugar.hs
+++ b/compiler/deSugar/Desugar.hs
@@ -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
diff --git a/compiler/ghci/ByteCodeGen.hs b/compiler/ghci/ByteCodeGen.hs
index 2ad089903b..b7b0d95217 100644
--- a/compiler/ghci/ByteCodeGen.hs
+++ b/compiler/ghci/ByteCodeGen.hs
@@ -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
diff --git a/compiler/iface/LoadIface.hs b/compiler/iface/LoadIface.hs
index 446477d018..6da6565219 100644
--- a/compiler/iface/LoadIface.hs
+++ b/compiler/iface/LoadIface.hs
@@ -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
diff --git a/compiler/llvmGen/LlvmCodeGen.hs b/compiler/llvmGen/LlvmCodeGen.hs
index b566b99a1f..49b24e8885 100644
--- a/compiler/llvmGen/LlvmCodeGen.hs
+++ b/compiler/llvmGen/LlvmCodeGen.hs
@@ -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
diff --git a/compiler/llvmGen/LlvmMangler.hs b/compiler/llvmGen/LlvmMangler.hs
index 114951946c..8215781860 100644
--- a/compiler/llvmGen/LlvmMangler.hs
+++ b/compiler/llvmGen/LlvmMangler.hs
@@ -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
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
diff --git a/compiler/nativeGen/AsmCodeGen.hs b/compiler/nativeGen/AsmCodeGen.hs
index 4c883e7185..56a2258f27 100644
--- a/compiler/nativeGen/AsmCodeGen.hs
+++ b/compiler/nativeGen/AsmCodeGen.hs
@@ -334,7 +334,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
@@ -403,7 +403,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
diff --git a/compiler/simplCore/SimplCore.hs b/compiler/simplCore/SimplCore.hs
index b3af87b2af..cbfa757552 100644
--- a/compiler/simplCore/SimplCore.hs
+++ b/compiler/simplCore/SimplCore.hs
@@ -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,10 +410,9 @@ 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))
- (const ()) $ do
+ 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')
; return guts' }
@@ -484,9 +483,8 @@ printCore dflags binds
ruleCheckPass :: CompilerPhase -> String -> ModGuts -> CoreM ModGuts
ruleCheckPass current_phase pat guts =
- withTiming getDynFlags
- (text "RuleCheck"<+>brackets (ppr $ mg_module guts))
- (const ()) $ do
+ withTimingD (text "RuleCheck"<+>brackets (ppr $ mg_module guts))
+ (const ()) $ do
{ rb <- getRuleBase
; dflags <- getDynFlags
; vis_orphs <- getVisibleOrphanMods
@@ -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'
diff --git a/compiler/typecheck/TcBackpack.hs b/compiler/typecheck/TcBackpack.hs
index 17c9ac7e80..fccc373368 100644
--- a/compiler/typecheck/TcBackpack.hs
+++ b/compiler/typecheck/TcBackpack.hs
@@ -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
diff --git a/compiler/typecheck/TcRnDriver.hs b/compiler/typecheck/TcRnDriver.hs
index 000455bd3f..4d1d32f8a5 100644
--- a/compiler/typecheck/TcRnDriver.hs
+++ b/compiler/typecheck/TcRnDriver.hs
@@ -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 $
diff --git a/utils/haddock b/utils/haddock
-Subproject a7c42a29f7c33f5fdbb04acc3866ec907c2e00f
+Subproject f0b5a2043ff6c527e55fab228d37ee698ce8726
View Lorry Controller Status