Commit 9df1b97e authored by keithw's avatar keithw

[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.
parent 0b3dcf9d
......@@ -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
......
......@@ -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
......
%
% (c) The AQUA Project, Glasgow University, 1993-1998
%
\section[Simplify]{The main module of the simplifier}
......
......@@ -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}
......@@ -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}
======================================================================
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment