From fb40d415b947805ac33690f63317dd3b8c3e85d6 Mon Sep 17 00:00:00 2001 From: Ben Gamari Date: Wed, 23 Mar 2016 16:11:45 +0100 Subject: ErrUtils: Add timings to compiler phases This adds timings and allocation figures to the compiler's output when run with `-v2` in an effort to ease performance analysis. Todo: * Documentation * Where else should we add these? * Perhaps we should remove some of the now-arguably-redundant `showPass` occurrences where they are * Must we force more? * Perhaps we should place this behind a `-ftimings` instead of `-v2` Test Plan: `ghc -v2 Test.hs`, look at the output Reviewers: hvr, goldfire, simonmar, austin Reviewed By: simonmar Subscribers: angerman, michalt, niteria, ezyang, thomie Differential Revision: https://phabricator.haskell.org/D1959 (cherry picked from commit 8048d51be0676627b417c128af0b0c352b75c537) --- compiler/cmm/CmmParse.y | 3 +- compiler/coreSyn/CoreLint.hs | 9 +----- compiler/coreSyn/CorePrep.hs | 16 ++++++---- compiler/deSugar/Desugar.hs | 9 +++--- compiler/ghci/ByteCodeGen.hs | 8 +++-- compiler/llvmGen/LlvmCodeGen.hs | 3 +- compiler/llvmGen/LlvmMangler.hs | 7 +++-- compiler/main/CodeOutput.hs | 7 +++-- compiler/main/ErrUtils.hs | 58 +++++++++++++++++++++++++++++++++++- compiler/main/GhcMake.hs | 19 ++++++------ compiler/main/HscMain.hs | 63 +++++++++++++++++++++------------------- compiler/main/TidyPgm.hs | 23 ++++++++++----- compiler/simplCore/SimplCore.hs | 31 +++++++++++--------- compiler/typecheck/TcRnDriver.hs | 12 ++++---- compiler/utils/Outputable.hs | 8 ++++- docs/users_guide/debugging.xml | 10 ++++++- 16 files changed, 189 insertions(+), 97 deletions(-) diff --git a/compiler/cmm/CmmParse.y b/compiler/cmm/CmmParse.y index fd9489bd7f..0b040525a3 100644 --- a/compiler/cmm/CmmParse.y +++ b/compiler/cmm/CmmParse.y @@ -1362,8 +1362,7 @@ initEnv dflags = listToUFM [ ] parseCmmFile :: DynFlags -> FilePath -> IO (Messages, Maybe CmmGroup) -parseCmmFile dflags filename = do - showPass dflags "ParseCmm" +parseCmmFile dflags filename = withTiming (pure dflags) (text "ParseCmm"<+>brackets (text filename)) (\_ -> ()) $ do buf <- hGetStringBuffer filename let init_loc = mkRealSrcLoc (mkFastString filename) 1 1 diff --git a/compiler/coreSyn/CoreLint.hs b/compiler/coreSyn/CoreLint.hs index adac6b8ae0..9fc00985bf 100644 --- a/compiler/coreSyn/CoreLint.hs +++ b/compiler/coreSyn/CoreLint.hs @@ -15,7 +15,7 @@ module CoreLint ( lintAnnots, -- ** Debug output - CoreLint.showPass, showPassIO, endPass, endPassIO, + endPass, endPassIO, dumpPassResult, CoreLint.dumpIfSet, ) where @@ -134,13 +134,6 @@ be, and it makes a conveneint place. place for them. They print out stuff before and after core passes, and do Core Lint when necessary. -} -showPass :: CoreToDo -> CoreM () -showPass pass = do { dflags <- getDynFlags - ; liftIO $ showPassIO dflags pass } - -showPassIO :: DynFlags -> CoreToDo -> IO () -showPassIO dflags pass = Err.showPass dflags (showPpr dflags pass) - endPass :: CoreToDo -> CoreProgram -> [CoreRule] -> CoreM () endPass pass binds rules = do { hsc_env <- getHscEnv diff --git a/compiler/coreSyn/CorePrep.hs b/compiler/coreSyn/CorePrep.hs index 924dfb4825..88ed7898b7 100644 --- a/compiler/coreSyn/CorePrep.hs +++ b/compiler/coreSyn/CorePrep.hs @@ -164,10 +164,12 @@ type CpeRhs = CoreExpr -- Non-terminal 'rhs' ************************************************************************ -} -corePrepPgm :: HscEnv -> ModLocation -> CoreProgram -> [TyCon] -> IO CoreProgram -corePrepPgm hsc_env mod_loc binds data_tycons = do - let dflags = hsc_dflags hsc_env - showPass dflags "CorePrep" +corePrepPgm :: HscEnv -> Module -> ModLocation -> CoreProgram -> [TyCon] + -> IO CoreProgram +corePrepPgm hsc_env this_mod mod_loc binds data_tycons = + withTiming (pure dflags) + (text "CorePrep"<+>brackets (ppr this_mod)) + (const ()) $ do us <- mkSplitUniqSupply 's' initialCorePrepEnv <- mkInitialCorePrepEnv dflags hsc_env @@ -182,10 +184,12 @@ corePrepPgm hsc_env mod_loc binds data_tycons = do endPassIO hsc_env alwaysQualify CorePrep binds_out [] return binds_out + where + dflags = hsc_dflags hsc_env corePrepExpr :: DynFlags -> HscEnv -> CoreExpr -> IO CoreExpr -corePrepExpr dflags hsc_env expr = do - showPass dflags "CorePrep" +corePrepExpr dflags hsc_env expr = + withTiming (pure 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 e4181b9bdb..23785b4aec 100644 --- a/compiler/deSugar/Desugar.hs +++ b/compiler/deSugar/Desugar.hs @@ -96,9 +96,10 @@ deSugar hsc_env = do { let dflags = hsc_dflags hsc_env print_unqual = mkPrintUnqualified dflags rdr_env - ; showPass dflags "Desugar" - - -- Desugar the program + ; withTiming (pure dflags) + (text "Desugar"<+>brackets (ppr mod)) + (const ()) $ + do { -- Desugar the program ; let export_set = availsToNameSet exports target = hscTarget dflags hpcInfo = emptyHpcInfo other_hpc_info @@ -196,7 +197,7 @@ deSugar hsc_env mg_dependent_files = dep_files } ; return (msgs, Just mod_guts) - }}} + }}}} dsImpSpecs :: [LTcSpecPrag] -> DsM (OrdList (Id,CoreExpr), [CoreRule]) dsImpSpecs imp_specs diff --git a/compiler/ghci/ByteCodeGen.hs b/compiler/ghci/ByteCodeGen.hs index de5b84e464..a2d1fc270a 100644 --- a/compiler/ghci/ByteCodeGen.hs +++ b/compiler/ghci/ByteCodeGen.hs @@ -75,7 +75,9 @@ byteCodeGen :: DynFlags -> ModBreaks -> IO CompiledByteCode byteCodeGen dflags this_mod binds tycs modBreaks - = do showPass dflags "ByteCodeGen" + = withTiming (pure dflags) + (text "ByteCodeGen"<+>brackets (ppr this_mod)) + (const ()) $ do let flatBinds = [ (bndr, freeVars rhs) | (bndr, rhs) <- flattenBinds binds] @@ -102,7 +104,9 @@ coreExprToBCOs :: DynFlags -> CoreExpr -> IO UnlinkedBCO coreExprToBCOs dflags this_mod expr - = do showPass dflags "ByteCodeGen" + = withTiming (pure dflags) + (text "ByteCodeGen"<+>brackets (ppr this_mod)) + (const ()) $ do -- create a totally bogus name for the top-level BCO; this -- should be harmless, since it's never used for anything diff --git a/compiler/llvmGen/LlvmCodeGen.hs b/compiler/llvmGen/LlvmCodeGen.hs index 6120a72d3a..6dc468c185 100644 --- a/compiler/llvmGen/LlvmCodeGen.hs +++ b/compiler/llvmGen/LlvmCodeGen.hs @@ -41,7 +41,8 @@ llvmCodeGen :: DynFlags -> Handle -> UniqSupply -> Stream.Stream IO RawCmmGroup () -> IO () llvmCodeGen dflags h us cmm_stream - = do bufh <- newBufHandle h + = withTiming (pure dflags) (text "LLVM CodeGen") (const ()) $ do + bufh <- newBufHandle h -- Pass header showPass dflags "LLVM CodeGen" diff --git a/compiler/llvmGen/LlvmMangler.hs b/compiler/llvmGen/LlvmMangler.hs index 8652a890cf..3f838b1fa2 100644 --- a/compiler/llvmGen/LlvmMangler.hs +++ b/compiler/llvmGen/LlvmMangler.hs @@ -10,8 +10,9 @@ module LlvmMangler ( llvmFixupAsm ) where import DynFlags ( DynFlags ) -import ErrUtils ( showPass ) +import ErrUtils ( withTiming ) import LlvmCodeGen.Ppr ( infoSection ) +import Outputable ( text ) import Control.Exception import Control.Monad ( when ) @@ -47,8 +48,8 @@ type Section = (B.ByteString, B.ByteString) -- | Read in assembly file and process llvmFixupAsm :: DynFlags -> FilePath -> FilePath -> IO () -llvmFixupAsm dflags f1 f2 = {-# SCC "llvm_mangler" #-} do - showPass dflags "LLVM Mangler" +llvmFixupAsm dflags f1 f2 = {-# SCC "llvm_mangler" #-} + withTiming (pure dflags) (text "LLVM Mangler") id $ do r <- openBinaryFile f1 ReadMode w <- openBinaryFile f2 WriteMode ss <- readSections r w diff --git a/compiler/main/CodeOutput.hs b/compiler/main/CodeOutput.hs index f55a15a842..2e10b23a9d 100644 --- a/compiler/main/CodeOutput.hs +++ b/compiler/main/CodeOutput.hs @@ -64,9 +64,10 @@ codeOutput dflags this_mod filenm location foreign_stubs pkg_deps cmm_stream then Stream.mapM do_lint cmm_stream else cmm_stream - do_lint cmm = do - { showPass dflags "CmmLint" - ; case cmmLint dflags cmm of + do_lint cmm = withTiming (pure dflags) + (text "CmmLint"<+>brackets (ppr this_mod)) + (const ()) $ do + { case cmmLint dflags cmm of Just err -> do { log_action dflags dflags SevDump noSrcSpan defaultDumpStyle err ; ghcExit dflags 1 } diff --git a/compiler/main/ErrUtils.hs b/compiler/main/ErrUtils.hs index 2a3b4c78ab..7d601409d2 100644 --- a/compiler/main/ErrUtils.hs +++ b/compiler/main/ErrUtils.hs @@ -5,6 +5,7 @@ -} {-# LANGUAGE CPP #-} +{-# LANGUAGE BangPatterns #-} module ErrUtils ( MsgDoc, @@ -32,7 +33,7 @@ module ErrUtils ( errorMsg, warningMsg, fatalErrorMsg, fatalErrorMsg', fatalErrorMsg'', compilationProgressMsg, - showPass, + showPass, withTiming, debugTraceMsg, prettyPrintGhcErrors, @@ -59,6 +60,8 @@ import Data.Time import Control.Monad import Control.Monad.IO.Class import System.IO +import GHC.Conc ( getAllocationCounter ) +import System.CPUTime ------------------------- type MsgDoc = SDoc @@ -396,6 +399,59 @@ showPass dflags what = ifVerbose dflags 2 $ logInfo dflags defaultUserStyle (text "***" <+> text what <> colon) +-- | Time a compilation phase. +-- +-- When timings are enabled (e.g. with the @-v2@ flag), the allocations +-- and CPU time used by the phase will be reported to stderr. Consider +-- a typical usage: @withTiming getDynFlags (text "simplify") force pass@. +-- When timings are enabled the following costs are included in the +-- produced accounting, +-- +-- - The cost of executing @pass@ to a result @r@ in WHNF +-- - The cost of evaluating @force r@ to WHNF (e.g. @()@) +-- +-- The choice of the @force@ function depends upon the amount of forcing +-- desired; the goal here is to ensure that the cost of evaluating the result +-- is, to the greatest extent possible, included in the accounting provided by +-- 'withTiming'. Often the pass already sufficiently forces its result during +-- construction; in this case @const ()@ is a reasonable choice. +-- In other cases, it is necessary to evaluate the result to normal form, in +-- which case something like @Control.DeepSeq.rnf@ is appropriate. +-- +-- To avoid adversely affecting compiler performance when timings are not +-- requested, the result is only forced when timings are enabled. +withTiming :: MonadIO m + => m 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 + -- (often either @const ()@ or 'rnf') + -> m a -- ^ The body of the phase to be timed + -> m a +withTiming getDFlags what force_result action + = do dflags <- getDFlags + if verbosity dflags >= 2 + then do liftIO $ logInfo dflags defaultUserStyle + $ text "***" <+> what <> colon + alloc0 <- liftIO getAllocationCounter + start <- liftIO getCPUTime + !r <- action + () <- pure $ force_result r + end <- liftIO getCPUTime + alloc1 <- liftIO getAllocationCounter + -- recall that allocation counter counts down + let alloc = alloc0 - alloc1 + liftIO $ logInfo dflags defaultUserStyle + (text "!!!" <+> what <> colon <+> text "finished in" + <+> doublePrec 2 (realToFrac (end - start) * 1e-9) + <+> text "milliseconds" + <> comma + <+> text "allocated" + <+> doublePrec 3 (realToFrac alloc / 1024 / 1024) + <+> text "megabytes") + pure r + else action + debugTraceMsg :: DynFlags -> Int -> MsgDoc -> IO () debugTraceMsg dflags val msg = ifVerbose dflags val $ logInfo dflags defaultDumpStyle msg diff --git a/compiler/main/GhcMake.hs b/compiler/main/GhcMake.hs index 5f3e31545f..e48e50618c 100644 --- a/compiler/main/GhcMake.hs +++ b/compiler/main/GhcMake.hs @@ -112,15 +112,16 @@ depanal excluded_mods allow_dup_roots = do targets = hsc_targets hsc_env old_graph = hsc_mod_graph hsc_env - liftIO $ showPass dflags "Chasing dependencies" - liftIO $ debugTraceMsg dflags 2 (hcat [ - text "Chasing modules from: ", - hcat (punctuate comma (map pprTarget targets))]) - - mod_graphE <- liftIO $ downsweep hsc_env old_graph excluded_mods allow_dup_roots - mod_graph <- reportImportErrors mod_graphE - modifySession $ \_ -> hsc_env { hsc_mod_graph = mod_graph } - return mod_graph + withTiming (pure dflags) (text "Chasing dependencies") (const ()) $ do + liftIO $ debugTraceMsg dflags 2 (hcat [ + text "Chasing modules from: ", + hcat (punctuate comma (map pprTarget targets))]) + + mod_graphE <- liftIO $ downsweep hsc_env old_graph + excluded_mods allow_dup_roots + mod_graph <- reportImportErrors mod_graphE + modifySession $ \_ -> hsc_env { hsc_mod_graph = mod_graph } + return mod_graph -- | Describes which modules of the module graph need to be loaded. data LoadHowMuch diff --git a/compiler/main/HscMain.hs b/compiler/main/HscMain.hs index ecc4a29971..7320658d54 100644 --- a/compiler/main/HscMain.hs +++ b/compiler/main/HscMain.hs @@ -318,15 +318,15 @@ hscParse hsc_env mod_summary = runHsc hsc_env $ hscParse' mod_summary -- internal version, that doesn't fail due to -Werror hscParse' :: ModSummary -> Hsc HsParsedModule -hscParse' mod_summary = do +hscParse' mod_summary = {-# SCC "Parser" #-} + withTiming getDynFlags + (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 -------------------------- Parser ---------------- - liftIO $ showPass dflags "Parser" - {-# SCC "Parser" #-} do - -- sometimes we already have the buffer in memory, perhaps -- because we needed to parse the imports out of it, or get the -- module name. @@ -1212,7 +1212,8 @@ hscGenHardCode hsc_env cgguts mod_summary output_filename = do -- PREPARE FOR CODE GENERATION -- Do saturation and convert to A-normal form prepd_binds <- {-# SCC "CorePrep" #-} - corePrepPgm hsc_env location core_binds data_tycons ; + corePrepPgm hsc_env this_mod location + core_binds data_tycons ----------------- Convert to STG ------------------ (stg_binds, cost_centre_info) <- {-# SCC "CoreToStg" #-} @@ -1228,27 +1229,28 @@ 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". - showPass dflags "CodeGen" - - cmms <- {-# SCC "StgCmm" #-} - doCodeGen hsc_env this_mod data_tycons - cost_centre_info - stg_binds hpc_info - - ------------------ Code output ----------------------- - rawcmms0 <- {-# SCC "cmmToRawCmm" #-} - cmmToRawCmm dflags cmms - - let dump a = do dumpIfSet_dyn dflags Opt_D_dump_cmm_raw "Raw Cmm" - (ppr a) - return a - rawcmms1 = Stream.mapM dump rawcmms0 - - (output_filename, (_stub_h_exists, stub_c_exists)) - <- {-# SCC "codeOutput" #-} - codeOutput dflags this_mod output_filename location - foreign_stubs dependencies rawcmms1 - return (output_filename, stub_c_exists) + withTiming (pure dflags) + (text "CodeGen"<+>brackets (ppr this_mod)) + (const ()) $ do + cmms <- {-# SCC "StgCmm" #-} + doCodeGen hsc_env this_mod data_tycons + cost_centre_info + stg_binds hpc_info + + ------------------ Code output ----------------------- + rawcmms0 <- {-# SCC "cmmToRawCmm" #-} + cmmToRawCmm dflags cmms + + let dump a = do dumpIfSet_dyn dflags Opt_D_dump_cmm_raw "Raw Cmm" + (ppr a) + return a + rawcmms1 = Stream.mapM dump rawcmms0 + + (output_filename, (_stub_h_exists, stub_c_exists)) + <- {-# SCC "codeOutput" #-} + codeOutput dflags this_mod output_filename location + foreign_stubs dependencies rawcmms1 + return (output_filename, stub_c_exists) hscInteractive :: HscEnv @@ -1275,7 +1277,7 @@ hscInteractive hsc_env cgguts mod_summary = do -- PREPARE FOR CODE GENERATION -- Do saturation and convert to A-normal form prepd_binds <- {-# SCC "CorePrep" #-} - corePrepPgm hsc_env location core_binds data_tycons + corePrepPgm hsc_env this_mod location core_binds data_tycons ----------------- Generate byte code ------------------ comp_bc <- byteCodeGen dflags this_mod prepd_binds data_tycons mod_breaks ------------------ Create f-x-dynamic C-side stuff --- @@ -1501,7 +1503,7 @@ hscDeclsWithLocation hsc_env0 str source linenumber = {- Prepare For Code Generation -} -- Do saturation and convert to A-normal form prepd_binds <- {-# SCC "CorePrep" #-} - liftIO $ corePrepPgm hsc_env iNTERACTIVELoc core_binds data_tycons + liftIO $ corePrepPgm hsc_env this_mod iNTERACTIVELoc core_binds data_tycons {- Generate byte code -} cbc <- liftIO $ byteCodeGen dflags this_mod @@ -1588,9 +1590,10 @@ hscParseThing = hscParseThingWithLocation "" 1 hscParseThingWithLocation :: (Outputable thing) => String -> Int -> Lexer.P thing -> String -> Hsc thing hscParseThingWithLocation source linenumber parser str - = {-# SCC "Parser" #-} do + = withTiming getDynFlags + (text "Parser [source]") + (const ()) $ {-# SCC "Parser" #-} do dflags <- getDynFlags - liftIO $ showPass dflags "Parser" let buf = stringToStringBuffer str loc = mkRealSrcLoc (fsLit source) linenumber 1 diff --git a/compiler/main/TidyPgm.hs b/compiler/main/TidyPgm.hs index a616dde373..54ad242624 100644 --- a/compiler/main/TidyPgm.hs +++ b/compiler/main/TidyPgm.hs @@ -138,12 +138,15 @@ mkBootModDetailsTc hsc_env tcg_tcs = tcs, tcg_patsyns = pat_syns, tcg_insts = insts, - tcg_fam_insts = fam_insts + tcg_fam_insts = fam_insts, + tcg_mod = this_mod } - = do { let dflags = hsc_dflags hsc_env - ; showPassIO dflags CoreTidy - - ; let { insts' = map (tidyClsInstDFun globaliseAndTidyId) insts + = -- 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) + (text "CoreTidy"<+>brackets (ppr this_mod)) + (const ()) $ + do { let { insts' = map (tidyClsInstDFun globaliseAndTidyId) insts ; type_env1 = mkBootTypeEnv (availsToNameSet exports) (typeEnvIds type_env) tcs fam_insts ; pat_syns' = map (tidyPatSynIds globaliseAndTidyId) pat_syns @@ -161,6 +164,7 @@ mkBootModDetailsTc hsc_env }) } where + dflags = hsc_dflags hsc_env mkBootTypeEnv :: NameSet -> [Id] -> [TyCon] -> [FamInst] -> TypeEnv mkBootTypeEnv exports ids tcs fam_insts @@ -316,12 +320,13 @@ tidyProgram hsc_env (ModGuts { mg_module = mod , mg_modBreaks = modBreaks }) - = do { let { dflags = hsc_dflags hsc_env - ; omit_prags = gopt Opt_OmitInterfacePragmas dflags + = Err.withTiming (pure dflags) + (text "CoreTidy"<+>brackets (ppr mod)) + (const ()) $ + do { let { omit_prags = gopt Opt_OmitInterfacePragmas dflags ; expose_all = gopt Opt_ExposeAllUnfoldings dflags ; print_unqual = mkPrintUnqualified dflags rdr_env } - ; showPassIO dflags CoreTidy ; let { type_env = typeEnvFromEntities [] tcs fam_insts @@ -415,6 +420,8 @@ tidyProgram hsc_env (ModGuts { mg_module = mod md_anns = anns -- are already tidy }) } + where + dflags = hsc_dflags hsc_env lookup_aux_id :: TypeEnv -> Var -> Id lookup_aux_id type_env id diff --git a/compiler/simplCore/SimplCore.hs b/compiler/simplCore/SimplCore.hs index 4789160120..cd91a6f2ae 100644 --- a/compiler/simplCore/SimplCore.hs +++ b/compiler/simplCore/SimplCore.hs @@ -21,7 +21,7 @@ import OccurAnal ( occurAnalysePgm, occurAnalyseExpr ) import IdInfo import CoreUtils ( coreBindsSize, coreBindsStats, exprSize, mkTicks, stripTicksTop ) -import CoreLint ( showPass, endPass, lintPassResult, dumpPassResult, +import CoreLint ( endPass, lintPassResult, dumpPassResult, lintAnnots ) import Simplify ( simplTopBinds, simplExpr, simplRules ) import SimplUtils ( simplEnvForGHCi, activeRule ) @@ -33,6 +33,7 @@ import FloatIn ( floatInwards ) import FloatOut ( floatOutwards ) import FamInstEnv import Id +import ErrUtils ( withTiming ) import BasicTypes ( CompilerPhase(..), isDefaultInlinePragma ) import VarSet import VarEnv @@ -342,11 +343,15 @@ runCorePasses passes guts do_pass guts CoreDoNothing = return guts do_pass guts (CoreDoPasses ps) = runCorePasses ps guts do_pass guts pass - = do { showPass pass - ; guts' <- lintAnnots (ppr pass) (doCorePass pass) guts + = withTiming getDynFlags + (ppr pass <+> brackets (ppr mod)) + (const ()) $ do + { guts' <- lintAnnots (ppr pass) (doCorePass pass) guts ; endPass pass (mg_binds guts') (mg_rules guts') ; return guts' } + mod = mg_module guts + doCorePass :: CoreToDo -> ModGuts -> CoreM ModGuts doCorePass pass@(CoreDoSimplify {}) = {-# SCC "Simplify" #-} simplifyPgm pass @@ -408,14 +413,15 @@ printCore dflags binds = Err.dumpIfSet dflags True "Print Core" (pprCoreBindings binds) ruleCheckPass :: CompilerPhase -> String -> ModGuts -> CoreM ModGuts -ruleCheckPass current_phase pat guts = do - rb <- getRuleBase - dflags <- getDynFlags - liftIO $ Err.showPass dflags "RuleCheck" - liftIO $ log_action dflags dflags Err.SevDump noSrcSpan defaultDumpStyle +ruleCheckPass current_phase pat guts = + withTiming getDynFlags + (text "RuleCheck"<+>brackets (ppr $ mg_module guts)) + (const ()) $ do + { rb <- getRuleBase + ; dflags <- getDynFlags + ; liftIO $ log_action dflags dflags Err.SevDump noSrcSpan defaultDumpStyle (ruleCheckProgram current_phase pat rb (mg_binds guts)) - return guts - + ; return guts } doPassDUM :: (DynFlags -> UniqSupply -> CoreProgram -> IO CoreProgram) -> ModGuts -> CoreM ModGuts doPassDUM do_pass = doPassM $ \binds -> do @@ -483,9 +489,8 @@ simplifyExpr :: DynFlags -- includes spec of what core-to-core passes to do -- -- Also used by Template Haskell simplifyExpr dflags expr - = do { - ; Err.showPass dflags "Simplify" - + = withTiming (pure dflags) (text "Simplify [expr]") (const ()) $ + do { ; us <- mkSplitUniqSupply 's' ; let sz = exprSize expr diff --git a/compiler/typecheck/TcRnDriver.hs b/compiler/typecheck/TcRnDriver.hs index fe319d05e0..01681b51f9 100644 --- a/compiler/typecheck/TcRnDriver.hs +++ b/compiler/typecheck/TcRnDriver.hs @@ -124,16 +124,18 @@ tcRnModule :: HscEnv tcRnModule hsc_env hsc_src save_rn_syntax parsedModule@HsParsedModule {hpm_module=L loc this_module} | RealSrcSpan real_loc <- loc - = do { showPass (hsc_dflags hsc_env) "Renamer/typechecker" ; - - ; initTc hsc_env hsc_src save_rn_syntax this_mod real_loc $ - withTcPlugins hsc_env $ - tcRnModuleTcRnM hsc_env hsc_src parsedModule pair } + = withTiming (pure dflags) + (text "Renamer/typechecker"<+>brackets (ppr this_mod)) + (const ()) $ + initTc hsc_env hsc_src save_rn_syntax this_mod real_loc $ + withTcPlugins hsc_env $ + tcRnModuleTcRnM hsc_env hsc_src parsedModule pair | otherwise = return ((emptyBag, unitBag err_msg), Nothing) where + dflags = hsc_dflags hsc_env err_msg = mkPlainErrMsg (hsc_dflags hsc_env) loc $ text "Module does not have a RealSrcSpan:" <+> ppr this_mod diff --git a/compiler/utils/Outputable.hs b/compiler/utils/Outputable.hs index e350de93b1..eb30010917 100644 --- a/compiler/utils/Outputable.hs +++ b/compiler/utils/Outputable.hs @@ -20,7 +20,7 @@ module Outputable ( empty, nest, char, text, ftext, ptext, ztext, - int, intWithCommas, integer, float, double, rational, + int, intWithCommas, integer, float, double, rational, doublePrec, parens, cparen, brackets, braces, quotes, quote, doubleQuotes, angleBrackets, paBrackets, semi, comma, colon, dcolon, space, equals, dot, @@ -101,6 +101,7 @@ import Data.Word import System.IO ( Handle ) import System.FilePath import Text.Printf +import Numeric (showFFloat) import GHC.Fingerprint import GHC.Show ( showMultiLineString ) @@ -476,6 +477,11 @@ float n = docToSDoc $ Pretty.float n double n = docToSDoc $ Pretty.double n rational n = docToSDoc $ Pretty.rational n +-- | @doublePrec p n@ shows a floating point number @n@ with @p@ +-- digits of precision after the decimal point. +doublePrec :: Int -> Double -> SDoc +doublePrec p n = text (showFFloat (Just p) n "") + parens, braces, brackets, quotes, quote, paBrackets, doubleQuotes, angleBrackets :: SDoc -> SDoc diff --git a/docs/users_guide/debugging.xml b/docs/users_guide/debugging.xml index aebb928ae8..3d820d65c5 100644 --- a/docs/users_guide/debugging.xml +++ b/docs/users_guide/debugging.xml @@ -423,7 +423,15 @@ - Print out each pass name as it happens. + Print out each pass name, its runtime and heap allocations as it happens. + Note that this may come at a slight performance cost as the compiler will + be a bit more eager in forcing pass results to more accurately account for + their costs. + + Two types of messages are produced: Those beginning with ``***`` are + denote the beginning of a compilation phase whereas those starting with + ``!!!`` mark the end of a pass and are accompanied by allocation and + runtime statistics. -- cgit v1.2.1