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,
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)
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
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 )
import Outputable
import Ratio ( numerator, denominator )
+import List ( partition )
\end{code}
%************************************************************************
\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
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}
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
(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
-
+%
% (c) The AQUA Project, Glasgow University, 1993-1998
%
\section[Simplify]{The main module of the simplifier}
\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"
= 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
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.
-- 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}
import UConSet
import CoreSyn
+import Rules ( RuleBase )
import TypeRep ( Type(..), TyNote(..) ) -- friend
import Type ( UsageAnn(..),
applyTy, applyTys,
\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" $
dumpIfSet opt_D_dump_usagesp "UsageSPInf" $
pprCoreBindings binds3
- return binds3
+ return (binds3, Nothing)
\end{code}
======================================================================
projects / ghc-hetmet.git / commitdiff