diff options
Diffstat (limited to 'compiler/simplCore/SimplCore.hs')
| -rw-r--r-- | compiler/simplCore/SimplCore.hs | 31 |
1 files changed, 18 insertions, 13 deletions
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 |