X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FsimplCore%2FSimplCore.lhs;h=1a634d5e0ebe86efcca3e9b39d5be48b533bcfc4;hp=17132e5d0f9ffc8c38576a1a6b1a0e8804b8507a;hb=f2aaae9757e7532485c97f6c9a9ed5437542d1dd;hpb=99d1354f70b94951fa8f7401ba82881a317b6a55 diff --git a/compiler/simplCore/SimplCore.lhs b/compiler/simplCore/SimplCore.lhs index 17132e5..1a634d5 100644 --- a/compiler/simplCore/SimplCore.lhs +++ b/compiler/simplCore/SimplCore.lhs @@ -4,51 +4,34 @@ \section[SimplCore]{Driver for simplifying @Core@ programs} \begin{code} -{-# OPTIONS -w #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and fix --- any warnings in the module. See --- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings --- for details - module SimplCore ( core2core, simplifyExpr ) where #include "HsVersions.h" -import DynFlags ( CoreToDo(..), SimplifierSwitch(..), - SimplifierMode(..), DynFlags, DynFlag(..), dopt, - getCoreToDo, shouldDumpSimplPhase ) +import DynFlags ( DynFlags, DynFlag(..), dopt ) import CoreSyn import CoreSubst import HscTypes import CSE ( cseProgram ) import Rules ( RuleBase, emptyRuleBase, mkRuleBase, unionRuleBase, - extendRuleBaseList, pprRuleBase, pprRulesForUser, - ruleCheckProgram, rulesOfBinds, - addSpecInfo, addIdSpecialisations ) -import PprCore ( pprCoreBindings, pprCoreExpr, pprRules ) + extendRuleBaseList, ruleCheckProgram, addSpecInfo, ) +import PprCore ( pprCoreBindings, pprCoreExpr ) import OccurAnal ( occurAnalysePgm, occurAnalyseExpr ) import IdInfo import CoreUtils ( coreBindsSize ) import Simplify ( simplTopBinds, simplExpr ) -import SimplUtils ( simplEnvForGHCi, simplEnvForRules ) +import SimplUtils ( simplEnvForGHCi, activeRule ) import SimplEnv import SimplMonad import CoreMonad import qualified ErrUtils as Err -import CoreLint -import CoreMonad ( endPass ) import FloatIn ( floatInwards ) import FloatOut ( floatOutwards ) import FamInstEnv import Id -import DataCon -import TyCon ( tyConDataCons ) -import Class ( classSelIds ) -import BasicTypes ( CompilerPhase, isActive, isDefaultInlinePragma ) +import BasicTypes ( CompilerPhase, isDefaultInlinePragma ) import VarSet import VarEnv -import NameEnv ( lookupNameEnv ) import LiberateCase ( liberateCase ) import SAT ( doStaticArgs ) import Specialise ( specProgram) @@ -62,9 +45,6 @@ import Util import UniqSupply ( UniqSupply, mkSplitUniqSupply, splitUniqSupply ) import Outputable import Control.Monad -import Data.List -import System.IO -import Maybes \end{code} %************************************************************************ @@ -74,117 +54,84 @@ import Maybes %************************************************************************ \begin{code} -core2core :: HscEnv - -> ModGuts - -> IO ModGuts - -core2core hsc_env guts = do - let dflags = hsc_dflags hsc_env - - us <- mkSplitUniqSupply 's' - let (cp_us, ru_us) = splitUniqSupply us +core2core :: HscEnv -> ModGuts -> IO ModGuts +core2core hsc_env guts + = do { us <- mkSplitUniqSupply 's' + ; (guts2, stats) <- runCoreM hsc_env hpt_rule_base us mod $ + doCorePasses (getCoreToDo dflags) guts - -- COMPUTE THE RULE BASE TO USE - (hpt_rule_base, guts1) <- prepareRules hsc_env guts ru_us + ; Err.dumpIfSet_dyn dflags Opt_D_dump_simpl_stats + "Grand total simplifier statistics" + (pprSimplCount stats) - -- Get the module out of the current HscEnv so we can retrieve it from the monad. + ; return guts2 } + where + dflags = hsc_dflags hsc_env + home_pkg_rules = hptRules hsc_env (dep_mods (mg_deps guts)) + hpt_rule_base = mkRuleBase home_pkg_rules + mod = mg_module guts + -- mod: get the module out of the current HscEnv so we can retrieve it from the monad. -- This is very convienent for the users of the monad (e.g. plugins do not have to -- consume the ModGuts to find the module) but somewhat ugly because mg_module may -- _theoretically_ be changed during the Core pipeline (it's part of ModGuts), which -- would mean our cached value would go out of date. - let mod = mg_module guts - (guts2, stats) <- runCoreM hsc_env hpt_rule_base cp_us mod $ do - -- FIND BUILT-IN PASSES - let builtin_core_todos = getCoreToDo dflags - - -- DO THE BUSINESS - doCorePasses builtin_core_todos guts1 - - Err.dumpIfSet_dyn dflags Opt_D_dump_simpl_stats - "Grand total simplifier statistics" - (pprSimplCount stats) - - return guts2 type CorePass = CoreToDo -simplifyExpr :: DynFlags -- includes spec of what core-to-core passes to do - -> CoreExpr - -> IO CoreExpr --- simplifyExpr is called by the driver to simplify an --- expression typed in at the interactive prompt --- --- Also used by Template Haskell -simplifyExpr dflags expr - = do { - ; Err.showPass dflags "Simplify" - - ; us <- mkSplitUniqSupply 's' - - ; let (expr', _counts) = initSmpl dflags emptyRuleBase emptyFamInstEnvs us $ - simplExprGently simplEnvForGHCi expr - - ; Err.dumpIfSet_dyn dflags Opt_D_dump_simpl "Simplified expression" - (pprCoreExpr expr') - - ; return 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 + 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 CoreDoVectorisation = {-# SCC "Vectorise" #-} + vectorise +doCorePass CoreDoGlomBinds = doPassDM glomBinds +doCorePass CoreDoPrintCore = observe printCore +doCorePass (CoreDoRuleCheck phase pat) = ruleCheck phase pat doCorePass CoreDoNothing = return doCorePass (CoreDoPasses passes) = doCorePasses passes +doCorePass pass = pprPanic "doCorePass" (ppr pass) \end{code} %************************************************************************ @@ -194,30 +141,7 @@ 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 :: a -> [CoreBind] -> IO () printCore _ binds = Err.dumpIfSet True "Print Core" (pprCoreBindings binds) ruleCheck :: CompilerPhase -> String -> ModGuts -> CoreM ModGuts @@ -229,11 +153,6 @@ ruleCheck current_phase pat guts = do return guts -doPassDMS :: (DynFlags -> [CoreBind] -> IO (SimplCount, [CoreBind])) -> ModGuts -> CoreM ModGuts -doPassDMS do_pass = doPassM $ \binds -> do - dflags <- getDynFlags - liftIOWithCount $ do_pass dflags binds - doPassDUM :: (DynFlags -> UniqSupply -> [CoreBind] -> IO [CoreBind]) -> ModGuts -> CoreM ModGuts doPassDUM do_pass = doPassM $ \binds -> do dflags <- getDynFlags @@ -259,11 +178,6 @@ doPassM bind_f guts = do binds' <- bind_f (mg_binds guts) return (guts { mg_binds = binds' }) -doPassMG :: Monad m => (ModGuts -> m [CoreBind]) -> ModGuts -> m ModGuts -doPassMG bind_f guts = do - binds' <- bind_f guts - return (guts { mg_binds = binds' }) - doPass :: ([CoreBind] -> [CoreBind]) -> ModGuts -> CoreM ModGuts doPass bind_f guts = return $ guts { mg_binds = bind_f (mg_binds guts) } @@ -271,132 +185,40 @@ doPass bind_f guts = return $ guts { mg_binds = bind_f (mg_binds guts) } observe :: (DynFlags -> [CoreBind] -> IO a) -> ModGuts -> CoreM ModGuts observe do_pass = doPassM $ \binds -> do dflags <- getDynFlags - liftIO $ do_pass dflags binds + _ <- liftIO $ do_pass dflags binds return binds \end{code} %************************************************************************ %* * - Dealing with rules + Gentle simplification %* * %************************************************************************ --- prepareLocalRuleBase takes the CoreBinds and rules defined in this module. --- It attaches those rules that are for local Ids to their binders, and --- returns the remainder attached to Ids in an IdSet. - \begin{code} -prepareRules :: HscEnv - -> ModGuts - -> UniqSupply - -> IO (RuleBase, -- Rule base for imported things, incl - -- (a) rules defined in this module (orphans) - -- (b) rules from other modules in home package - -- but not things from other packages - - ModGuts) -- Modified fields are - -- (a) Bindings have rules attached, - -- and INLINE rules simplified - -- (b) Rules are now just orphan rules - -prepareRules hsc_env@(HscEnv { hsc_dflags = dflags, hsc_HPT = hpt }) - guts@(ModGuts { mg_binds = binds, mg_deps = deps - , mg_rules = local_rules, mg_rdr_env = rdr_env }) - us - = do { us <- mkSplitUniqSupply 'w' - - ; let -- Simplify the local rules; boringly, we need to make an in-scope set - -- from the local binders, to avoid warnings from Simplify.simplVar - local_ids = mkInScopeSet (mkVarSet (bindersOfBinds binds)) - env = setInScopeSet simplEnvForRules local_ids - (simpl_rules, _) = initSmpl dflags emptyRuleBase emptyFamInstEnvs us $ - mapM (simplRule env) local_rules - - ; let (rules_for_locals, rules_for_imps) = partition isLocalRule simpl_rules - - home_pkg_rules = hptRules hsc_env (dep_mods deps) - hpt_rule_base = mkRuleBase home_pkg_rules - binds_w_rules = updateBinders rules_for_locals binds - - - ; Err.dumpIfSet_dyn dflags Opt_D_dump_rules "Transformation rules" - (withPprStyle (mkUserStyle (mkPrintUnqualified dflags rdr_env) AllTheWay) $ - vcat [text "Local rules", pprRules simpl_rules, - blankLine, - text "Imported rules", pprRuleBase hpt_rule_base]) - - ; return (hpt_rule_base, guts { mg_binds = binds_w_rules, - mg_rules = rules_for_imps }) - } +simplifyExpr :: DynFlags -- includes spec of what core-to-core passes to do + -> CoreExpr + -> IO CoreExpr +-- simplifyExpr is called by the driver to simplify an +-- expression typed in at the interactive prompt +-- +-- Also used by Template Haskell +simplifyExpr dflags expr + = do { + ; Err.showPass dflags "Simplify" --- Note [Attach rules to local ids] --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ --- Find the rules for locally-defined Ids; then we can attach them --- to the binders in the top-level bindings --- --- Reason --- - It makes the rules easier to look up --- - It means that transformation rules and specialisations for --- locally defined Ids are handled uniformly --- - It keeps alive things that are referred to only from a rule --- (the occurrence analyser knows about rules attached to Ids) --- - It makes sure that, when we apply a rule, the free vars --- of the RHS are more likely to be in scope --- - The imported rules are carried in the in-scope set --- which is extended on each iteration by the new wave of --- local binders; any rules which aren't on the binding will --- thereby get dropped - -updateBinders :: [CoreRule] -> [CoreBind] -> [CoreBind] -updateBinders rules_for_locals binds - = map update_bind binds - where - local_rules = extendRuleBaseList emptyRuleBase rules_for_locals - - update_bind (NonRec b r) = NonRec (add_rules b) r - update_bind (Rec prs) = Rec (mapFst add_rules prs) - - -- See Note [Attach rules to local ids] - -- NB: the binder might have some existing rules, - -- arising from specialisation pragmas - add_rules bndr - | Just rules <- lookupNameEnv local_rules (idName bndr) - = bndr `addIdSpecialisations` rules - | otherwise - = bndr -\end{code} + ; us <- mkSplitUniqSupply 's' -Note [Simplifying the left-hand side of a RULE] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We must do some gentle simplification on the lhs (template) of each -rule. The case that forced me to add this was the fold/build rule, -which without simplification looked like: - fold k z (build (/\a. g a)) ==> ... -This doesn't match unless you do eta reduction on the build argument. -Similarly for a LHS like - augment g (build h) -we do not want to get - augment (\a. g a) (build h) -otherwise we don't match when given an argument like - augment (\a. h a a) (build h) - -The simplifier does indeed do eta reduction (it's in -Simplify.completeLam) but only if -O is on. + ; let (expr', _counts) = initSmpl dflags emptyRuleBase emptyFamInstEnvs us $ + simplExprGently simplEnvForGHCi expr -\begin{code} -simplRule :: SimplEnv -> CoreRule -> SimplM CoreRule -simplRule env rule@(BuiltinRule {}) - = return rule -simplRule env rule@(Rule { ru_bndrs = bndrs, ru_args = args, ru_rhs = rhs }) - = do (env, bndrs') <- simplBinders env bndrs - args' <- mapM (simplExprGently env) args - rhs' <- simplExprGently env rhs - return (rule { ru_bndrs = bndrs', ru_args = args' - , ru_rhs = occurAnalyseExpr rhs' }) -\end{code} + ; Err.dumpIfSet_dyn dflags Opt_D_dump_simpl "Simplified expression" + (pprCoreExpr expr') + + ; return expr' + } -\begin{code} simplExprGently :: SimplEnv -> CoreExpr -> SimplM CoreExpr -- Simplifies an expression -- does occurrence analysis, then simplification @@ -470,77 +292,78 @@ 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 max_iterations mode) + hsc_env us hpt_rule_base guts@(ModGuts { mg_binds = binds, mg_rules = rules , mg_fam_inst_env = fam_inst_env }) - = do { - (termination_msg, it_count, counts_out, guts') - <- do_iteration us 1 (zeroSimplCount dflags) binds rules ; + = do { (termination_msg, it_count, counts_out, guts') + <- do_iteration us 1 [] binds rules - Err.dumpIfSet (dump_phase && dopt Opt_D_dump_simpl_stats dflags) + ; Err.dumpIfSet (dump_phase && dopt Opt_D_dump_simpl_stats dflags) "Simplifier statistics for following pass" (vcat [text termination_msg <+> text "after" <+> ppr it_count <+> text "iterations", blankLine, - pprSimplCount counts_out]); + pprSimplCount counts_out]) - return (counts_out, guts') + ; return (counts_out, guts') } where - dflags = hsc_dflags hsc_env - dump_phase = shouldDumpSimplPhase dflags mode - - sw_chkr = isAmongSimpl switches - max_iterations = intSwitchSet sw_chkr MaxSimplifierIterations `orElse` 2 - + dflags = hsc_dflags hsc_env + dump_phase = dumpSimplPhase dflags mode + simpl_env = mkSimplEnv mode + active_rule = activeRule dflags simpl_env + do_iteration :: UniqSupply - -> Int -- Counts iterations - -> SimplCount -- Logs optimisations performed - -> [CoreBind] -- Bindings in - -> [CoreRule] -- and orphan rules + -> Int -- Counts iterations + -> [SimplCount] -- Counts from earlier iterations, reversed + -> [CoreBind] -- Bindings in + -> [CoreRule] -- and orphan rules -> IO (String, Int, SimplCount, ModGuts) - do_iteration us iteration_no counts binds rules + do_iteration us iteration_no counts_so_far binds rules -- iteration_no is the number of the iteration we are -- about to begin, with '1' for the first | iteration_no > max_iterations -- Stop if we've run out of iterations - = WARN(debugIsOn && (max_iterations > 2), - text ("Simplifier still going after " ++ - show max_iterations ++ - " iterations; bailing out. Size = " ++ show (coreBindsSize binds) ++ "\n" )) + = WARN( debugIsOn && (max_iterations > 2) + , ptext (sLit "Simplifier baling out after") <+> int max_iterations + <+> ptext (sLit "iterations") + <+> (brackets $ hsep $ punctuate comma $ + map (int . simplCountN) (reverse counts_so_far)) + <+> ptext (sLit "Size =") <+> int (coreBindsSize binds) ) + -- Subtract 1 from iteration_no to get the -- number of iterations we actually completed - return ("Simplifier bailed out", iteration_no - 1, counts, - guts { mg_binds = binds, mg_rules = rules }) + return ( "Simplifier baled out", iteration_no - 1 + , totalise counts_so_far + , guts { mg_binds = binds, mg_rules = rules } ) -- Try and force thunks off the binds; significantly reduces -- space usage, especially with -O. JRS, 000620. | let sz = coreBindsSize binds in sz == sz = do { -- Occurrence analysis - let { tagged_binds = {-# SCC "OccAnal" #-} occurAnalysePgm binds rules } ; + let { tagged_binds = {-# SCC "OccAnal" #-} + occurAnalysePgm active_rule rules binds } ; Err.dumpIfSet_dyn dflags Opt_D_dump_occur_anal "Occurrence analysis" (pprCoreBindings tagged_binds); -- Get any new rules, and extend the rule base + -- See Note [Overall plumbing for rules] in Rules.lhs -- We need to do this regularly, because simplification can -- poke on IdInfo thunks, which in turn brings in new rules -- behind the scenes. Otherwise there's a danger we'll simply @@ -548,7 +371,6 @@ simplifyPgmIO mode switches hsc_env us hpt_rule_base eps <- hscEPS hsc_env ; let { rule_base1 = unionRuleBase hpt_rule_base (eps_rule_base eps) ; rule_base2 = extendRuleBaseList rule_base1 rules - ; simpl_env = mkSimplEnv sw_chkr mode ; simpl_binds = {-# SCC "SimplTopBinds" #-} simplTopBinds simpl_env tagged_binds ; fam_envs = (eps_fam_inst_env eps, fam_inst_env) } ; @@ -559,23 +381,23 @@ simplifyPgmIO mode switches hsc_env us hpt_rule_base -- With a let, we ended up with -- let -- t = initSmpl ... - -- counts' = snd t + -- counts1 = snd t -- in - -- case t of {(_,counts') -> if counts'=0 then ... } - -- So the conditional didn't force counts', because the + -- case t of {(_,counts1) -> if counts1=0 then ... } + -- So the conditional didn't force counts1, because the -- selection got duplicated. Sigh! case initSmpl dflags rule_base2 fam_envs us1 simpl_binds of { (env1, counts1) -> do { - let { all_counts = counts `plusSimplCount` counts1 - ; binds1 = getFloats env1 - ; rules1 = substRulesForImportedIds (mkCoreSubst env1) rules + let { binds1 = getFloats env1 + ; rules1 = substRulesForImportedIds (mkCoreSubst (text "imp-rules") env1) rules } ; -- Stop if nothing happened; don't dump output if isZeroSimplCount counts1 then - return ("Simplifier reached fixed point", iteration_no, all_counts, - guts { mg_binds = binds1, mg_rules = rules1 }) + return ( "Simplifier reached fixed point", iteration_no + , totalise (counts1 : counts_so_far) -- Include "free" ticks + , guts { mg_binds = binds1, mg_rules = rules1 } ) else do { -- Short out indirections -- We do this *after* at least one run of the simplifier @@ -588,27 +410,32 @@ 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 - } } } } + do_iteration us2 (iteration_no + 1) (counts1:counts_so_far) binds2 rules1 + } } } } + | otherwise = panic "do_iteration" where - (us1, us2) = splitUniqSupply us + (us1, us2) = splitUniqSupply us + + -- Remember the counts_so_far are reversed + totalise :: [SimplCount] -> SimplCount + totalise = foldr (\c acc -> acc `plusSimplCount` c) + (zeroSimplCount dflags) + +simplifyPgmIO _ _ _ _ _ = panic "simplifyPgmIO" ------------------- -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} @@ -771,10 +598,10 @@ makeIndEnv binds add_pair :: (Id,CoreExpr) -> IndEnv -> IndEnv add_pair (exported_id, Var local_id) env | shortMeOut env exported_id local_id = extendVarEnv env local_id exported_id - add_pair (exported_id, rhs) env - = env + add_pair _ env = env ----------------- +shortMeOut :: IndEnv -> Id -> Id -> Bool shortMeOut ind_env exported_id local_id -- The if-then-else stuff is just so I can get a pprTrace to see -- how often I don't get shorting out becuase of IdInfo stuff