X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FsimplCore%2FSimplCore.lhs;fp=ghc%2Fcompiler%2FsimplCore%2FSimplCore.lhs;h=8df100a3ec5d98eab7ac6c881b4e5dd0541b5711;hb=711ede5f855b3d29c38968e84df952a1555b781f;hp=4ee26a0f1802aa3303e7a5acd76717983f6d698b;hpb=272163f08c4392a5e0a40e31330c813e04da9061;p=ghc-hetmet.git diff --git a/ghc/compiler/simplCore/SimplCore.lhs b/ghc/compiler/simplCore/SimplCore.lhs index 4ee26a0..8df100a 100644 --- a/ghc/compiler/simplCore/SimplCore.lhs +++ b/ghc/compiler/simplCore/SimplCore.lhs @@ -14,12 +14,11 @@ import CmdLineOpts ( CoreToDo(..), SimplifierSwitch(..), ) import CoreSyn import TcIface ( loadImportedRules ) -import HscTypes ( HscEnv(..), ModGuts(..), ModGuts, - ModDetails(..), HomeModInfo(..) ) +import HscTypes ( HscEnv(..), ModGuts(..), ExternalPackageState(..), + ModDetails(..), HomeModInfo(..), hscEPS ) import CSE ( cseProgram ) -import Rules ( RuleBase, ruleBaseIds, - extendRuleBaseList, pprRuleBase, getLocalRules, - ruleCheckProgram ) +import Rules ( RuleBase, ruleBaseIds, emptyRuleBase, + extendRuleBaseList, pprRuleBase, ruleCheckProgram ) import Module ( moduleEnvElts ) import PprCore ( pprCoreBindings, pprCoreExpr, pprIdRules ) import OccurAnal ( occurAnalyseBinds, occurAnalyseGlobalExpr ) @@ -29,6 +28,7 @@ import SimplUtils ( simplBinders ) import SimplMonad import ErrUtils ( dumpIfSet, dumpIfSet_dyn, showPass ) import CoreLint ( endPass ) +import Subst ( mkInScopeSet ) import FloatIn ( floatInwards ) import FloatOut ( floatOutwards ) import Id ( idIsFrom, idSpecialisation, setIdSpecialisation ) @@ -47,7 +47,7 @@ import CprAnalyse ( cprAnalyse ) import UniqSupply ( UniqSupply, mkSplitUniqSupply, splitUniqSupply ) import IO ( hPutStr, stderr ) import Outputable - +import List ( partition ) import Maybes ( orElse ) \end{code} @@ -62,36 +62,29 @@ core2core :: HscEnv -> ModGuts -> IO ModGuts -core2core hsc_env - mod_impl@(ModGuts { mg_binds = binds_in }) +core2core hsc_env guts = do - let dflags = hsc_dflags hsc_env + let dflags = hsc_dflags hsc_env core_todos | Just todo <- dopt_CoreToDo dflags = todo | otherwise = buildCoreToDo dflags - us <- mkSplitUniqSupply 's' + us <- mkSplitUniqSupply 's' let (cp_us, ru_us) = splitUniqSupply us -- COMPUTE THE RULE BASE TO USE - (rule_base, local_rule_ids, orphan_rules) - <- prepareRules hsc_env mod_impl ru_us - - -- PREPARE THE BINDINGS - let binds1 = updateBinders local_rule_ids binds_in + (imp_rule_base, guts') <- prepareRules hsc_env guts ru_us -- DO THE BUSINESS - (stats, processed_binds) - <- doCorePasses dflags rule_base (zeroSimplCount dflags) cp_us binds1 core_todos + (stats, guts'') <- doCorePasses hsc_env cp_us + (zeroSimplCount dflags) + imp_rule_base guts' core_todos dumpIfSet_dyn dflags Opt_D_dump_simpl_stats "Grand total simplifier statistics" (pprSimplCount stats) - -- Return results - -- We only return local orphan rules, i.e., local rules not attached to an Id - -- The bindings cotain more rules, embedded in the Ids - return (mod_impl { mg_binds = processed_binds, mg_rules = orphan_rules}) + return guts'' simplifyExpr :: DynFlags -- includes spec of what core-to-core passes to do @@ -105,7 +98,7 @@ simplifyExpr dflags expr ; us <- mkSplitUniqSupply 's' - ; let env = emptySimplEnv SimplGently [] emptyVarSet + ; let env = emptySimplEnv SimplGently [] (expr', _counts) = initSmpl dflags us (simplExprGently env expr) ; dumpIfSet_dyn dflags Opt_D_dump_simpl "Simplified expression" @@ -114,77 +107,81 @@ simplifyExpr dflags expr ; return expr' } - -doCorePasses :: DynFlags - -> RuleBase -- the main rule base - -> SimplCount -- simplifier stats +doCorePasses :: HscEnv -> UniqSupply -- uniques - -> [CoreBind] -- local binds in (with rules attached) + -> SimplCount -- simplifier stats + -> RuleBase -- the main rule base + -> ModGuts -- local binds in (with rules attached) -> [CoreToDo] -- which passes to do - -> IO (SimplCount, [CoreBind]) -- stats, binds, local orphan rules + -> IO (SimplCount, ModGuts) -doCorePasses dflags rb stats us binds [] - = return (stats, binds) +doCorePasses hsc_env us stats rb guts [] + = return (stats, guts) -doCorePasses dflags rb stats us binds (to_do : to_dos) +doCorePasses hsc_env us stats rb guts (to_do : to_dos) = do let (us1, us2) = splitUniqSupply us - - (stats1, binds1) <- doCorePass dflags rb us1 binds to_do - - doCorePasses dflags rb (stats `plusSimplCount` stats1) us2 binds1 to_dos - -doCorePass dfs rb us binds (CoreDoSimplify mode switches) - = _scc_ "Simplify" simplifyPgm dfs rb mode switches us binds -doCorePass dfs rb us binds CoreCSE - = _scc_ "CommonSubExpr" noStats dfs (cseProgram dfs binds) -doCorePass dfs rb us binds CoreLiberateCase - = _scc_ "LiberateCase" noStats dfs (liberateCase dfs binds) -doCorePass dfs rb us binds CoreDoFloatInwards - = _scc_ "FloatInwards" noStats dfs (floatInwards dfs binds) -doCorePass dfs rb us binds (CoreDoFloatOutwards f) - = _scc_ "FloatOutwards" noStats dfs (floatOutwards dfs f us binds) -doCorePass dfs rb us binds CoreDoStaticArgs - = _scc_ "StaticArgs" noStats dfs (doStaticArgs us binds) -doCorePass dfs rb us binds CoreDoStrictness - = _scc_ "Stranal" noStats dfs (dmdAnalPgm dfs binds) -doCorePass dfs rb us binds CoreDoWorkerWrapper - = _scc_ "WorkWrap" noStats dfs (wwTopBinds dfs us binds) -doCorePass dfs rb us binds CoreDoSpecialising - = _scc_ "Specialise" noStats dfs (specProgram dfs us binds) -doCorePass dfs rb us binds CoreDoSpecConstr - = _scc_ "SpecConstr" noStats dfs (specConstrProgram dfs us binds) -#ifdef OLD_STRICTNESS -doCorePass dfs rb us binds CoreDoOldStrictness - = _scc_ "OldStrictness" noStats dfs (doOldStrictness dfs binds) + (stats1, rb1, guts1) <- doCorePass to_do hsc_env us1 rb guts + doCorePasses hsc_env us2 (stats `plusSimplCount` stats1) rb1 guts1 to_dos + +doCorePass (CoreDoSimplify mode sws) = _scc_ "Simplify" simplifyPgm mode sws +doCorePass CoreCSE = _scc_ "CommonSubExpr" trBinds cseProgram +doCorePass CoreLiberateCase = _scc_ "LiberateCase" trBinds liberateCase +doCorePass CoreDoFloatInwards = _scc_ "FloatInwards" trBinds floatInwards +doCorePass (CoreDoFloatOutwards f) = _scc_ "FloatOutwards" trBindsU (floatOutwards f) +doCorePass CoreDoStaticArgs = _scc_ "StaticArgs" trBinds doStaticArgs +doCorePass CoreDoStrictness = _scc_ "Stranal" trBinds dmdAnalPgm +doCorePass CoreDoWorkerWrapper = _scc_ "WorkWrap" trBindsU wwTopBinds +doCorePass CoreDoSpecialising = _scc_ "Specialise" trBindsU specProgram +doCorePass CoreDoSpecConstr = _scc_ "SpecConstr" trBindsU specConstrProgram +doCorePass CoreDoGlomBinds = trBinds glomBinds +doCorePass CoreDoPrintCore = observe printCore +doCorePass (CoreDoRuleCheck phase pat) = observe (ruleCheck phase pat) +doCorePass CoreDoNothing = observe (\ _ _ -> return ()) +#ifdef OLD_STRICTNESS +doCorePass CoreDoOldStrictness = _scc_ "OldStrictness" trBinds doOldStrictness #endif -doCorePass dfs rb us binds CoreDoPrintCore - = _scc_ "PrintCore" noStats dfs (printCore binds) -doCorePass dfs rb us binds CoreDoGlomBinds - = noStats dfs (glomBinds dfs binds) -doCorePass dfs rb us binds (CoreDoRuleCheck phase pat) - = noStats dfs (ruleCheck dfs phase pat binds) -doCorePass dfs rb us binds CoreDoNothing - = noStats dfs (return binds) #ifdef OLD_STRICTNESS -doOldStrictness dfs binds +doOldStrictness dfs binds = do binds1 <- saBinds dfs binds binds2 <- cprAnalyse dfs binds1 return binds2 #endif -printCore binds = do dumpIfSet True "Print Core" - (pprCoreBindings binds) - return binds +printCore _ binds = dumpIfSet True "Print Core" (pprCoreBindings binds) -ruleCheck dflags phase pat binds = do showPass dflags "RuleCheck" +ruleCheck phase pat dflags binds = do showPass dflags "RuleCheck" printDump (ruleCheckProgram phase pat binds) - return binds - --- most passes return no stats and don't change rules -noStats dfs thing = do { binds <- thing; return (zeroSimplCount dfs, binds) } +-- Most passes return no stats and don't change rules +trBinds :: (DynFlags -> [CoreBind] -> IO [CoreBind]) + -> HscEnv -> UniqSupply -> RuleBase -> ModGuts + -> IO (SimplCount, RuleBase, ModGuts) +trBinds do_pass hsc_env us rb guts + = do { binds' <- do_pass dflags (mg_binds guts) + ; return (zeroSimplCount dflags, rb, guts { mg_binds = binds' }) } + where + dflags = hsc_dflags hsc_env + +trBindsU :: (DynFlags -> UniqSupply -> [CoreBind] -> IO [CoreBind]) + -> HscEnv -> UniqSupply -> RuleBase -> ModGuts + -> IO (SimplCount, RuleBase, ModGuts) +trBindsU do_pass hsc_env us rb guts + = do { binds' <- do_pass dflags us (mg_binds guts) + ; return (zeroSimplCount dflags, rb, guts { mg_binds = binds' }) } + where + dflags = hsc_dflags hsc_env + +-- Observer passes just peek; don't modify the bindings at all +observe :: (DynFlags -> [CoreBind] -> IO a) + -> HscEnv -> UniqSupply -> RuleBase -> ModGuts + -> IO (SimplCount, RuleBase, ModGuts) +observe do_pass hsc_env us rb guts + = do { binds <- do_pass dflags (mg_binds guts) + ; return (zeroSimplCount dflags, rb, guts) } + where + dflags = hsc_dflags hsc_env \end{code} @@ -203,64 +200,85 @@ noStats dfs thing = do { binds <- thing; return (zeroSimplCount dfs, binds) } prepareRules :: HscEnv -> ModGuts -> UniqSupply - -> IO (RuleBase, -- Full rule base - IdSet, -- Local rule Ids - [IdCoreRule]) -- Orphan rules defined in this module + -> IO (RuleBase, -- Rule base for imported things, incl + -- (a) rules defined in this module (orphans) + -- (b) rules from other packages + -- (c) rules from other modules in home package + ModGuts) -- Modified fields are + -- (a) Bindings have rules attached, + -- (b) Rules are now just orphan rules prepareRules hsc_env@(HscEnv { hsc_dflags = dflags, hsc_HPT = hpt }) guts@(ModGuts { mg_binds = binds, mg_rules = local_rules, mg_module = this_mod }) us - = do { pkg_rule_base <- loadImportedRules hsc_env guts + = do { eps <- hscEPS hsc_env - ; let env = emptySimplEnv SimplGently [] local_ids + ; 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 (emptySimplEnv SimplGently []) local_ids (better_rules,_) = initSmpl dflags us (mapSmpl (simplRule env) local_rules) - imp_rule_base = foldl add_rules pkg_rule_base (moduleEnvElts hpt) - full_rule_base = extendRuleBaseList imp_rule_base better_rules - - (local_rule_ids, final_rule_base) = getLocalRules this_mod full_rule_base - -- NB: the imported rules may include rules for Ids in this module - -- which is why we suck the local rules out of full_rule_base - - orphan_rules = filter (not . idIsFrom this_mod . fst) better_rules + (rules_for_locals, orphan_rules) = partition is_local_rule better_rules + is_local_rule (id,_) = idIsFrom this_mod id + -- Get the rules for locally-defined Ids out of the RuleBase + -- If we miss any rules for Ids defined here, then we end up + -- giving the local decl a new Unique (because the in-scope-set is (hackily) the + -- same as the non-local-rule-id set, so the Id looks as if it's in scope + -- and hence should be cloned), and now the binding for the class method + -- doesn't have the same Unique as the one in the Class and the tc-env + -- Example: class Foo a where + -- op :: a -> a + -- {-# RULES "op" op x = x #-} + -- + -- NB we can't use isLocalId, because isLocalId isn't true of class methods. + + -- NB: we assume that the imported rules dont include + -- rules for Ids in this module; if there is, the above bad things may happen + + pkg_rule_base = eps_rule_base eps + hpt_rule_base = foldl add_rules pkg_rule_base (moduleEnvElts hpt) + imp_rule_base = extendRuleBaseList hpt_rule_base orphan_rules + + -- Update the binders in the local bindings with the lcoal rules + -- Update the binders of top-level bindings by + -- attaching the rules for each locally-defined Id to that Id. + -- + -- 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 + local_rule_base = extendRuleBaseList emptyRuleBase rules_for_locals + binds_w_rules = updateBinders local_rule_base binds ; dumpIfSet_dyn dflags Opt_D_dump_rules "Transformation rules" (vcat [text "Local rules", pprIdRules better_rules, text "", - text "Imported rules", pprRuleBase final_rule_base]) + text "Imported rules", pprRuleBase imp_rule_base]) - ; return (final_rule_base, local_rule_ids, orphan_rules) +#ifdef DEBUG + ; let bad_rules = filter (idIsFrom this_mod) (varSetElems (ruleBaseIds imp_rule_base)) + ; WARN( not (null bad_rules), ppr bad_rules ) return () +#endif + ; return (imp_rule_base, guts { mg_binds = binds_w_rules, mg_rules = orphan_rules }) } where add_rules rule_base mod_info = extendRuleBaseList rule_base (md_rules (hm_details mod_info)) - -- Boringly, we need to gather the in-scope set. - local_ids = foldr (unionVarSet . mkVarSet . bindersOf) emptyVarSet binds - - -updateBinders :: IdSet -- Locally defined ids with their Rules attached - -> [CoreBind] -> [CoreBind] - -- A horrible function - --- Update the binders of top-level bindings by --- attaching the rules for each locally-defined Id to that Id. --- --- 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 rule_ids binds +updateBinders :: RuleBase -> [CoreBind] -> [CoreBind] +updateBinders rule_base binds = map update_bndrs binds where + rule_ids = ruleBaseIds rule_base + update_bndrs (NonRec b r) = NonRec (update_bndr b) r update_bndrs (Rec prs) = Rec [(update_bndr b, r) | (b,r) <- prs] @@ -365,21 +383,20 @@ glomBinds dflags binds %************************************************************************ \begin{code} -simplifyPgm :: DynFlags - -> RuleBase - -> SimplifierMode +simplifyPgm :: SimplifierMode -> [SimplifierSwitch] + -> HscEnv -> UniqSupply - -> [CoreBind] -- Input - -> IO (SimplCount, [CoreBind]) -- New bindings + -> RuleBase + -> ModGuts + -> IO (SimplCount, RuleBase, ModGuts) -- New bindings -simplifyPgm dflags rule_base - mode switches us binds +simplifyPgm mode switches hsc_env us rule_base guts = do { showPass dflags "Simplify"; - (termination_msg, it_count, counts_out, binds') - <- iteration us 1 (zeroSimplCount dflags) binds; + (termination_msg, it_count, counts_out, rule_base', guts') + <- do_iteration us rule_base 1 (zeroSimplCount dflags) guts; dumpIfSet (dopt Opt_D_verbose_core2core dflags && dopt Opt_D_dump_simpl_stats dflags) @@ -388,21 +405,21 @@ simplifyPgm dflags rule_base text "", pprSimplCount counts_out]); - endPass dflags "Simplify" Opt_D_verbose_core2core binds'; + endPass dflags "Simplify" Opt_D_verbose_core2core (mg_binds guts'); - return (counts_out, binds') + return (counts_out, rule_base', guts') } where + dflags = hsc_dflags hsc_env phase_info = case mode of SimplGently -> "gentle" SimplPhase n -> show n - imported_rule_ids = ruleBaseIds rule_base - simpl_env = emptySimplEnv mode switches imported_rule_ids + simpl_env = emptySimplEnv mode switches sw_chkr = getSwitchChecker simpl_env max_iterations = intSwitchSet sw_chkr MaxSimplifierIterations `orElse` 2 - iteration us iteration_no counts binds + do_iteration us rule_base iteration_no counts guts -- 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 @@ -417,20 +434,37 @@ simplifyPgm dflags rule_base #endif -- Subtract 1 from iteration_no to get the -- number of iterations we actually completed - return ("Simplifier baled out", iteration_no - 1, counts, binds) + return ("Simplifier baled out", iteration_no - 1, counts, rule_base, guts) } -- Try and force thunks off the binds; significantly reduces -- space usage, especially with -O. JRS, 000620. - | let sz = coreBindsSize binds in sz == sz + | let sz = coreBindsSize (mg_binds guts) in sz == sz = do { -- Occurrence analysis - let { tagged_binds = _scc_ "OccAnal" occurAnalyseBinds binds } ; + let { tagged_binds = _scc_ "OccAnal" occurAnalyseBinds (mg_binds guts) } ; dumpIfSet_dyn dflags Opt_D_dump_occur_anal "Occurrence analysis" (pprCoreBindings tagged_binds); - -- SIMPLIFY + -- Get any new rules, and extend the rule base + -- (on the side this extends the package rule base in the + -- ExternalPackageTable, ready for the next complation + -- in --make mode) + -- 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 + -- miss the rules for Ids hidden inside imported inlinings + new_rules <- loadImportedRules hsc_env guts ; + let { rule_base' = extendRuleBaseList rule_base new_rules + ; in_scope = mkInScopeSet (ruleBaseIds rule_base') + ; simpl_env' = setInScopeSet simpl_env in_scope } ; + -- The new rule base Ids are used to initialise + -- the in-scope set. That way, the simplifier will change any + -- occurrences of the imported id to the one in the imported_rule_ids + -- set, which are decorated with their rules. + + -- Simplify the program -- We do this with a *case* not a *let* because lazy pattern -- matching bit us with bad space leak! -- With a let, we ended up with @@ -441,22 +475,20 @@ simplifyPgm dflags rule_base -- case t of {(_,counts') -> if counts'=0 then ... } -- So the conditional didn't force counts', because the -- selection got duplicated. Sigh! - case initSmpl dflags us1 (simplTopBinds simpl_env tagged_binds) of { + case initSmpl dflags us1 (simplTopBinds simpl_env' tagged_binds) of { (binds', counts') -> do { - -- The imported_rule_ids are used by initSmpl to initialise - -- the in-scope set. That way, the simplifier will change any - -- occurrences of the imported id to the one in the imported_rule_ids - -- set, which are decorated with their rules. - let { all_counts = counts `plusSimplCount` counts' ; - herald = "Simplifier phase " ++ phase_info ++ + let { guts' = guts { mg_binds = binds' } + ; all_counts = counts `plusSimplCount` counts' + ; herald = "Simplifier phase " ++ phase_info ++ ", iteration " ++ show iteration_no ++ " out of " ++ show max_iterations } ; -- Stop if nothing happened; don't dump output if isZeroSimplCount counts' then - return ("Simplifier reached fixed point", iteration_no, all_counts, binds') + return ("Simplifier reached fixed point", iteration_no, + all_counts, rule_base', guts') else do { -- Dump the result of this iteration @@ -466,7 +498,7 @@ simplifyPgm dflags rule_base endPass dflags herald Opt_D_dump_simpl_iterations binds' ; -- Loop - iteration us2 (iteration_no + 1) all_counts binds' + do_iteration us2 rule_base' (iteration_no + 1) all_counts guts' } } } } where (us1, us2) = splitUniqSupply us