)
import CoreLint ( beginPass, endPass )
import CoreSyn
+import CoreFVs ( ruleSomeFreeVars )
+import HscTypes ( PackageRuleBase, HomeSymbolTable, ModDetails(..) )
import CSE ( cseProgram )
-import Rules ( RuleBase, ProtoCoreRule(..), pprProtoCoreRule, prepareLocalRuleBase,
- prepareOrphanRuleBase, unionRuleBase, localRule )
+import Rules ( RuleBase, emptyRuleBase, ruleBaseFVs, ruleBaseIds, extendRuleBaseList, addRuleBaseFVs )
+import Module ( moduleEnvElts )
import CoreUnfold
-import PprCore ( pprCoreBindings )
+import PprCore ( pprCoreBindings, pprIdCoreRule )
import OccurAnal ( occurAnalyseBinds )
-import CoreUtils ( exprIsTrivial, etaReduceExpr, coreBindsSize )
+import CoreUtils ( etaReduceExpr, coreBindsSize )
import Simplify ( simplTopBinds, simplExpr )
import SimplUtils ( simplBinders )
import SimplMonad
import ErrUtils ( dumpIfSet, dumpIfSet_dyn )
import FloatIn ( floatInwards )
import FloatOut ( floatOutwards )
-import Id ( isDataConWrapId )
+import Id ( Id, isDataConWrapId, setIdNoDiscard )
import VarSet
import LiberateCase ( liberateCase )
import SAT ( doStaticArgs )
\begin{code}
core2core :: DynFlags
+ -> PackageRuleBase -- Rule-base accumulated from imported packages
+ -> HomeSymbolTable
-> [CoreToDo] -- Spec of what core-to-core passes to do
-> [CoreBind] -- Binds in
- -> [ProtoCoreRule] -- Rules in
- -> IO ([CoreBind], RuleBase) -- binds, local orphan rules out
+ -> [IdCoreRule] -- Rules in
+ -> IO ([CoreBind], [IdCoreRule]) -- binds, local orphan rules out
-core2core dflags core_todos binds rules
+core2core dflags pkg_rule_base hst core_todos binds rules
= do
us <- mkSplitUniqSupply 's'
let (cp_us, ru_us) = splitUniqSupply us
- let (local_rules, imported_rules) = partition localRule rules
+ -- COMPUTE THE RULE BASE TO USE
+ (rule_base, binds1, orphan_rules)
+ <- prepareRules dflags pkg_rule_base hst ru_us binds rules
- better_local_rules <- simplRules dflags ru_us local_rules binds
- let (binds1, local_rule_base) = prepareLocalRuleBase binds better_local_rules
- imported_rule_base = prepareOrphanRuleBase imported_rules
-
- -- Do the main business
- (stats, processed_binds, processed_local_rules)
- <- doCorePasses dflags (zeroSimplCount dflags) cp_us binds1 local_rule_base
- imported_rule_base Nothing core_todos
+ -- DO THE BUSINESS
+ (stats, processed_binds)
+ <- doCorePasses dflags rule_base (zeroSimplCount dflags) cp_us binds1 core_todos
dumpIfSet_dyn dflags Opt_D_dump_simpl_stats
"Grand total simplifier statistics"
-- Return results
-- We only return local orphan rules, i.e., local rules not attached to an Id
- return (processed_binds, processed_local_rules)
+ -- The bindings cotain more rules, embedded in the Ids
+ return (processed_binds, orphan_rules)
doCorePasses :: DynFlags
+ -> RuleBase -- the main rule base
-> 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
+ -> IO (SimplCount, [CoreBind]) -- stats, binds, local orphan rules
-doCorePasses dflags stats us binds lrb irb rb0 []
- = return (stats, binds, lrb)
+doCorePasses dflags rb stats us binds []
+ = return (stats, binds)
-doCorePasses dflags stats us binds lrb irb rb0 (to_do : to_dos)
+doCorePasses dflags rb stats us binds (to_do : to_dos)
= do
let (us1, us2) = splitUniqSupply us
- -- recompute rulebase if necessary
- let rb = maybe (irb `unionRuleBase` lrb) id rb0
-
- (stats1, binds1, mlrb1) <- doCorePass dflags us1 binds lrb rb to_do
+ (stats1, binds1) <- doCorePass dflags rb us1 binds to_do
- -- request rulebase recomputation if pass returned a new local rulebase
- let (lrb1,rb1) = maybe (lrb, Just rb) (\ lrb1 -> (lrb1, Nothing)) mlrb1
+ doCorePasses dflags rb (stats `plusSimplCount` stats1) us2 binds1 to_dos
- doCorePasses dflags (stats `plusSimplCount` stats1) us2 binds1 lrb1 irb rb1 to_dos
-
-doCorePass dfs us binds lrb rb (CoreDoSimplify sw_chkr)
+doCorePass dfs rb us binds (CoreDoSimplify sw_chkr)
= _scc_ "Simplify" simplifyPgm dfs rb sw_chkr us binds
-doCorePass dfs us binds lrb rb CoreCSE
+doCorePass dfs rb us binds CoreCSE
= _scc_ "CommonSubExpr" noStats dfs (cseProgram dfs binds)
-doCorePass dfs us binds lrb rb CoreLiberateCase
+doCorePass dfs rb us binds CoreLiberateCase
= _scc_ "LiberateCase" noStats dfs (liberateCase dfs binds)
-doCorePass dfs us binds lrb rb CoreDoFloatInwards
+doCorePass dfs rb us binds CoreDoFloatInwards
= _scc_ "FloatInwards" noStats dfs (floatInwards dfs binds)
-doCorePass dfs us binds lrb rb (CoreDoFloatOutwards f)
+doCorePass dfs rb us binds (CoreDoFloatOutwards f)
= _scc_ "FloatOutwards" noStats dfs (floatOutwards dfs f us binds)
-doCorePass dfs us binds lrb rb CoreDoStaticArgs
+doCorePass dfs rb us binds CoreDoStaticArgs
= _scc_ "StaticArgs" noStats dfs (doStaticArgs us binds)
-doCorePass dfs us binds lrb rb CoreDoStrictness
+doCorePass dfs rb us binds CoreDoStrictness
= _scc_ "Stranal" noStats dfs (saBinds dfs binds)
-doCorePass dfs us binds lrb rb CoreDoWorkerWrapper
+doCorePass dfs rb us binds CoreDoWorkerWrapper
= _scc_ "WorkWrap" noStats dfs (wwTopBinds dfs us binds)
-doCorePass dfs us binds lrb rb CoreDoSpecialising
+doCorePass dfs rb us binds CoreDoSpecialising
= _scc_ "Specialise" noStats dfs (specProgram dfs us binds)
-doCorePass dfs us binds lrb rb CoreDoCPResult
+doCorePass dfs rb us binds CoreDoCPResult
= _scc_ "CPResult" noStats dfs (cprAnalyse dfs binds)
-doCorePass dfs us binds lrb rb CoreDoPrintCore
+doCorePass dfs rb us binds CoreDoPrintCore
= _scc_ "PrintCore" noStats dfs (printCore binds)
-doCorePass dfs us binds lrb rb CoreDoUSPInf
- = _scc_ "CoreUsageSPInf" noStats dfs (doUsageSPInf dfs us binds lrb)
-doCorePass dfs us binds lrb rb CoreDoGlomBinds
+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)
printCore binds = do dumpIfSet True "Print Core"
return binds
-- most passes return no stats and don't change rules
-noStats dfs thing = do { binds <- thing; return (zeroSimplCount dfs, binds, Nothing) }
+noStats dfs thing = do { binds <- thing; return (zeroSimplCount dfs, binds) }
\end{code}
%* *
%************************************************************************
-We must do some gentle simplification on the template (but not the RHS)
-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.
+-- 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
\begin{code}
-simplRules :: DynFlags -> UniqSupply -> [ProtoCoreRule] -> [CoreBind]
- -> IO [ProtoCoreRule]
-simplRules dflags us rules binds
- = do let (better_rules,_)
- = initSmpl dflags sw_chkr us bind_vars black_list_all
- (mapSmpl simplRule rules)
-
- dumpIfSet_dyn dflags Opt_D_dump_rules
- "Transformation rules"
- (vcat (map pprProtoCoreRule better_rules))
-
- return better_rules
+prepareRules :: DynFlags -> PackageRuleBase -> HomeSymbolTable
+ -> UniqSupply
+ -> [CoreBind] -> [IdCoreRule] -- Local bindings and rules
+ -> IO (RuleBase, -- Full rule base
+ [CoreBind], -- Bindings augmented with rules
+ [IdCoreRule]) -- Orphan rules
+
+prepareRules dflags pkg_rule_base hst us binds rules
+ = do { let (better_rules,_) = initSmpl dflags sw_chkr us local_ids black_list_all
+ (mapSmpl simplRule rules)
+
+ ; dumpIfSet_dyn dflags Opt_D_dump_rules "Transformation rules"
+ (vcat (map pprIdCoreRule better_rules))
+
+ ; let (local_id_rules, orphan_rules) = partition ((`elemVarSet` local_ids) . fst) better_rules
+ (binds1, local_rule_fvs) = addRulesToBinds binds local_id_rules
+ 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 local_rule_fvs
+ -- The last step black-lists the free vars of local rules too
+
+ ; return (final_rule_base, binds1, orphan_rules)
+ }
where
+ sw_chkr any = SwBool False -- A bit bogus
black_list_all v = not (isDataConWrapId v)
-- This stops all inlining except the
-- wrappers for data constructors
- sw_chkr any = SwBool False -- A bit bogus
+ add_rules rule_base mds = extendRuleBaseList rule_base (md_rules mds)
-- Boringly, we need to gather the in-scope set.
- -- Typically this thunk won't even be force, but the test in
- -- simpVar fails if it isn't right, and it might conceivably matter
- bind_vars = foldr (unionVarSet . mkVarSet . bindersOf) emptyVarSet binds
+ -- Typically this thunk won't even be forced, but the test in
+ -- simpVar fails if it isn't right, and it might conceiveably matter
+ local_ids = foldr (unionVarSet . mkVarSet . bindersOf) emptyVarSet binds
+
+addRulesToBinds :: [CoreBind] -> [(Id,CoreRule)] -> ([CoreBind], IdSet)
+ -- A horrible function
+
+ -- Attach the rules for each locally-defined Id to that Id.
+ -- - This 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
+ --
+ -- Both the LHS and RHS Ids are marked 'no-discard'.
+ -- This 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.
+
+addRulesToBinds binds local_rules
+ = (map zap_bind binds, rule_lhs_fvs)
+ where
+ -- rule_fvs is the set of all variables mentioned in this module's rules
+ rule_fvs = unionVarSets [ ruleSomeFreeVars isId rule | (_,rule) <- local_rules ]
+
+ rule_base = extendRuleBaseList emptyRuleBase local_rules
+ rule_lhs_fvs = ruleBaseFVs rule_base
+ rule_ids = ruleBaseIds rule_base
+
+ zap_bind (NonRec b r) = NonRec (zap_bndr b) r
+ zap_bind (Rec prs) = Rec [(zap_bndr b, r) | (b,r) <- prs]
+
+ zap_bndr bndr = case lookupVarSet rule_ids bndr of
+ Just bndr' -> setIdNoDiscard bndr'
+ Nothing | bndr `elemVarSet` rule_fvs -> setIdNoDiscard bndr
+ | otherwise -> bndr
+\end{code}
-simplRule rule@(ProtoCoreRule is_local id (BuiltinRule _))
+We must do some gentle simplification on the template (but not the RHS)
+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.
+
+\begin{code}
+simplRule rule@(id, BuiltinRule _)
= returnSmpl rule
-simplRule rule@(ProtoCoreRule is_local id (Rule name bndrs args rhs))
- | not is_local
- = returnSmpl rule -- No need to fiddle with imported rules
- | otherwise
+simplRule rule@(id, Rule name bndrs args rhs)
= simplBinders bndrs $ \ bndrs' ->
mapSmpl simpl_arg args `thenSmpl` \ args' ->
simplExpr rhs `thenSmpl` \ rhs' ->
- returnSmpl (ProtoCoreRule is_local id (Rule name bndrs' args' rhs'))
+ returnSmpl (id, Rule name bndrs' args' rhs')
simpl_arg e
-- I've seen rules in which a LHS like
returnSmpl (etaReduceExpr e')
\end{code}
+
+%************************************************************************
+%* *
+\subsection{Glomming}
+%* *
+%************************************************************************
+
\begin{code}
glomBinds :: DynFlags -> [CoreBind] -> IO [CoreBind]
-- Glom all binds together in one Rec, in case any
-- just consumes output bandwidth
\end{code}
+
%************************************************************************
%* *
\subsection{The driver for the simplifier}
-> RuleBase
-> (SimplifierSwitch -> SwitchResult)
-> UniqSupply
- -> [CoreBind] -- Input
- -> IO (SimplCount, [CoreBind], Maybe RuleBase) -- New bindings
+ -> [CoreBind] -- Input
+ -> IO (SimplCount, [CoreBind]) -- New bindings
-simplifyPgm dflags (RuleBase imported_rule_ids rule_lhs_fvs)
+simplifyPgm dflags rule_base
sw_chkr us binds
= do {
beginPass dflags "Simplify";
&& not (dopt Opt_D_dump_simpl_iterations dflags))
binds' ;
- return (counts_out, binds', Nothing)
+ return (counts_out, binds')
}
where
- max_iterations = getSimplIntSwitch sw_chkr MaxSimplifierIterations
- black_list_fn = blackListed rule_lhs_fvs (intSwitchSet sw_chkr SimplInlinePhase)
-
+ max_iterations = getSimplIntSwitch sw_chkr MaxSimplifierIterations
+ black_list_fn = blackListed rule_lhs_fvs (intSwitchSet sw_chkr SimplInlinePhase)
+ imported_rule_ids = ruleBaseIds rule_base
+ rule_lhs_fvs = ruleBaseFVs rule_base
+
iteration us iteration_no counts binds
-- Try and force thunks off the binds; significantly reduces
-- space usage, especially with -O. JRS, 000620.
projects / ghc-hetmet.git / blobdiff