X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FsimplCore%2FSimplCore.lhs;h=eb354ae080ec85b0b5d747d7aaa7d48add02deee;hb=085afd3e54adb6a240b8c498bae29e4b7402525a;hp=2ff3caaa8d59f580db7ff498e89e95616073d071;hpb=973539a893ff512a3e9ac408c1583a080de0abf4;p=ghc-hetmet.git diff --git a/ghc/compiler/simplCore/SimplCore.lhs b/ghc/compiler/simplCore/SimplCore.lhs index 2ff3caa..eb354ae 100644 --- a/ghc/compiler/simplCore/SimplCore.lhs +++ b/ghc/compiler/simplCore/SimplCore.lhs @@ -8,20 +8,20 @@ module SimplCore ( core2core, simplifyExpr ) where #include "HsVersions.h" -import CmdLineOpts ( CoreToDo(..), SimplifierSwitch(..), SimplifierMode(..), - DynFlags, DynFlag(..), dopt, dopt_CoreToDo +import CmdLineOpts ( CoreToDo(..), SimplifierSwitch(..), + SimplifierMode(..), DynFlags, DynFlag(..), dopt, + dopt_CoreToDo, buildCoreToDo ) import CoreSyn -import CoreFVs ( ruleRhsFreeVars ) -import HscTypes ( PersistentCompilerState(..), - PackageRuleBase, HomeSymbolTable, IsExported, ModDetails(..) - ) +import TcIface ( loadImportedRules ) +import HscTypes ( HscEnv(..), ModGuts(..), ModGuts, + ModDetails(..), HomeModInfo(..) ) import CSE ( cseProgram ) -import Rules ( RuleBase, emptyRuleBase, ruleBaseFVs, ruleBaseIds, - extendRuleBaseList, addRuleBaseFVs, pprRuleBase, +import Rules ( RuleBase, ruleBaseIds, + extendRuleBaseList, pprRuleBase, getLocalRules, ruleCheckProgram ) import Module ( moduleEnvElts ) -import PprCore ( pprCoreBindings, pprCoreExpr ) +import PprCore ( pprCoreBindings, pprCoreExpr, pprIdRules ) import OccurAnal ( occurAnalyseBinds, occurAnalyseGlobalExpr ) import CoreUtils ( coreBindsSize ) import Simplify ( simplTopBinds, simplExpr ) @@ -31,24 +31,24 @@ import ErrUtils ( dumpIfSet, dumpIfSet_dyn, showPass ) import CoreLint ( endPass ) import FloatIn ( floatInwards ) import FloatOut ( floatOutwards ) -import Id ( idName, setIdLocalExported ) +import Id ( idIsFrom, idSpecialisation, setIdSpecialisation ) import VarSet import LiberateCase ( liberateCase ) import SAT ( doStaticArgs ) import Specialise ( specProgram) import SpecConstr ( specConstrProgram) -import UsageSPInf ( doUsageSPInf ) -import StrictAnal ( saBinds ) import DmdAnal ( dmdAnalPgm ) import WorkWrap ( wwTopBinds ) +#ifdef OLD_STRICTNESS +import StrictAnal ( saBinds ) import CprAnalyse ( cprAnalyse ) +#endif import UniqSupply ( UniqSupply, mkSplitUniqSupply, splitUniqSupply ) import IO ( hPutStr, stderr ) import Outputable import Maybes ( orElse ) -import List ( partition ) \end{code} %************************************************************************ @@ -58,29 +58,27 @@ import List ( partition ) %************************************************************************ \begin{code} -core2core :: DynFlags -- includes spec of what core-to-core passes to do - -> PersistentCompilerState - -> HomeSymbolTable - -> IsExported - -> ModDetails - -> IO ModDetails - -core2core dflags pcs hst is_exported - mod_details@(ModDetails { md_binds = binds_in, md_rules = rules_in }) +core2core :: HscEnv + -> ModGuts + -> IO ModGuts + +core2core hsc_env + mod_impl@(ModGuts { mg_binds = binds_in }) = do - let core_todos = dopt_CoreToDo dflags - let pkg_rule_base = pcs_rules pcs -- Rule-base accumulated from imported packages - + let dflags = hsc_dflags hsc_env + core_todos + | Just todo <- dopt_CoreToDo dflags = todo + | otherwise = buildCoreToDo dflags us <- mkSplitUniqSupply 's' let (cp_us, ru_us) = splitUniqSupply us -- COMPUTE THE RULE BASE TO USE - (rule_base, local_rule_ids, orphan_rules, rule_rhs_fvs) - <- prepareRules dflags pkg_rule_base hst ru_us binds_in rules_in + (rule_base, local_rule_ids, orphan_rules) + <- prepareRules hsc_env mod_impl ru_us -- PREPARE THE BINDINGS - let binds1 = updateBinders local_rule_ids rule_rhs_fvs is_exported binds_in + let binds1 = updateBinders local_rule_ids binds_in -- DO THE BUSINESS (stats, processed_binds) @@ -93,23 +91,21 @@ core2core dflags pcs hst is_exported -- 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_details { md_binds = processed_binds, md_rules = orphan_rules}) + return (mod_impl { mg_binds = processed_binds, mg_rules = orphan_rules}) simplifyExpr :: DynFlags -- includes spec of what core-to-core passes to do - -> PersistentCompilerState - -> HomeSymbolTable -> CoreExpr -> IO CoreExpr -- simplifyExpr is called by the driver to simplify an -- expression typed in at the interactive prompt -simplifyExpr dflags pcs hst expr +simplifyExpr dflags expr = do { ; showPass dflags "Simplify" ; us <- mkSplitUniqSupply 's' - ; let env = emptySimplEnv (SimplPhase 0) [] emptyVarSet + ; let env = emptySimplEnv SimplGently [] emptyVarSet (expr', _counts) = initSmpl dflags us (simplExprGently env expr) ; dumpIfSet_dyn dflags Opt_D_dump_simpl "Simplified expression" @@ -151,21 +147,19 @@ doCorePass dfs rb us binds (CoreDoFloatOutwards f) doCorePass dfs rb us binds CoreDoStaticArgs = _scc_ "StaticArgs" noStats dfs (doStaticArgs us binds) doCorePass dfs rb us binds CoreDoStrictness - = _scc_ "Stranal" noStats dfs (strictAnal dfs binds) + = _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 DEBUG -doCorePass dfs rb us binds CoreDoCPResult - = _scc_ "CPResult" noStats dfs (cprAnalyse dfs binds) +#ifdef OLD_STRICTNESS +doCorePass dfs rb us binds CoreDoOldStrictness + = _scc_ "OldStrictness" noStats dfs (doOldStrictness dfs binds) #endif doCorePass dfs rb us binds CoreDoPrintCore = _scc_ "PrintCore" noStats dfs (printCore binds) -doCorePass dfs rb us binds CoreDoUSPInf - = _scc_ "CoreUsageSPInf" noStats dfs (doUsageSPInf dfs us binds) doCorePass dfs rb us binds CoreDoGlomBinds = noStats dfs (glomBinds dfs binds) doCorePass dfs rb us binds (CoreDoRuleCheck phase pat) @@ -173,11 +167,12 @@ doCorePass dfs rb us binds (CoreDoRuleCheck phase pat) doCorePass dfs rb us binds CoreDoNothing = noStats dfs (return binds) -strictAnal dfs binds = do -#ifdef DEBUG - binds <- saBinds dfs binds +#ifdef OLD_STRICTNESS +doOldStrictness dfs binds + = do binds1 <- saBinds dfs binds + binds2 <- cprAnalyse dfs binds1 + return binds2 #endif - dmdAnalPgm dfs binds printCore binds = do dumpIfSet True "Print Core" (pprCoreBindings binds) @@ -209,64 +204,52 @@ noStats dfs thing = do { binds <- thing; return (zeroSimplCount dfs, binds) } -- so that the opportunity to apply the rule isn't lost too soon \begin{code} -prepareRules :: DynFlags -> PackageRuleBase -> HomeSymbolTable +prepareRules :: HscEnv + -> ModGuts -> UniqSupply - -> [CoreBind] - -> [IdCoreRule] -- Local rules -> IO (RuleBase, -- Full rule base IdSet, -- Local rule Ids - [IdCoreRule], -- Orphan rules - IdSet) -- RHS free vars of all rules + [IdCoreRule]) -- Orphan rules defined in this module + +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 -prepareRules dflags pkg_rule_base hst us binds local_rules - = do { let env = emptySimplEnv SimplGently [] local_ids + ; let env = emptySimplEnv SimplGently [] local_ids (better_rules,_) = initSmpl dflags us (mapSmpl (simplRule env) local_rules) - ; let (local_rules, orphan_rules) = partition ((`elemVarSet` local_ids) . fst) better_rules - -- We use (`elemVarSet` local_ids) rather than isLocalId because - -- isLocalId isn't true of class methods. - -- 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 the - -- same as the rule-id set), 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 #-} - - rule_rhs_fvs = unionVarSets (map (ruleRhsFreeVars . snd) better_rules) - local_rule_base = extendRuleBaseList emptyRuleBase local_rules - local_rule_ids = ruleBaseIds local_rule_base -- Local Ids with rules attached - imp_rule_base = foldl add_rules pkg_rule_base (moduleEnvElts hst) - rule_base = extendRuleBaseList imp_rule_base orphan_rules - final_rule_base = addRuleBaseFVs rule_base (ruleBaseFVs local_rule_base) - -- The last step black-lists the free vars of local rules too + 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 ; dumpIfSet_dyn dflags Opt_D_dump_rules "Transformation rules" - (vcat [text "Local rules", pprRuleBase local_rule_base, + (vcat [text "Local rules", pprIdRules better_rules, text "", text "Imported rules", pprRuleBase final_rule_base]) - ; return (final_rule_base, local_rule_ids, orphan_rules, rule_rhs_fvs) + ; return (final_rule_base, local_rule_ids, orphan_rules) } where - add_rules rule_base mds = extendRuleBaseList rule_base (md_rules mds) + 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 - -> IdSet -- Ids free in the RHS of local rules - -> IsExported -> [CoreBind] -> [CoreBind] -- A horrible function --- Update the binders of top-level bindings as follows --- a) Attach the rules for each locally-defined Id to that Id. --- b) Set the no-discard flag if either the Id is exported, --- or it's mentoined in the RHS of a rule +-- Update the binders of top-level bindings by +-- attaching the rules for each locally-defined Id to that Id. -- --- Reason for (a) +-- Reason -- - It makes the rules easier to look up -- - It means that transformation rules and specialisations for -- locally defined Ids are handled uniformly @@ -274,28 +257,20 @@ updateBinders :: IdSet -- Locally defined ids with their Rules attached -- (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 --- --- Reason for (b) --- It means that the binding won't be discarded EVEN if the binding --- ends up being trivial (v = w) -- the simplifier would usually just --- substitute w for v throughout, but we don't apply the substitution to --- the rules (maybe we should?), so this substitution would make the rule --- bogus. - -updateBinders rule_ids rule_rhs_fvs is_exported binds +-- - 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 = map update_bndrs binds where update_bndrs (NonRec b r) = NonRec (update_bndr b) r update_bndrs (Rec prs) = Rec [(update_bndr b, r) | (b,r) <- prs] - update_bndr bndr - | dont_discard bndr = setIdLocalExported bndr_with_rules - | otherwise = bndr_with_rules - where - bndr_with_rules = lookupVarSet rule_ids bndr `orElse` bndr - - dont_discard bndr = is_exported (idName bndr) - || bndr `elemVarSet` rule_rhs_fvs + update_bndr bndr = case lookupVarSet rule_ids bndr of + Nothing -> bndr + Just id -> bndr `setIdSpecialisation` idSpecialisation id \end{code} @@ -334,6 +309,11 @@ simplExprGently :: SimplEnv -> CoreExpr -> SimplM CoreExpr -- alone leaves tons of crud. -- Used (a) for user expressions typed in at the interactive prompt -- (b) the LHS and RHS of a RULE +-- +-- The name 'Gently' suggests that the SimplifierMode is SimplGently, +-- and in fact that is so.... but the 'Gently' in simplExprGently doesn't +-- enforce that; it just simplifies the expression twice + simplExprGently env expr = simplExpr env (occurAnalyseGlobalExpr expr) `thenSmpl` \ expr1 -> simplExpr env (occurAnalyseGlobalExpr expr1) @@ -427,6 +407,23 @@ simplifyPgm dflags rule_base max_iterations = intSwitchSet sw_chkr MaxSimplifierIterations `orElse` 2 iteration us iteration_no counts binds + -- 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 + = do { +#ifdef DEBUG + if max_iterations > 2 then + hPutStr stderr ("NOTE: Simplifier still going after " ++ + show max_iterations ++ + " iterations; bailing out.\n") + else + return (); +#endif + -- Subtract 1 from iteration_no to get the + -- number of iterations we actually completed + return ("Simplifier baled out", iteration_no - 1, counts, binds) + } + -- Try and force thunks off the binds; significantly reduces -- space usage, especially with -O. JRS, 000620. | let sz = coreBindsSize binds in sz == sz @@ -445,7 +442,7 @@ simplifyPgm dflags rule_base -- t = initSmpl ... -- counts' = snd t -- in - -- case t of {(_,counts') -> if counts'=0 then ... + -- 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 { @@ -468,27 +465,12 @@ simplifyPgm dflags rule_base -- Dump the result of this iteration dumpIfSet_dyn dflags Opt_D_dump_simpl_iterations herald - (pprSimplCount counts') ; + (pprSimplCount counts') ; endPass dflags herald Opt_D_dump_simpl_iterations binds' ; - -- Stop if we've run out of iterations - if iteration_no == max_iterations then - do { -#ifdef DEBUG - if max_iterations > 2 then - hPutStr stderr ("NOTE: Simplifier still going after " ++ - show max_iterations ++ - " iterations; bailing out.\n") - else -#endif - return (); - - return ("Simplifier baled out", iteration_no, all_counts, binds') - } - - -- Else loop - else iteration us2 (iteration_no + 1) all_counts binds' + -- Loop + iteration us2 (iteration_no + 1) all_counts binds' } } } } where (us1, us2) = splitUniqSupply us