From: keithw Date: Mon, 15 May 2000 15:34:03 +0000 (+0000) Subject: [project @ 2000-05-15 15:34:03 by keithw] X-Git-Tag: Approximately_9120_patches~4456 X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=9df1b97e2fcd4df84542547d57965cd46ccedcc6;p=ghc-hetmet.git [project @ 2000-05-15 15:34:03 by keithw] Adjust treatment of rules in SimplCore to enable a Core pass to alter them if necessary. Use tricks to ensure that the common case (no change) is still efficient. --- diff --git a/ghc/compiler/coreSyn/CoreTidy.lhs b/ghc/compiler/coreSyn/CoreTidy.lhs index 3f5626d..a1bd8ff 100644 --- a/ghc/compiler/coreSyn/CoreTidy.lhs +++ b/ghc/compiler/coreSyn/CoreTidy.lhs @@ -15,12 +15,12 @@ import CmdLineOpts ( opt_D_dump_simpl, opt_D_verbose_core2core, opt_UsageSPOn ) import CoreSyn import CoreUnfold ( noUnfolding ) import CoreLint ( beginPass, endPass ) -import Rules ( ProtoCoreRule(..) ) +import Rules ( ProtoCoreRule(..), RuleBase ) import UsageSPInf ( doUsageSPInf ) import VarEnv import VarSet import Var ( Id, Var ) -import Id ( idType, idInfo, idName, +import Id ( idType, idInfo, idName, idSpecialisation, mkVanillaId, mkId, exportWithOrigOccName, idStrictness, setIdStrictness, idDemandInfo, setIdDemandInfo, @@ -52,34 +52,38 @@ import Outputable Several tasks are done by @tidyCorePgm@ -1. Make certain top-level bindings into Globals. The point is that +1. If @opt_UsageSPOn@ then compute usage information (which is + needed by Core2Stg). ** NOTE _scc_ HERE ** + Do this first, because it may introduce new binders. + +2. Make certain top-level bindings into Globals. The point is that Global things get externally-visible labels at code generation time -2. Give all binders a nice print-name. Their uniques aren't changed; +3. Give all binders a nice print-name. Their uniques aren't changed; rather we give them lexically unique occ-names, so that we can safely print the OccNae only in the interface file. [Bad idea to change the uniques, because the code generator makes global labels from the uniques for local thunks etc.] - -3. If @opt_UsageSPOn@ then compute usage information (which is - needed by Core2Stg). ** NOTE _scc_ HERE ** - \begin{code} -tidyCorePgm :: UniqSupply -> Module -> [CoreBind] -> [ProtoCoreRule] +tidyCorePgm :: UniqSupply -> Module -> [CoreBind] -> RuleBase -> IO ([CoreBind], [ProtoCoreRule]) -tidyCorePgm us module_name binds_in rules +tidyCorePgm us module_name binds_in rulebase_in = do beginPass "Tidy Core" - let (tidy_env1, binds_tidy) = mapAccumL (tidyBind (Just module_name)) init_tidy_env binds_in - rules_out = tidyProtoRules tidy_env1 rules + (binds_in1,mrulebase_in1) <- if opt_UsageSPOn + then _scc_ "CoreUsageSPInf" + doUsageSPInf us binds_in rulebase_in + else return (binds_in,Nothing) + + let rulebase_in1 = maybe rulebase_in id mrulebase_in1 - binds_out <- if opt_UsageSPOn - then _scc_ "CoreUsageSPInf" doUsageSPInf us binds_tidy - else return binds_tidy + (tidy_env1, binds_out) = mapAccumL (tidyBind (Just module_name)) + init_tidy_env binds_in1 + rules_out = tidyProtoRules tidy_env1 (mk_local_protos rulebase_in1) endPass "Tidy Core" (opt_D_dump_simpl || opt_D_verbose_core2core) binds_out return (binds_out, rules_out) @@ -96,6 +100,11 @@ tidyCorePgm us module_name binds_in rules avoids = [getOccName bndr | bndr <- bindersOfBinds binds_in, exportWithOrigOccName bndr] + mk_local_protos :: RuleBase -> [ProtoCoreRule] + mk_local_protos (rule_ids, _) + = [ProtoCoreRule True id rule | id <- varSetElems rule_ids, + rule <- rulesRules (idSpecialisation id)] + tidyBind :: Maybe Module -- (Just m) for top level, Nothing for nested -> TidyEnv -> CoreBind diff --git a/ghc/compiler/simplCore/SimplCore.lhs b/ghc/compiler/simplCore/SimplCore.lhs index 381b5d2..754f7de 100644 --- a/ghc/compiler/simplCore/SimplCore.lhs +++ b/ghc/compiler/simplCore/SimplCore.lhs @@ -21,7 +21,8 @@ import CmdLineOpts ( CoreToDo(..), SimplifierSwitch(..), import CoreLint ( beginPass, endPass ) import CoreSyn import CSE ( cseProgram ) -import Rules ( RuleBase, ProtoCoreRule(..), pprProtoCoreRule, prepareRuleBase, orphanRule ) +import Rules ( RuleBase, ProtoCoreRule(..), pprProtoCoreRule, prepareLocalRuleBase, + prepareOrphanRuleBase, unionRuleBase, localRule, orphanRule ) import CoreUnfold import PprCore ( pprCoreBindings ) import OccurAnal ( occurAnalyseBinds ) @@ -68,6 +69,7 @@ import IO ( hPutStr, stderr ) import Outputable import Ratio ( numerator, denominator ) +import List ( partition ) \end{code} %************************************************************************ @@ -79,8 +81,8 @@ import Ratio ( numerator, denominator ) \begin{code} core2core :: [CoreToDo] -- Spec of what core-to-core passes to do -> [CoreBind] -- Binds in - -> [ProtoCoreRule] -- Rules - -> IO ([CoreBind], [ProtoCoreRule]) + -> [ProtoCoreRule] -- Rules in + -> IO ([CoreBind], RuleBase) -- binds, local orphan rules out core2core core_todos binds rules = do @@ -88,58 +90,83 @@ core2core core_todos binds rules let (cp_us, us1) = splitUniqSupply us (ru_us, ps_us) = splitUniqSupply us1 - better_rules <- simplRules ru_us rules binds + let (local_rules, imported_rules) = partition localRule rules - let all_rules = builtinRules ++ better_rules + better_local_rules <- simplRules ru_us local_rules binds + + let all_imported_rules = builtinRules ++ imported_rules -- Here is where we add in the built-in rules - let (binds1, rule_base) = prepareRuleBase binds all_rules + let (binds1, local_rule_base) = prepareLocalRuleBase binds better_local_rules + imported_rule_base = prepareOrphanRuleBase all_imported_rules -- Do the main business - (stats, processed_binds) <- doCorePasses zeroSimplCount cp_us binds1 - rule_base core_todos + (stats, processed_binds, processed_local_rules) + <- doCorePasses zeroSimplCount cp_us binds1 local_rule_base + imported_rule_base Nothing core_todos dumpIfSet opt_D_dump_simpl_stats "Grand total simplifier statistics" (pprSimplCount stats) -- Return results - return (processed_binds, filter orphanRule better_rules) - + -- We only return local orphan rules, i.e., local rules not attached to an Id + return (processed_binds, processed_local_rules) + + +doCorePasses :: SimplCount -- simplifier stats + -> UniqSupply -- uniques + -> [CoreBind] -- local binds in (with rules attached) + -> RuleBase -- local orphan rules + -> RuleBase -- imported and builtin rules + -> Maybe RuleBase -- combined rulebase, or Nothing to ask for it to be rebuilt + -> [CoreToDo] -- which passes to do + -> IO (SimplCount, [CoreBind], RuleBase) -- stats, binds, local orphan rules -doCorePasses stats us binds irs [] - = return (stats, binds) +doCorePasses stats us binds lrb irb rb0 [] + = return (stats, binds, lrb) -doCorePasses stats us binds irs (to_do : to_dos) +doCorePasses stats us binds lrb irb rb0 (to_do : to_dos) = do - let (us1, us2) = splitUniqSupply us - (stats1, binds1) <- doCorePass us1 binds irs to_do - doCorePasses (stats `plusSimplCount` stats1) us2 binds1 irs to_dos - -doCorePass us binds rb (CoreDoSimplify sw_chkr) = _scc_ "Simplify" simplifyPgm rb sw_chkr us binds -doCorePass us binds rb CoreCSE = _scc_ "CommonSubExpr" noStats (cseProgram binds) -doCorePass us binds rb CoreLiberateCase = _scc_ "LiberateCase" noStats (liberateCase binds) -doCorePass us binds rb CoreDoFloatInwards = _scc_ "FloatInwards" noStats (floatInwards binds) -doCorePass us binds rb (CoreDoFloatOutwards f) = _scc_ "FloatOutwards" noStats (floatOutwards f us binds) -doCorePass us binds rb CoreDoStaticArgs = _scc_ "StaticArgs" noStats (doStaticArgs us binds) -doCorePass us binds rb CoreDoStrictness = _scc_ "Stranal" noStats (saBinds binds) -doCorePass us binds rb CoreDoWorkerWrapper = _scc_ "WorkWrap" noStats (wwTopBinds us binds) -doCorePass us binds rb CoreDoSpecialising = _scc_ "Specialise" noStats (specProgram us binds) -doCorePass us binds rb CoreDoCPResult = _scc_ "CPResult" noStats (cprAnalyse binds) -doCorePass us binds rb CoreDoPrintCore = _scc_ "PrintCore" noStats (printCore binds) -doCorePass us binds rb CoreDoUSPInf + let (us1, us2) = splitUniqSupply us + + -- recompute rulebase if necessary + let rb = maybe (irb `unionRuleBase` lrb) id rb0 + + (stats1, binds1, mlrb1) <- doCorePass us1 binds lrb rb to_do + + -- request rulebase recomputation if pass returned a new local rulebase + let (lrb1,rb1) = maybe (lrb, Just rb) (\ lrb1 -> (lrb1, Nothing)) mlrb1 + + doCorePasses (stats `plusSimplCount` stats1) us2 binds1 lrb1 irb rb1 to_dos + +doCorePass us binds lrb rb (CoreDoSimplify sw_chkr) = _scc_ "Simplify" simplifyPgm rb sw_chkr us binds +doCorePass us binds lrb rb CoreCSE = _scc_ "CommonSubExpr" noStats (cseProgram binds) +doCorePass us binds lrb rb CoreLiberateCase = _scc_ "LiberateCase" noStats (liberateCase binds) +doCorePass us binds lrb rb CoreDoFloatInwards = _scc_ "FloatInwards" noStats (floatInwards binds) +doCorePass us binds lrb rb (CoreDoFloatOutwards f) = _scc_ "FloatOutwards" noStats (floatOutwards f us binds) +doCorePass us binds lrb rb CoreDoStaticArgs = _scc_ "StaticArgs" noStats (doStaticArgs us binds) +doCorePass us binds lrb rb CoreDoStrictness = _scc_ "Stranal" noStats (saBinds binds) +doCorePass us binds lrb rb CoreDoWorkerWrapper = _scc_ "WorkWrap" noStats (wwTopBinds us binds) +doCorePass us binds lrb rb CoreDoSpecialising = _scc_ "Specialise" noStats (specProgram us binds) +doCorePass us binds lrb rb CoreDoCPResult = _scc_ "CPResult" noStats (cprAnalyse binds) +doCorePass us binds lrb rb CoreDoPrintCore = _scc_ "PrintCore" noStats (printCore binds) +doCorePass us binds lrb rb CoreDoUSPInf = _scc_ "CoreUsageSPInf" if opt_UsageSPOn then - noStats (doUsageSPInf us binds) + do + (binds1, rules1) <- doUsageSPInf us binds lrb + return (zeroSimplCount, binds1, rules1) else trace "WARNING: ignoring requested -fusagesp pass; requires -fusagesp-on" $ - noStats (return binds) + return (zeroSimplCount, binds, Nothing) printCore binds = do dumpIfSet True "Print Core" (pprCoreBindings binds) return binds -noStats thing = do { result <- thing; return (zeroSimplCount, result) } +-- most passes return no stats and don't change rules +noStats thing = do { binds <- thing; return (zeroSimplCount, binds, Nothing) } \end{code} @@ -209,8 +236,8 @@ simpl_arg e simplifyPgm :: RuleBase -> (SimplifierSwitch -> SwitchResult) -> UniqSupply - -> [CoreBind] -- Input - -> IO (SimplCount, [CoreBind]) -- New bindings + -> [CoreBind] -- Input + -> IO (SimplCount, [CoreBind], Maybe RuleBase) -- New bindings simplifyPgm (imported_rule_ids, rule_lhs_fvs) sw_chkr us binds @@ -248,7 +275,7 @@ simplifyPgm (imported_rule_ids, rule_lhs_fvs) (opt_D_verbose_core2core && not opt_D_dump_simpl_iterations) binds' ; - return (counts_out, binds') + return (counts_out, binds', Nothing) } where max_iterations = getSimplIntSwitch sw_chkr MaxSimplifierIterations diff --git a/ghc/compiler/simplCore/Simplify.lhs b/ghc/compiler/simplCore/Simplify.lhs index 9f75c40..6cacbdb 100644 --- a/ghc/compiler/simplCore/Simplify.lhs +++ b/ghc/compiler/simplCore/Simplify.lhs @@ -1,4 +1,4 @@ - +% % (c) The AQUA Project, Glasgow University, 1993-1998 % \section[Simplify]{The main module of the simplifier} diff --git a/ghc/compiler/specialise/Rules.lhs b/ghc/compiler/specialise/Rules.lhs index 3777e07..9d77aaf 100644 --- a/ghc/compiler/specialise/Rules.lhs +++ b/ghc/compiler/specialise/Rules.lhs @@ -5,10 +5,10 @@ \begin{code} module Rules ( - RuleBase, prepareRuleBase, lookupRule, addRule, - addIdSpecialisations, + RuleBase, prepareLocalRuleBase, prepareOrphanRuleBase, + unionRuleBase, lookupRule, addRule, addIdSpecialisations, ProtoCoreRule(..), pprProtoCoreRule, - orphanRule + localRule, orphanRule ) where #include "HsVersions.h" @@ -464,6 +464,9 @@ lookupRule in_scope fn args = case idSpecialisation fn of Rules rules _ -> matchRules in_scope rules args +localRule :: ProtoCoreRule -> Bool +localRule (ProtoCoreRule local _ _) = local + orphanRule :: ProtoCoreRule -> Bool -- An "orphan rule" is one that is defined in this -- module, but for an *imported* function. We need @@ -484,17 +487,32 @@ type RuleBase = (IdSet, -- Imported Ids that have rules attached IdSet) -- Ids (whether local or imported) mentioned on -- LHS of some rule; these should be black listed +unionRuleBase (rule_ids1, black_ids1) (rule_ids2, black_ids2) + = (plusUFM_C merge_rules rule_ids1 rule_ids2, + unionVarSet black_ids1 black_ids2) + where + merge_rules id1 id2 = let rules1 = idSpecialisation id1 + rules2 = idSpecialisation id2 + new_rules = foldl (addRule id1) rules1 (rulesRules rules2) + in + setIdSpecialisation id1 new_rules + +-- 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. It also returns +-- Ids mentioned on LHS of some rule; these should be blacklisted. + -- The rule Ids and LHS Ids are black-listed; that is, they aren't inlined -- so that the opportunity to apply the rule isn't lost too soon -prepareRuleBase :: [CoreBind] -> [ProtoCoreRule] -> ([CoreBind], RuleBase) -prepareRuleBase binds all_rules - = (map zap_bind binds, (imported_rule_ids, rule_lhs_fvs)) +prepareLocalRuleBase :: [CoreBind] -> [ProtoCoreRule] -> ([CoreBind], RuleBase) +prepareLocalRuleBase binds local_rules + = (map zap_bind binds, (imported_id_rule_ids, rule_lhs_fvs)) where - (rule_ids, rule_lhs_fvs) = foldr add_rule (emptyVarSet, emptyVarSet) all_rules - imported_rule_ids = filterVarSet (not . isLocallyDefined) rule_ids + (rule_ids, rule_lhs_fvs) = foldr add_rule (emptyVarSet, emptyVarSet) local_rules + imported_id_rule_ids = filterVarSet (not . isLocallyDefined) rule_ids - -- rule_fvs is the set of all variables mentioned in rules + -- rule_fvs is the set of all variables mentioned in this module's rules rule_fvs = foldVarSet (unionVarSet . idRuleVars) rule_lhs_fvs rule_ids -- Attach the rules for each locally-defined Id to that Id. @@ -533,4 +551,11 @@ add_rule (ProtoCoreRule _ id rule) -- locally defined ones!! addRuleToId id rule = setIdSpecialisation id (addRule id (idSpecialisation id) rule) + +-- prepareOrphanRuleBase does exactly the same as prepareLocalRuleBase, except that +-- it assumes that none of the rules can be attached to local Ids. + +prepareOrphanRuleBase :: [ProtoCoreRule] -> RuleBase +prepareOrphanRuleBase imported_rules + = foldr add_rule (emptyVarSet, emptyVarSet) imported_rules \end{code} diff --git a/ghc/compiler/usageSP/UsageSPInf.lhs b/ghc/compiler/usageSP/UsageSPInf.lhs index ee9be6e..d0f062e 100644 --- a/ghc/compiler/usageSP/UsageSPInf.lhs +++ b/ghc/compiler/usageSP/UsageSPInf.lhs @@ -18,6 +18,7 @@ import UsageSPLint import UConSet import CoreSyn +import Rules ( RuleBase ) import TypeRep ( Type(..), TyNote(..) ) -- friend import Type ( UsageAnn(..), applyTy, applyTys, @@ -90,9 +91,11 @@ monad. \begin{code} doUsageSPInf :: UniqSupply -> [CoreBind] - -> IO [CoreBind] + -> RuleBase + -> IO ([CoreBind], Maybe RuleBase) -doUsageSPInf us binds = do +doUsageSPInf us binds local_rules + = do let binds1 = doUnAnnotBinds binds dumpIfSet opt_D_dump_usagesp "UsageSPInf unannot'd" $ @@ -118,7 +121,7 @@ doUsageSPInf us binds = do dumpIfSet opt_D_dump_usagesp "UsageSPInf" $ pprCoreBindings binds3 - return binds3 + return (binds3, Nothing) \end{code} ======================================================================