Commit 5e218036 authored by simonpj@microsoft.com's avatar simonpj@microsoft.com

Occurrence analyser takes account of the phase when handing RULES

See Note [Finding rule RHS free vars]

This should make Roman happy.
parent 469c8c3c
......@@ -28,7 +28,7 @@ module CoreFVs (
-- * Free variables of Rules, Vars and Ids
varTypeTyVars, varTypeTcTyVars,
idUnfoldingVars, idFreeVars, idRuleAndUnfoldingVars,
idRuleVars, idRuleRhsVars,
idRuleVars, idRuleRhsVars, stableUnfoldingVars,
ruleRhsFreeVars, rulesFreeVars,
ruleLhsFreeNames, ruleLhsFreeIds,
......@@ -51,6 +51,7 @@ import VarSet
import Var
import TcType
import Util
import BasicTypes( Activation )
import Outputable
\end{code}
......@@ -285,6 +286,20 @@ ruleFreeVars (Rule { ru_fn = fn, ru_bndrs = bndrs, ru_rhs = rhs, ru_args = args
where
fvs = addBndrs bndrs (exprs_fvs (rhs:args)) isLocalVar emptyVarSet
idRuleRhsVars :: (Activation -> Bool) -> Id -> VarSet
-- Just the variables free on the *rhs* of a rule
idRuleRhsVars is_active id
= foldr (unionVarSet . get_fvs) emptyVarSet (idCoreRules id)
where
get_fvs (Rule { ru_fn = fn, ru_bndrs = bndrs
, ru_rhs = rhs, ru_act = act })
| is_active act
-- See Note [Finding rule RHS free vars] in OccAnal.lhs
= delFromUFM fvs fn -- Note [Rule free var hack]
where
fvs = addBndrs bndrs (expr_fvs rhs) isLocalVar emptyVarSet
get_fvs _ = noFVs
-- | Those variables free in the right hand side of several rules
rulesFreeVars :: [CoreRule] -> VarSet
rulesFreeVars rules = foldr (unionVarSet . ruleFreeVars) emptyVarSet rules
......@@ -406,26 +421,19 @@ idRuleAndUnfoldingVars id = ASSERT( isId id)
idRuleVars ::Id -> VarSet -- Does *not* include CoreUnfolding vars
idRuleVars id = ASSERT( isId id) specInfoFreeVars (idSpecialisation id)
idRuleRhsVars :: Id -> VarSet -- Does *not* include the CoreUnfolding vars
-- Just the variables free on the *rhs* of a rule
-- See Note [Choosing loop breakers] in Simplify.lhs
idRuleRhsVars id = foldr (unionVarSet . ruleRhsFreeVars)
emptyVarSet
(idCoreRules id)
idUnfoldingVars :: Id -> VarSet
-- Produce free vars for an unfolding, but NOT for an ordinary
-- (non-inline) unfolding, since it is a dup of the rhs
-- and we'll get exponential behaviour if we look at both unf and rhs!
-- But do look at the *real* unfolding, even for loop breakers, else
-- we might get out-of-scope variables
idUnfoldingVars id
= case realIdUnfolding id of
CoreUnfolding { uf_tmpl = rhs, uf_src = src }
| isStableSource src
-> exprFreeVars rhs
DFunUnfolding _ _ args -> exprsFreeVars args
_ -> emptyVarSet
idUnfoldingVars id = stableUnfoldingVars (realIdUnfolding id)
stableUnfoldingVars :: Unfolding -> VarSet
stableUnfoldingVars (CoreUnfolding { uf_tmpl = rhs, uf_src = src })
| isStableSource src = exprFreeVars rhs
stableUnfoldingVars (DFunUnfolding _ _ args) = exprsFreeVars args
stableUnfoldingVars _ = emptyVarSet
\end{code}
......
......@@ -699,7 +699,8 @@ simpleOptPgm dflags binds rules
; return (reverse binds', substRulesForImportedIds subst' rules) }
where
occ_anald_binds = occurAnalysePgm binds rules
occ_anald_binds = occurAnalysePgm Nothing {- No rules active -}
rules binds
(subst', binds') = foldl do_one (emptySubst, []) occ_anald_binds
do_one (subst, binds') bind
......
This diff is collapsed.
......@@ -20,7 +20,7 @@ import OccurAnal ( occurAnalysePgm, occurAnalyseExpr )
import IdInfo
import CoreUtils ( coreBindsSize )
import Simplify ( simplTopBinds, simplExpr )
import SimplUtils ( simplEnvForGHCi )
import SimplUtils ( simplEnvForGHCi, activeRule )
import SimplEnv
import SimplMonad
import CoreMonad
......@@ -307,7 +307,7 @@ simplifyPgmIO :: CoreToDo
-> ModGuts
-> IO (SimplCount, ModGuts) -- New bindings
simplifyPgmIO pass@(CoreDoSimplify mode max_iterations switches)
simplifyPgmIO pass@(CoreDoSimplify max_iterations mode)
hsc_env us hpt_rule_base
guts@(ModGuts { mg_binds = binds, mg_rules = rules
, mg_fam_inst_env = fam_inst_env })
......@@ -323,9 +323,11 @@ simplifyPgmIO pass@(CoreDoSimplify mode max_iterations switches)
; return (counts_out, guts')
}
where
dflags = hsc_dflags hsc_env
dump_phase = dumpSimplPhase dflags mode
sw_chkr = isAmongSimpl switches
dflags = hsc_dflags hsc_env
dump_phase = dumpSimplPhase dflags mode
simpl_env = mkSimplEnv mode
active_rule = activeRule dflags simpl_env
do_iteration :: UniqSupply
-> Int -- Counts iterations
-> [SimplCount] -- Counts from earlier iterations, reversed
......@@ -355,7 +357,8 @@ simplifyPgmIO pass@(CoreDoSimplify mode max_iterations switches)
| let sz = coreBindsSize binds in sz == sz
= do {
-- Occurrence analysis
let { tagged_binds = {-# SCC "OccAnal" #-} occurAnalysePgm binds rules } ;
let { tagged_binds = {-# SCC "OccAnal" #-}
occurAnalysePgm active_rule rules binds } ;
Err.dumpIfSet_dyn dflags Opt_D_dump_occur_anal "Occurrence analysis"
(pprCoreBindings tagged_binds);
......@@ -368,7 +371,6 @@ simplifyPgmIO pass@(CoreDoSimplify mode max_iterations switches)
eps <- hscEPS hsc_env ;
let { rule_base1 = unionRuleBase hpt_rule_base (eps_rule_base eps)
; rule_base2 = extendRuleBaseList rule_base1 rules
; simpl_env = mkSimplEnv sw_chkr mode
; simpl_binds = {-# SCC "SimplTopBinds" #-}
simplTopBinds simpl_env tagged_binds
; fam_envs = (eps_fam_inst_env eps, fam_inst_env) } ;
......
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