From d4f4391a030e683572eee01291cc8bc6203dbf5d Mon Sep 17 00:00:00 2001 From: "simonpj@microsoft.com" Date: Thu, 24 Dec 2009 15:46:43 +0000 Subject: [PATCH] Continue refactoring the core-to-core pipeline This patch mainly concerns the plumbing for running the passes and printing intermediate output --- compiler/coreSyn/CoreLint.lhs | 36 ++------- compiler/coreSyn/CorePrep.lhs | 4 +- compiler/deSugar/Desugar.lhs | 4 +- compiler/main/ErrUtils.lhs | 20 ++--- compiler/main/TidyPgm.lhs | 17 +++- compiler/simplCore/CoreMonad.lhs | 155 ++++++++++++++++++++++++++++++------- compiler/simplCore/SimplCore.lhs | 97 ++++++++--------------- compiler/simplCore/SimplMonad.lhs | 5 +- 8 files changed, 185 insertions(+), 153 deletions(-) diff --git a/compiler/coreSyn/CoreLint.lhs b/compiler/coreSyn/CoreLint.lhs index ee6541e..62fe897 100644 --- a/compiler/coreSyn/CoreLint.lhs +++ b/compiler/coreSyn/CoreLint.lhs @@ -36,7 +36,6 @@ import BasicTypes import StaticFlags import ListSetOps import PrelNames -import DynFlags import Outputable import FastString import Util @@ -96,29 +95,11 @@ find an occurence of an Id, we fetch it from the in-scope set. \begin{code} -lintCoreBindings :: DynFlags -> String -> [CoreBind] -> IO () - -lintCoreBindings dflags _whoDunnit _binds - | not (dopt Opt_DoCoreLinting dflags) - = return () - -lintCoreBindings dflags whoDunnit binds - | isEmptyBag errs - = do { showPass dflags ("Core Linted result of " ++ whoDunnit) - ; unless (isEmptyBag warns || opt_NoDebugOutput) $ printDump $ - (banner "warnings" $$ displayMessageBag warns) - ; return () } - - | otherwise - = do { printDump (vcat [ banner "errors", displayMessageBag errs - , ptext (sLit "*** Offending Program ***") - , pprCoreBindings binds - , ptext (sLit "*** End of Offense ***") ]) - - ; ghcExit dflags 1 } +lintCoreBindings :: [CoreBind] -> (Bag Message, Bag Message) +-- Returns (warnings, errors) +lintCoreBindings binds + = initL (lint_binds binds) where - (warns, errs) = initL (lint_binds binds) - -- Put all the top-level binders in scope at the start -- This is because transformation rules can bring something -- into use 'unexpectedly' @@ -128,13 +109,6 @@ lintCoreBindings dflags whoDunnit binds lint_bind (Rec prs) = mapM_ (lintSingleBinding TopLevel Recursive) prs lint_bind (NonRec bndr rhs) = lintSingleBinding TopLevel NonRecursive (bndr,rhs) - - banner string = ptext (sLit "*** Core Lint") <+> text string - <+> ptext (sLit ": in result of") <+> text whoDunnit - <+> ptext (sLit "***") - -displayMessageBag :: Bag Message -> SDoc -displayMessageBag msgs = vcat (punctuate blankLine (bagToList msgs)) \end{code} %************************************************************************ @@ -154,7 +128,7 @@ lintUnfolding :: SrcLoc lintUnfolding locn vars expr | isEmptyBag errs = Nothing - | otherwise = Just (displayMessageBag errs) + | otherwise = Just (pprMessageBag errs) where (_warns, errs) = initL (addLoc (ImportedUnfolding locn) $ addInScopeVars vars $ diff --git a/compiler/coreSyn/CorePrep.lhs b/compiler/coreSyn/CorePrep.lhs index 738bf82..5616803 100644 --- a/compiler/coreSyn/CorePrep.lhs +++ b/compiler/coreSyn/CorePrep.lhs @@ -15,7 +15,7 @@ import PrelNames ( lazyIdKey, hasKey ) import CoreUtils import CoreArity import CoreFVs -import CoreMonad ( endPass ) +import CoreMonad ( endPass, CoreToDo(..) ) import CoreSyn import Type import Coercion @@ -147,7 +147,7 @@ corePrepPgm dflags binds data_tycons = do floats2 <- corePrepTopBinds implicit_binds return (deFloatTop (floats1 `appendFloats` floats2)) - endPass dflags "CorePrep" Opt_D_dump_prep binds_out [] + endPass dflags CorePrep binds_out [] return binds_out corePrepExpr :: DynFlags -> CoreExpr -> IO CoreExpr diff --git a/compiler/deSugar/Desugar.lhs b/compiler/deSugar/Desugar.lhs index 3b30dea..64fff0d 100644 --- a/compiler/deSugar/Desugar.lhs +++ b/compiler/deSugar/Desugar.lhs @@ -28,7 +28,7 @@ import Module import RdrName import NameSet import Rules -import CoreMonad ( endPass ) +import CoreMonad ( endPass, CoreToDo(..) ) import ErrUtils import Outputable import SrcLoc @@ -114,7 +114,7 @@ deSugar hsc_env -- things into the in-scope set before simplifying; so we get no unfolding for F#! -- Lint result if necessary - ; endPass dflags "Desugar" Opt_D_dump_ds ds_binds ds_rules + ; endPass dflags CoreDesugar ds_binds ds_rules -- Dump output ; doIfSet (dopt Opt_D_dump_ds dflags) diff --git a/compiler/main/ErrUtils.lhs b/compiler/main/ErrUtils.lhs index d64e98e..f1328e0 100644 --- a/compiler/main/ErrUtils.lhs +++ b/compiler/main/ErrUtils.lhs @@ -5,7 +5,7 @@ \begin{code} module ErrUtils ( - Message, mkLocMessage, printError, + Message, mkLocMessage, printError, pprMessageBag, Severity(..), ErrMsg, WarnMsg, @@ -18,7 +18,7 @@ module ErrUtils ( ghcExit, doIfSet, doIfSet_dyn, - dumpIfSet, dumpIf_core, dumpIfSet_core, dumpIfSet_dyn, dumpIfSet_dyn_or, + dumpIfSet, dumpIfSet_dyn, dumpIfSet_dyn_or, mkDumpDoc, dumpSDoc, -- * Messages during compilation @@ -49,6 +49,9 @@ import System.IO type Message = SDoc +pprMessageBag :: Bag Message -> SDoc +pprMessageBag msgs = vcat (punctuate blankLine (bagToList msgs)) + data Severity = SevInfo | SevWarning @@ -202,19 +205,6 @@ dumpIfSet flag hdr doc | not flag = return () | otherwise = printDump (mkDumpDoc hdr doc) -dumpIf_core :: Bool -> DynFlags -> DynFlag -> String -> SDoc -> IO () -dumpIf_core cond dflags dflag hdr doc - | cond - || verbosity dflags >= 4 - || dopt Opt_D_verbose_core2core dflags - = dumpSDoc dflags dflag hdr doc - - | otherwise = return () - -dumpIfSet_core :: DynFlags -> DynFlag -> String -> SDoc -> IO () -dumpIfSet_core dflags flag hdr doc - = dumpIf_core (dopt flag dflags) dflags flag hdr doc - dumpIfSet_dyn :: DynFlags -> DynFlag -> String -> SDoc -> IO () dumpIfSet_dyn dflags flag hdr doc | dopt flag dflags || verbosity dflags >= 4 diff --git a/compiler/main/TidyPgm.lhs b/compiler/main/TidyPgm.lhs index 4c01bc5..98ab1d9 100644 --- a/compiler/main/TidyPgm.lhs +++ b/compiler/main/TidyPgm.lhs @@ -18,6 +18,7 @@ import CoreFVs import CoreTidy import CoreMonad import CoreUtils +import Rules import CoreArity ( exprArity, exprBotStrictness_maybe ) import Class ( classSelIds ) import VarEnv @@ -38,11 +39,11 @@ import TyCon import Module import HscTypes import Maybes -import ErrUtils import UniqSupply import Outputable import FastBool hiding ( fastOr ) import Util +import FastString import Data.List ( sortBy ) import Data.IORef ( IORef, readIORef, writeIORef ) @@ -133,7 +134,7 @@ mkBootModDetails :: HscEnv -> [AvailInfo] -> NameEnv TyThing -> [Instance] -> [FamInstEnv.FamInst] -> IO ModDetails mkBootModDetails hsc_env exports type_env insts fam_insts = do { let dflags = hsc_dflags hsc_env - ; showPass dflags "Tidy [hoot] type env" + ; showPass dflags CoreTidy ; let { insts' = tidyInstances globaliseAndTidyId insts ; dfun_ids = map instanceDFunId insts' @@ -301,7 +302,7 @@ tidyProgram hsc_env (ModGuts { mg_module = mod, mg_exports = exports, ; expose_all = dopt Opt_ExposeAllUnfoldings dflags ; th = dopt Opt_TemplateHaskell dflags } - ; showPass dflags "Tidy Core" + ; showPass dflags CoreTidy ; let { implicit_binds = getImplicitBinds type_env } @@ -342,7 +343,15 @@ tidyProgram hsc_env (ModGuts { mg_module = mod, mg_exports = exports, ; alg_tycons = filter isAlgTyCon (typeEnvTyCons type_env) } - ; endPass dflags "Tidy Core" Opt_D_dump_simpl all_tidy_binds tidy_rules + ; endPass dflags CoreTidy all_tidy_binds tidy_rules + + -- If the endPass didn't print the rules, but ddump-rules is on, print now + ; dumpIfSet (dopt Opt_D_dump_rules dflags + && (not (dopt Opt_D_dump_simpl dflags))) + CoreTidy + (ptext (sLit "rules")) + (pprRulesForUser tidy_rules) + ; let dir_imp_mods = moduleEnvKeys dir_imps ; return (CgGuts { cg_module = mod, diff --git a/compiler/simplCore/CoreMonad.lhs b/compiler/simplCore/CoreMonad.lhs index ef8c428..f9ff5e7 100644 --- a/compiler/simplCore/CoreMonad.lhs +++ b/compiler/simplCore/CoreMonad.lhs @@ -36,13 +36,13 @@ module CoreMonad ( getAnnotations, getFirstAnnotations, -- ** Debug output - endPass, endPassIf, endIteration, + showPass, endPass, endIteration, dumpIfSet, -- ** Screen output putMsg, putMsgS, errorMsg, errorMsgS, fatalErrorMsg, fatalErrorMsgS, debugTraceMsg, debugTraceMsgS, - dumpIfSet_dyn, + dumpIfSet_dyn, #ifdef GHCI -- * Getting 'Name's @@ -75,6 +75,7 @@ import TcRnMonad ( TcM, initTc ) import Outputable import FastString import qualified ErrUtils as Err +import Bag import Maybes import UniqSupply import LazyUniqFM ( UniqFM, mapUFM, filterUFM ) @@ -106,35 +107,80 @@ 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. \begin{code} -endPass :: DynFlags -> String -> DynFlag -> [CoreBind] -> [CoreRule] -> IO () -endPass = dumpAndLint Err.dumpIfSet_core +showPass :: DynFlags -> CoreToDo -> IO () +showPass dflags pass = Err.showPass dflags (showSDoc (ppr pass)) -endPassIf :: Bool -> DynFlags -> String -> DynFlag -> [CoreBind] -> [CoreRule] -> IO () -endPassIf cond = dumpAndLint (Err.dumpIf_core cond) +endPass :: DynFlags -> CoreToDo -> [CoreBind] -> [CoreRule] -> IO () +endPass dflags pass = dumpAndLint dflags True pass empty (coreDumpFlag pass) -- Same as endPass but doesn't dump Core even with -dverbose-core2core -endIteration :: DynFlags -> String -> DynFlag -> [CoreBind] -> [CoreRule] -> IO () -endIteration = dumpAndLint Err.dumpIfSet_dyn +endIteration :: DynFlags -> CoreToDo -> Int -> [CoreBind] -> [CoreRule] -> IO () +endIteration dflags pass n + = dumpAndLint dflags False pass (ptext (sLit "iteration=") <> int n) + (Just Opt_D_dump_simpl_iterations) -dumpAndLint :: (DynFlags -> DynFlag -> String -> SDoc -> IO ()) - -> DynFlags -> String -> DynFlag +dumpIfSet :: Bool -> CoreToDo -> SDoc -> SDoc -> IO () +dumpIfSet dump_me pass extra_info doc + = Err.dumpIfSet dump_me (showSDoc (ppr pass <+> extra_info)) doc + +dumpAndLint :: DynFlags -> Bool -> CoreToDo -> SDoc -> Maybe DynFlag -> [CoreBind] -> [CoreRule] -> IO () -dumpAndLint dump dflags pass_name dump_flag binds rules +-- The "show_all" parameter says to print dump if -dverbose-core2core is on +dumpAndLint dflags show_all pass extra_info mb_dump_flag binds rules = do { -- Report result size if required -- This has the side effect of forcing the intermediate to be evaluated ; Err.debugTraceMsg dflags 2 $ (text " Result size =" <+> int (coreBindsSize binds)) -- Report verbosely, if required - ; dump dflags dump_flag pass_name - (pprCoreBindings binds $$ ppUnless (null rules) pp_rules) + ; let pass_name = showSDoc (ppr pass <+> extra_info) + dump_doc = pprCoreBindings binds + $$ ppUnless (null rules) pp_rules + + ; case mb_dump_flag of + Nothing -> return () + Just dump_flag -> Err.dumpIfSet_dyn_or dflags dump_flags pass_name dump_doc + where + dump_flags | show_all = [dump_flag, Opt_D_verbose_core2core] + | otherwise = [dump_flag] -- Type check - ; lintCoreBindings dflags pass_name binds } + ; when (dopt Opt_DoCoreLinting dflags) $ + do { let (warns, errs) = lintCoreBindings binds + ; Err.showPass dflags ("Core Linted result of " ++ pass_name) + ; displayLintResults dflags pass warns errs binds } } where pp_rules = vcat [ blankLine , ptext (sLit "------ Local rules for imported ids --------") , pprRules rules ] + +displayLintResults :: DynFlags -> CoreToDo + -> Bag Err.Message -> Bag Err.Message -> [CoreBind] + -> IO () +displayLintResults dflags pass warns errs binds + | not (isEmptyBag errs) + = do { printDump (vcat [ banner "errors", Err.pprMessageBag errs + , ptext (sLit "*** Offending Program ***") + , pprCoreBindings binds + , ptext (sLit "*** End of Offense ***") ]) + ; Err.ghcExit dflags 1 } + + | not (isEmptyBag warns) + , not opt_NoDebugOutput + , showLintWarnings pass + = printDump (banner "warnings" $$ Err.pprMessageBag warns) + + | otherwise = return () + where + banner string = ptext (sLit "*** Core Lint") <+> text string + <+> ptext (sLit ": in result of") <+> ppr pass + <+> ptext (sLit "***") + +showLintWarnings :: CoreToDo -> Bool +-- Disable Lint warnings on the first simplifier pass, because +-- there may be some INLINE knots still tied, which is tiresomely noisy +showLintWarnings (CoreDoSimplify (SimplGently {}) _ _) = False +showLintWarnings _ = True \end{code} @@ -152,9 +198,9 @@ data CoreToDo -- These are diff core-to-core passes, = CoreDoSimplify -- The core-to-core simplifier. SimplifierMode - [SimplifierSwitch] - -- Each run of the simplifier can take a different - -- set of simplifier-specific flags. + Int -- Max iterations + [SimplifierSwitch] -- Each run of the simplifier can take a different + -- set of simplifier-specific flags. | CoreDoFloatInwards | CoreDoFloatOutwards FloatOutSwitches | CoreLiberateCase @@ -164,7 +210,6 @@ data CoreToDo -- These are diff core-to-core passes, | CoreDoWorkerWrapper | CoreDoSpecialising | CoreDoSpecConstr - | CoreDoOldStrictness | CoreDoGlomBinds | CoreCSE | CoreDoRuleCheck CompilerPhase String -- Check for non-application of rules @@ -173,7 +218,59 @@ data CoreToDo -- These are diff core-to-core passes, | CoreDoNothing -- Useful when building up | CoreDoPasses [CoreToDo] -- lists of these things + | CoreDesugar -- Not strictly a core-to-core pass, but produces + -- Core output, and hence useful to pass to endPass + + | CoreTidy + | CorePrep + +coreDumpFlag :: CoreToDo -> Maybe DynFlag +coreDumpFlag (CoreDoSimplify {}) = Just Opt_D_dump_simpl_phases +coreDumpFlag CoreDoFloatInwards = Just Opt_D_verbose_core2core +coreDumpFlag (CoreDoFloatOutwards {}) = Just Opt_D_verbose_core2core +coreDumpFlag CoreLiberateCase = Just Opt_D_verbose_core2core +coreDumpFlag CoreDoStaticArgs = Just Opt_D_verbose_core2core +coreDumpFlag CoreDoStrictness = Just Opt_D_dump_stranal +coreDumpFlag CoreDoWorkerWrapper = Just Opt_D_dump_worker_wrapper +coreDumpFlag CoreDoSpecialising = Just Opt_D_dump_spec +coreDumpFlag CoreDoSpecConstr = Just Opt_D_dump_spec +coreDumpFlag CoreCSE = Just Opt_D_dump_cse +coreDumpFlag (CoreDoVectorisation {}) = Just Opt_D_dump_vect +coreDumpFlag CoreDesugar = Just Opt_D_dump_ds +coreDumpFlag CoreTidy = Just Opt_D_dump_simpl +coreDumpFlag CorePrep = Just Opt_D_dump_prep + +coreDumpFlag CoreDoPrintCore = Nothing +coreDumpFlag (CoreDoRuleCheck {}) = Nothing +coreDumpFlag CoreDoNothing = Nothing +coreDumpFlag CoreDoGlomBinds = Nothing +coreDumpFlag (CoreDoPasses {}) = Nothing + +instance Outputable CoreToDo where + ppr (CoreDoSimplify md n _) = ptext (sLit "Simplifier") + <+> ppr md + <+> ptext (sLit "max-iterations=") <> int n + ppr CoreDoFloatInwards = ptext (sLit "Float inwards") + ppr (CoreDoFloatOutwards f) = ptext (sLit "Float out") <> parens (ppr f) + ppr CoreLiberateCase = ptext (sLit "Liberate case") + ppr CoreDoStaticArgs = ptext (sLit "Static argument") + ppr CoreDoStrictness = ptext (sLit "Demand analysis") + ppr CoreDoWorkerWrapper = ptext (sLit "Worker Wrapper binds") + ppr CoreDoSpecialising = ptext (sLit "Specialise") + ppr CoreDoSpecConstr = ptext (sLit "SpecConstr") + ppr CoreCSE = ptext (sLit "Common sub-expression") + ppr (CoreDoVectorisation {}) = ptext (sLit "Vectorisation") + ppr CoreDesugar = ptext (sLit "Desugar") + ppr CoreTidy = ptext (sLit "Tidy Core") + ppr CorePrep = ptext (sLit "CorePrep") + ppr CoreDoPrintCore = ptext (sLit "Print core") + ppr (CoreDoRuleCheck {}) = ptext (sLit "Rule check") + ppr CoreDoGlomBinds = ptext (sLit "Glom binds") + ppr CoreDoNothing = ptext (sLit "CoreDoNothing") + ppr (CoreDoPasses {}) = ptext (sLit "CoreDoPasses") +\end{code} +\begin{code} data SimplifierMode -- See comments in SimplMonad = SimplGently { sm_rules :: Bool -- Whether RULES are enabled @@ -185,7 +282,7 @@ data SimplifierMode -- See comments in SimplMonad instance Outputable SimplifierMode where ppr (SimplPhase { sm_num = n, sm_names = ss }) - = int n <+> brackets (text (concat $ intersperse "," ss)) + = ptext (sLit "Phase") <+> int n <+> brackets (text (concat $ intersperse "," ss)) ppr (SimplGently { sm_rules = r, sm_inline = i }) = ptext (sLit "gentle") <> brackets (pp_flag r (sLit "rules") <> comma <> @@ -194,15 +291,16 @@ instance Outputable SimplifierMode where pp_flag f s = ppUnless f (ptext (sLit "no")) <+> ptext s data SimplifierSwitch - = MaxSimplifierIterations Int - | NoCaseOfCase + = NoCaseOfCase +\end{code} + +\begin{code} data FloatOutSwitches = FloatOutSwitches { floatOutLambdas :: Bool, -- ^ True <=> float lambdas to top level floatOutConstants :: Bool -- ^ True <=> float constants to top level, -- even if they do not escape a lambda } - instance Outputable FloatOutSwitches where ppr = pprFloatOutSwitches @@ -254,11 +352,10 @@ getCoreToDo dflags simpl_phase phase names iter = CoreDoPasses - [ maybe_strictness_before phase, - CoreDoSimplify (SimplPhase phase names) [ - MaxSimplifierIterations iter - ], - maybe_rule_check phase + [ maybe_strictness_before phase + , CoreDoSimplify (SimplPhase phase names) + iter [] + , maybe_rule_check phase ] vectorisation @@ -284,6 +381,7 @@ getCoreToDo dflags -- initial simplify: mk specialiser happy: minimum effort please simpl_gently = CoreDoSimplify (SimplGently { sm_rules = True, sm_inline = False }) + max_iter [ -- Simplify "gently" -- Don't inline anything till full laziness has bitten @@ -295,9 +393,8 @@ getCoreToDo dflags -- Similarly, don't apply any rules until after full -- laziness. Notably, list fusion can prevent floating. - NoCaseOfCase, -- Don't do case-of-case transformations. + NoCaseOfCase -- Don't do case-of-case transformations. -- This makes full laziness work better - MaxSimplifierIterations max_iter ] core_todo = diff --git a/compiler/simplCore/SimplCore.lhs b/compiler/simplCore/SimplCore.lhs index 8ec2d1d..4df489b 100644 --- a/compiler/simplCore/SimplCore.lhs +++ b/compiler/simplCore/SimplCore.lhs @@ -130,57 +130,55 @@ simplifyExpr dflags expr } doCorePasses :: [CorePass] -> ModGuts -> CoreM ModGuts -doCorePasses passes guts = foldM (flip doCorePass) guts passes +doCorePasses passes guts + = foldM do_pass guts passes + where + do_pass guts CoreDoNothing = return guts + do_pass guts (CoreDoPasses ps) = doCorePasses ps guts + do_pass guts pass + = do { dflags <- getDynFlags + ; liftIO $ showPass dflags pass + ; guts' <- doCorePass pass guts + ; liftIO $ endPass dflags pass (mg_binds guts') (mg_rules guts') + ; return guts' } doCorePass :: CorePass -> ModGuts -> CoreM ModGuts -doCorePass (CoreDoSimplify mode sws) = {-# SCC "Simplify" #-} - simplifyPgm mode sws +doCorePass pass@(CoreDoSimplify {}) = {-# SCC "Simplify" #-} + simplifyPgm pass doCorePass CoreCSE = {-# SCC "CommonSubExpr" #-} - describePass "Common sub-expression" Opt_D_dump_cse $ doPass cseProgram doCorePass CoreLiberateCase = {-# SCC "LiberateCase" #-} - describePass "Liberate case" Opt_D_verbose_core2core $ doPassD liberateCase doCorePass CoreDoFloatInwards = {-# SCC "FloatInwards" #-} - describePass "Float inwards" Opt_D_verbose_core2core $ doPass floatInwards doCorePass (CoreDoFloatOutwards f) = {-# SCC "FloatOutwards" #-} - describePassD (text "Float out" <+> parens (ppr f)) - Opt_D_verbose_core2core $ doPassDUM (floatOutwards f) doCorePass CoreDoStaticArgs = {-# SCC "StaticArgs" #-} - describePass "Static argument" Opt_D_verbose_core2core $ doPassU doStaticArgs doCorePass CoreDoStrictness = {-# SCC "Stranal" #-} - describePass "Demand analysis" Opt_D_dump_stranal $ doPassDM dmdAnalPgm doCorePass CoreDoWorkerWrapper = {-# SCC "WorkWrap" #-} - describePass "Worker Wrapper binds" Opt_D_dump_worker_wrapper $ doPassU wwTopBinds doCorePass CoreDoSpecialising = {-# SCC "Specialise" #-} - describePassR "Specialise" Opt_D_dump_spec $ doPassU specProgram doCorePass CoreDoSpecConstr = {-# SCC "SpecConstr" #-} - describePassR "SpecConstr" Opt_D_dump_spec $ specConstrProgram doCorePass (CoreDoVectorisation be) = {-# SCC "Vectorise" #-} - describePass "Vectorisation" Opt_D_dump_vect $ vectorise be -doCorePass CoreDoGlomBinds = dontDescribePass $ doPassDM glomBinds -doCorePass CoreDoPrintCore = dontDescribePass $ observe printCore -doCorePass (CoreDoRuleCheck phase pat) = dontDescribePass $ ruleCheck phase pat - +doCorePass CoreDoGlomBinds = doPassDM glomBinds +doCorePass CoreDoPrintCore = observe printCore +doCorePass (CoreDoRuleCheck phase pat) = ruleCheck phase pat doCorePass CoreDoNothing = return doCorePass (CoreDoPasses passes) = doCorePasses passes \end{code} @@ -192,30 +190,6 @@ doCorePass (CoreDoPasses passes) = doCorePasses passes %************************************************************************ \begin{code} - -dontDescribePass :: (ModGuts -> CoreM ModGuts) -> ModGuts -> CoreM ModGuts -dontDescribePass = ($) - -describePass :: String -> DynFlag -> (ModGuts -> CoreM ModGuts) -> ModGuts -> CoreM ModGuts -describePass name dflag pass guts = do - dflags <- getDynFlags - - liftIO $ Err.showPass dflags name - guts' <- pass guts - liftIO $ endPass dflags name dflag (mg_binds guts') (mg_rules guts') - - return guts' - -describePassD :: SDoc -> DynFlag -> (ModGuts -> CoreM ModGuts) -> ModGuts -> CoreM ModGuts -describePassD doc = describePass (showSDoc doc) - -describePassR :: String -> DynFlag -> (ModGuts -> CoreM ModGuts) -> ModGuts -> CoreM ModGuts -describePassR name dflag pass guts = do - guts' <- describePass name dflag pass guts - dumpIfSet_dyn Opt_D_dump_rules "Top-level specialisations" - (pprRulesForUser (rulesOfBinds (mg_binds guts'))) - return guts' - printCore _ binds = Err.dumpIfSet True "Print Core" (pprCoreBindings binds) ruleCheck :: CompilerPhase -> String -> ModGuts -> CoreM ModGuts @@ -468,26 +442,23 @@ glomBinds dflags binds %************************************************************************ \begin{code} -simplifyPgm :: SimplifierMode -> [SimplifierSwitch] -> ModGuts -> CoreM ModGuts -simplifyPgm mode switches - = describePassD doc Opt_D_dump_simpl_phases $ \guts -> - do { hsc_env <- getHscEnv +simplifyPgm :: CoreToDo -> ModGuts -> CoreM ModGuts +simplifyPgm pass guts + = do { hsc_env <- getHscEnv ; us <- getUniqueSupplyM ; rb <- getRuleBase ; liftIOWithCount $ - simplifyPgmIO mode switches hsc_env us rb guts } - where - doc = ptext (sLit "Simplifier Phase") <+> text (showPpr mode) + simplifyPgmIO pass hsc_env us rb guts } -simplifyPgmIO :: SimplifierMode - -> [SimplifierSwitch] +simplifyPgmIO :: CoreToDo -> HscEnv -> UniqSupply -> RuleBase -> ModGuts -> IO (SimplCount, ModGuts) -- New bindings -simplifyPgmIO mode switches hsc_env us hpt_rule_base +simplifyPgmIO pass@(CoreDoSimplify mode max_iterations switches) + hsc_env us hpt_rule_base guts@(ModGuts { mg_binds = binds, mg_rules = rules , mg_fam_inst_env = fam_inst_env }) = do { @@ -505,10 +476,7 @@ simplifyPgmIO mode switches hsc_env us hpt_rule_base where dflags = hsc_dflags hsc_env dump_phase = dumpSimplPhase dflags mode - - sw_chkr = isAmongSimpl switches - max_iterations = intSwitchSet sw_chkr MaxSimplifierIterations `orElse` 2 - + sw_chkr = isAmongSimpl switches do_iteration :: UniqSupply -> Int -- Counts iterations -> SimplCount -- Logs optimisations performed @@ -587,7 +555,7 @@ simplifyPgmIO mode switches hsc_env us hpt_rule_base let { binds2 = {-# SCC "ZapInd" #-} shortOutIndirections binds1 } ; -- Dump the result of this iteration - end_iteration dflags mode iteration_no max_iterations counts1 binds2 rules1 ; + end_iteration dflags pass iteration_no counts1 binds2 rules1 ; -- Loop do_iteration us2 (iteration_no + 1) all_counts binds2 rules1 @@ -596,18 +564,15 @@ simplifyPgmIO mode switches hsc_env us hpt_rule_base (us1, us2) = splitUniqSupply us ------------------- -end_iteration :: DynFlags -> SimplifierMode -> Int -> Int +end_iteration :: DynFlags -> CoreToDo -> Int -> SimplCount -> [CoreBind] -> [CoreRule] -> IO () -- Same as endIteration but with simplifier counts -end_iteration dflags mode iteration_no max_iterations counts binds rules - = do { Err.dumpIfSet_dyn dflags Opt_D_dump_simpl_iterations pass_name - (pprSimplCount counts) ; +end_iteration dflags pass iteration_no counts binds rules + = do { dumpIfSet (dopt Opt_D_dump_simpl_iterations dflags) + pass (ptext (sLit "Simplifier counts")) + (pprSimplCount counts) - ; endIteration dflags pass_name Opt_D_dump_simpl_iterations binds rules } - where - pass_name = "Simplifier mode " ++ showPpr mode ++ - ", iteration " ++ show iteration_no ++ - " out of " ++ show max_iterations + ; endIteration dflags pass iteration_no binds rules } \end{code} diff --git a/compiler/simplCore/SimplMonad.lhs b/compiler/simplCore/SimplMonad.lhs index 5065f57..10bc70d 100644 --- a/compiler/simplCore/SimplMonad.lhs +++ b/compiler/simplCore/SimplMonad.lhs @@ -201,8 +201,6 @@ isAmongSimpl on_switches -- Switches mentioned later occur *earlier* -- (avoid some unboxing, bounds checking, and other horrible things:) \ switch -> unsafeAt sw_tbl $ iBox (tagOf_SimplSwitch switch) where - mk_assoc_elem k@(MaxSimplifierIterations lvl) - = (iBox (tagOf_SimplSwitch k), SwInt lvl) mk_assoc_elem k = (iBox (tagOf_SimplSwitch k), SwBool True) -- I'm here, Mom! @@ -252,8 +250,7 @@ instance Ord SimplifierSwitch where tagOf_SimplSwitch :: SimplifierSwitch -> FastInt -tagOf_SimplSwitch (MaxSimplifierIterations _) = _ILIT(1) -tagOf_SimplSwitch NoCaseOfCase = _ILIT(2) +tagOf_SimplSwitch NoCaseOfCase = _ILIT(1) -- If you add anything here, be sure to change lAST_SIMPL_SWITCH_TAG, too! -- 1.7.10.4