Commit 2325bd4e authored by niteria's avatar niteria Committed by Ben Gamari

Create a deterministic version of tyVarsOfType

I've run into situations where I need deterministic `tyVarsOfType` and
this implementation achieves that and also brings an algorithmic
improvement.  Union of two `VarSet`s takes linear time the size of the
sets and in the worst case we can have `n` unions of sets of sizes
`(n-1, 1), (n-2, 1)...` making it quadratic.

One reason why we need deterministic `tyVarsOfType` is in `abstractVars`
in `SetLevels`. When we abstract type variables when floating we want
them to be abstracted in deterministic order.

Test Plan: harbormaster

Reviewers: simonpj, goldfire, austin, hvr, simonmar, bgamari

Reviewed By: simonmar

Subscribers: thomie

Differential Revision: https://phabricator.haskell.org/D1468

GHC Trac Issues: #4012
parent 6664ab83
...@@ -376,21 +376,21 @@ and put in the global list. ...@@ -376,21 +376,21 @@ and put in the global list.
data RuleInfo data RuleInfo
= RuleInfo = RuleInfo
[CoreRule] [CoreRule]
VarSet -- Locally-defined free vars of *both* LHS and RHS DVarSet -- Locally-defined free vars of *both* LHS and RHS
-- of rules. I don't think it needs to include the -- of rules. I don't think it needs to include the
-- ru_fn though. -- ru_fn though.
-- Note [Rule dependency info] in OccurAnal -- Note [Rule dependency info] in OccurAnal
-- | Assume that no specilizations exist: always safe -- | Assume that no specilizations exist: always safe
emptyRuleInfo :: RuleInfo emptyRuleInfo :: RuleInfo
emptyRuleInfo = RuleInfo [] emptyVarSet emptyRuleInfo = RuleInfo [] emptyDVarSet
isEmptyRuleInfo :: RuleInfo -> Bool isEmptyRuleInfo :: RuleInfo -> Bool
isEmptyRuleInfo (RuleInfo rs _) = null rs isEmptyRuleInfo (RuleInfo rs _) = null rs
-- | Retrieve the locally-defined free variables of both the left and -- | Retrieve the locally-defined free variables of both the left and
-- right hand sides of the specialization rules -- right hand sides of the specialization rules
ruleInfoFreeVars :: RuleInfo -> VarSet ruleInfoFreeVars :: RuleInfo -> DVarSet
ruleInfoFreeVars (RuleInfo _ fvs) = fvs ruleInfoFreeVars (RuleInfo _ fvs) = fvs
ruleInfoRules :: RuleInfo -> [CoreRule] ruleInfoRules :: RuleInfo -> [CoreRule]
......
...@@ -11,6 +11,7 @@ Taken quite directly from the Peyton Jones/Lester paper. ...@@ -11,6 +11,7 @@ Taken quite directly from the Peyton Jones/Lester paper.
module CoreFVs ( module CoreFVs (
-- * Free variables of expressions and binding groups -- * Free variables of expressions and binding groups
exprFreeVars, -- CoreExpr -> VarSet -- Find all locally-defined free Ids or tyvars exprFreeVars, -- CoreExpr -> VarSet -- Find all locally-defined free Ids or tyvars
exprFreeDVars, -- CoreExpr -> DVarSet -- Find all locally-defined free Ids or tyvars
exprFreeIds, -- CoreExpr -> IdSet -- Find all locally-defined free Ids exprFreeIds, -- CoreExpr -> IdSet -- Find all locally-defined free Ids
exprsFreeVars, -- [CoreExpr] -> VarSet exprsFreeVars, -- [CoreExpr] -> VarSet
bindFreeVars, -- CoreBind -> VarSet bindFreeVars, -- CoreBind -> VarSet
...@@ -22,16 +23,20 @@ module CoreFVs ( ...@@ -22,16 +23,20 @@ module CoreFVs (
-- * Free variables of Rules, Vars and Ids -- * Free variables of Rules, Vars and Ids
varTypeTyVars, varTypeTyVars,
idUnfoldingVars, idFreeVars, idRuleAndUnfoldingVars, idUnfoldingVars, idFreeVars, idRuleAndUnfoldingVars,
idFreeVarsAcc,
idRuleVars, idRuleRhsVars, stableUnfoldingVars, idRuleVars, idRuleRhsVars, stableUnfoldingVars,
ruleRhsFreeVars, ruleFreeVars, rulesFreeVars, ruleRhsFreeVars, ruleFreeVars, rulesFreeVars,
rulesFreeDVars,
ruleLhsFreeIds, exprsOrphNames, ruleLhsFreeIds, exprsOrphNames,
vectsFreeVars, vectsFreeVars,
expr_fvs,
-- * Core syntax tree annotation with free variables -- * Core syntax tree annotation with free variables
CoreExprWithFVs, -- = AnnExpr Id VarSet CoreExprWithFVs, -- = AnnExpr Id DVarSet
CoreBindWithFVs, -- = AnnBind Id VarSet CoreBindWithFVs, -- = AnnBind Id DVarSet
freeVars, -- CoreExpr -> CoreExprWithFVs freeVars, -- CoreExpr -> CoreExprWithFVs
freeVarsOf -- CoreExprWithFVs -> IdSet freeVarsOf -- CoreExprWithFVs -> DIdSet
) where ) where
#include "HsVersions.h" #include "HsVersions.h"
...@@ -45,11 +50,13 @@ import Name ...@@ -45,11 +50,13 @@ import Name
import VarSet import VarSet
import Var import Var
import TcType import TcType
import TypeRep
import Coercion import Coercion
import Maybes( orElse ) import Maybes( orElse )
import Util import Util
import BasicTypes( Activation ) import BasicTypes( Activation )
import Outputable import Outputable
import FV
{- {-
************************************************************************ ************************************************************************
...@@ -69,7 +76,11 @@ but not those that are free in the type of variable occurrence. ...@@ -69,7 +76,11 @@ but not those that are free in the type of variable occurrence.
-- | Find all locally-defined free Ids or type variables in an expression -- | Find all locally-defined free Ids or type variables in an expression
exprFreeVars :: CoreExpr -> VarSet exprFreeVars :: CoreExpr -> VarSet
exprFreeVars = exprSomeFreeVars isLocalVar exprFreeVars = runFVSet . filterFV isLocalVar . expr_fvs
exprFreeDVars :: CoreExpr -> DVarSet
exprFreeDVars = runFVDSet . filterFV isLocalVar . expr_fvs
-- | Find all locally-defined free Ids in an expression -- | Find all locally-defined free Ids in an expression
exprFreeIds :: CoreExpr -> IdSet -- Find all locally-defined free Ids exprFreeIds :: CoreExpr -> IdSet -- Find all locally-defined free Ids
...@@ -81,44 +92,23 @@ exprsFreeVars = mapUnionVarSet exprFreeVars ...@@ -81,44 +92,23 @@ exprsFreeVars = mapUnionVarSet exprFreeVars
-- | Find all locally defined free Ids in a binding group -- | Find all locally defined free Ids in a binding group
bindFreeVars :: CoreBind -> VarSet bindFreeVars :: CoreBind -> VarSet
bindFreeVars (NonRec b r) = rhs_fvs (b,r) isLocalVar emptyVarSet bindFreeVars (NonRec b r) = runFVSet $ filterFV isLocalVar $ rhs_fvs (b,r)
bindFreeVars (Rec prs) = addBndrs (map fst prs) bindFreeVars (Rec prs) = runFVSet $ filterFV isLocalVar $
(foldr (union . rhs_fvs) noVars prs) addBndrs (map fst prs)
isLocalVar emptyVarSet (foldr (unionFV . rhs_fvs) noVars prs)
-- | Finds free variables in an expression selected by a predicate -- | Finds free variables in an expression selected by a predicate
exprSomeFreeVars :: InterestingVarFun -- ^ Says which 'Var's are interesting exprSomeFreeVars :: InterestingVarFun -- ^ Says which 'Var's are interesting
-> CoreExpr -> CoreExpr
-> VarSet -> VarSet
exprSomeFreeVars fv_cand e = expr_fvs e fv_cand emptyVarSet exprSomeFreeVars fv_cand e = runFVSet $ filterFV fv_cand $ expr_fvs e
-- | Finds free variables in several expressions selected by a predicate -- | Finds free variables in several expressions selected by a predicate
exprsSomeFreeVars :: InterestingVarFun -- Says which 'Var's are interesting exprsSomeFreeVars :: InterestingVarFun -- Says which 'Var's are interesting
-> [CoreExpr] -> [CoreExpr]
-> VarSet -> VarSet
exprsSomeFreeVars fv_cand = mapUnionVarSet (exprSomeFreeVars fv_cand) exprsSomeFreeVars fv_cand es =
runFVSet $ filterFV fv_cand $ foldr (unionFV . expr_fvs) noVars es
-- | Predicate on possible free variables: returns @True@ iff the variable is interesting
type InterestingVarFun = Var -> Bool
type FV = InterestingVarFun
-> VarSet -- Locally bound
-> VarSet -- Free vars
-- Return the vars that are both (a) interesting
-- and (b) not locally bound
-- See function keep_it
keep_it :: InterestingVarFun -> VarSet -> Var -> Bool
keep_it fv_cand in_scope var
| var `elemVarSet` in_scope = False
| fv_cand var = True
| otherwise = False
union :: FV -> FV -> FV
union fv1 fv2 fv_cand in_scope = fv1 fv_cand in_scope `unionVarSet` fv2 fv_cand in_scope
noVars :: FV
noVars _ _ = emptyVarSet
-- Comment about obselete code -- Comment about obselete code
-- We used to gather the free variables the RULES at a variable occurrence -- We used to gather the free variables the RULES at a variable occurrence
...@@ -148,63 +138,65 @@ noVars _ _ = emptyVarSet ...@@ -148,63 +138,65 @@ noVars _ _ = emptyVarSet
-- | otherwise = set -- | otherwise = set
-- SLPJ Feb06 -- SLPJ Feb06
oneVar :: Id -> FV -- XXX move to FV
oneVar var fv_cand in_scope someVars :: [Var] -> FV
= ASSERT( isId var ) someVars vars = foldr (unionFV . oneVar) noVars vars
if keep_it fv_cand in_scope var
then unitVarSet var
else emptyVarSet
someVars :: VarSet -> FV
someVars vars fv_cand in_scope
= filterVarSet (keep_it fv_cand in_scope) vars
addBndr :: CoreBndr -> FV -> FV addBndr :: CoreBndr -> FV -> FV
addBndr bndr fv fv_cand in_scope addBndr bndr fv fv_cand in_scope acc
= someVars (varTypeTyVars bndr) fv_cand in_scope = (varTypeTyVarsAcc bndr `unionFV`
-- Include type varibles in the binder's type -- Include type varibles in the binder's type
-- (not just Ids; coercion variables too!) -- (not just Ids; coercion variables too!)
`unionVarSet` fv fv_cand (in_scope `extendVarSet` bndr) FV.delFV bndr fv) fv_cand in_scope acc
addBndrs :: [CoreBndr] -> FV -> FV addBndrs :: [CoreBndr] -> FV -> FV
addBndrs bndrs fv = foldr addBndr fv bndrs addBndrs bndrs fv = foldr addBndr fv bndrs
expr_fvs :: CoreExpr -> FV expr_fvs :: CoreExpr -> FV
expr_fvs (Type ty) = someVars (tyVarsOfType ty) expr_fvs (Type ty) fv_cand in_scope acc =
expr_fvs (Coercion co) = someVars (tyCoVarsOfCo co) tyVarsOfTypeAcc ty fv_cand in_scope acc
expr_fvs (Var var) = oneVar var expr_fvs (Coercion co) fv_cand in_scope acc =
expr_fvs (Lit _) = noVars tyCoVarsOfCoAcc co fv_cand in_scope acc
expr_fvs (Tick t expr) = tickish_fvs t `union` expr_fvs expr expr_fvs (Var var) fv_cand in_scope acc = oneVar var fv_cand in_scope acc
expr_fvs (App fun arg) = expr_fvs fun `union` expr_fvs arg expr_fvs (Lit _) fv_cand in_scope acc = noVars fv_cand in_scope acc
expr_fvs (Lam bndr body) = addBndr bndr (expr_fvs body) expr_fvs (Tick t expr) fv_cand in_scope acc =
expr_fvs (Cast expr co) = expr_fvs expr `union` someVars (tyCoVarsOfCo co) (tickish_fvs t `unionFV` expr_fvs expr) fv_cand in_scope acc
expr_fvs (App fun arg) fv_cand in_scope acc =
expr_fvs (Case scrut bndr ty alts) (expr_fvs fun `unionFV` expr_fvs arg) fv_cand in_scope acc
= expr_fvs scrut `union` someVars (tyVarsOfType ty) `union` addBndr bndr expr_fvs (Lam bndr body) fv_cand in_scope acc =
(foldr (union . alt_fvs) noVars alts) addBndr bndr (expr_fvs body) fv_cand in_scope acc
expr_fvs (Cast expr co) fv_cand in_scope acc =
(expr_fvs expr `unionFV` tyCoVarsOfCoAcc co) fv_cand in_scope acc
expr_fvs (Case scrut bndr ty alts) fv_cand in_scope acc
= (expr_fvs scrut `unionFV` tyVarsOfTypeAcc ty `unionFV` addBndr bndr
(foldr (unionFV . alt_fvs) noVars alts)) fv_cand in_scope acc
where where
alt_fvs (_, bndrs, rhs) = addBndrs bndrs (expr_fvs rhs) alt_fvs (_, bndrs, rhs) = addBndrs bndrs (expr_fvs rhs)
expr_fvs (Let (NonRec bndr rhs) body) expr_fvs (Let (NonRec bndr rhs) body) fv_cand in_scope acc
= rhs_fvs (bndr, rhs) `union` addBndr bndr (expr_fvs body) = (rhs_fvs (bndr, rhs) `unionFV` addBndr bndr (expr_fvs body))
fv_cand in_scope acc
expr_fvs (Let (Rec pairs) body) expr_fvs (Let (Rec pairs) body) fv_cand in_scope acc
= addBndrs (map fst pairs) = addBndrs (map fst pairs)
(foldr (union . rhs_fvs) (expr_fvs body) pairs) (foldr (unionFV . rhs_fvs) (expr_fvs body) pairs)
fv_cand in_scope acc
--------- ---------
rhs_fvs :: (Id,CoreExpr) -> FV rhs_fvs :: (Id, CoreExpr) -> FV
rhs_fvs (bndr, rhs) = expr_fvs rhs `union` rhs_fvs (bndr, rhs) = expr_fvs rhs `unionFV`
someVars (bndrRuleAndUnfoldingVars bndr) bndrRuleAndUnfoldingVarsAcc bndr -- XXX: FIXME
-- Treat any RULES as extra RHSs of the binding -- Treat any RULES as extra RHSs of the binding
--------- ---------
exprs_fvs :: [CoreExpr] -> FV exprs_fvs :: [CoreExpr] -> FV
exprs_fvs exprs = foldr (union . expr_fvs) noVars exprs exprs_fvs exprs = foldr (unionFV . expr_fvs) noVars exprs
tickish_fvs :: Tickish Id -> FV tickish_fvs :: Tickish Id -> FV
tickish_fvs (Breakpoint _ ids) = someVars (mkVarSet ids) tickish_fvs (Breakpoint _ ids) = someVars ids
tickish_fvs _ = noVars tickish_fvs _ = noVars
{- {-
...@@ -258,7 +250,7 @@ exprsOrphNames es = foldr (unionNameSet . exprOrphNames) emptyNameSet es ...@@ -258,7 +250,7 @@ exprsOrphNames es = foldr (unionNameSet . exprOrphNames) emptyNameSet es
ruleRhsFreeVars :: CoreRule -> VarSet ruleRhsFreeVars :: CoreRule -> VarSet
ruleRhsFreeVars (BuiltinRule {}) = noFVs ruleRhsFreeVars (BuiltinRule {}) = noFVs
ruleRhsFreeVars (Rule { ru_fn = _, ru_bndrs = bndrs, ru_rhs = rhs }) ruleRhsFreeVars (Rule { ru_fn = _, ru_bndrs = bndrs, ru_rhs = rhs })
= addBndrs bndrs (expr_fvs rhs) isLocalVar emptyVarSet = runFVSet $ filterFV isLocalVar $ addBndrs bndrs (expr_fvs rhs)
-- See Note [Rule free var hack] -- See Note [Rule free var hack]
-- | Those variables free in the both the left right hand sides of a rule -- | Those variables free in the both the left right hand sides of a rule
...@@ -267,7 +259,22 @@ ruleFreeVars (BuiltinRule {}) = noFVs ...@@ -267,7 +259,22 @@ ruleFreeVars (BuiltinRule {}) = noFVs
ruleFreeVars (Rule { ru_fn = _do_not_include -- See Note [Rule free var hack] ruleFreeVars (Rule { ru_fn = _do_not_include -- See Note [Rule free var hack]
, ru_bndrs = bndrs , ru_bndrs = bndrs
, ru_rhs = rhs, ru_args = args }) , ru_rhs = rhs, ru_args = args })
= addBndrs bndrs (exprs_fvs (rhs:args)) isLocalVar emptyVarSet = runFVSet $ filterFV isLocalVar $ addBndrs bndrs (exprs_fvs (rhs:args))
ruleFreeVarsAcc :: CoreRule -> FV
ruleFreeVarsAcc (BuiltinRule {}) =
noVars
ruleFreeVarsAcc (Rule { ru_fn = _do_not_include -- See Note [Rule free var hack]
, ru_bndrs = bndrs
, ru_rhs = rhs, ru_args = args })
= addBndrs bndrs (exprs_fvs (rhs:args))
rulesFreeVarsAcc :: [CoreRule] -> FV
rulesFreeVarsAcc (rule:rules) = ruleFreeVarsAcc rule `unionFV` rulesFreeVarsAcc rules
rulesFreeVarsAcc [] = noVars
rulesFreeDVars :: [CoreRule] -> DVarSet
rulesFreeDVars rules = runFVDSet $ filterFV isLocalVar $ rulesFreeVarsAcc rules
idRuleRhsVars :: (Activation -> Bool) -> Id -> VarSet idRuleRhsVars :: (Activation -> Bool) -> Id -> VarSet
...@@ -281,7 +288,7 @@ idRuleRhsVars is_active id ...@@ -281,7 +288,7 @@ idRuleRhsVars is_active id
-- See Note [Finding rule RHS free vars] in OccAnal.hs -- See Note [Finding rule RHS free vars] in OccAnal.hs
= delFromUFM fvs fn -- Note [Rule free var hack] = delFromUFM fvs fn -- Note [Rule free var hack]
where where
fvs = addBndrs bndrs (expr_fvs rhs) isLocalVar emptyVarSet fvs = runFVSet $ filterFV isLocalVar $ addBndrs bndrs (expr_fvs rhs)
get_fvs _ = noFVs get_fvs _ = noFVs
-- | Those variables free in the right hand side of several rules -- | Those variables free in the right hand side of several rules
...@@ -292,7 +299,7 @@ ruleLhsFreeIds :: CoreRule -> VarSet ...@@ -292,7 +299,7 @@ ruleLhsFreeIds :: CoreRule -> VarSet
-- ^ This finds all locally-defined free Ids on the left hand side of a rule -- ^ This finds all locally-defined free Ids on the left hand side of a rule
ruleLhsFreeIds (BuiltinRule {}) = noFVs ruleLhsFreeIds (BuiltinRule {}) = noFVs
ruleLhsFreeIds (Rule { ru_bndrs = bndrs, ru_args = args }) ruleLhsFreeIds (Rule { ru_bndrs = bndrs, ru_args = args })
= addBndrs bndrs (exprs_fvs args) isLocalId emptyVarSet = runFVSet $ filterFV isLocalId $ addBndrs bndrs (exprs_fvs args)
{- {-
Note [Rule free var hack] (Not a hack any more) Note [Rule free var hack] (Not a hack any more)
...@@ -311,7 +318,7 @@ breaker, which is perfectly inlinable. ...@@ -311,7 +318,7 @@ breaker, which is perfectly inlinable.
vectsFreeVars :: [CoreVect] -> VarSet vectsFreeVars :: [CoreVect] -> VarSet
vectsFreeVars = mapUnionVarSet vectFreeVars vectsFreeVars = mapUnionVarSet vectFreeVars
where where
vectFreeVars (Vect _ rhs) = expr_fvs rhs isLocalId emptyVarSet vectFreeVars (Vect _ rhs) = runFVSet $ filterFV isLocalId $ expr_fvs rhs
vectFreeVars (NoVect _) = noFVs vectFreeVars (NoVect _) = noFVs
vectFreeVars (VectType _ _ _) = noFVs vectFreeVars (VectType _ _ _) = noFVs
vectFreeVars (VectClass _) = noFVs vectFreeVars (VectClass _) = noFVs
...@@ -331,28 +338,28 @@ NON-GLOBAL free variables and type variables. ...@@ -331,28 +338,28 @@ NON-GLOBAL free variables and type variables.
-- | Every node in a binding group annotated with its -- | Every node in a binding group annotated with its
-- (non-global) free variables, both Ids and TyVars -- (non-global) free variables, both Ids and TyVars
type CoreBindWithFVs = AnnBind Id VarSet type CoreBindWithFVs = AnnBind Id DVarSet
-- | Every node in an expression annotated with its -- | Every node in an expression annotated with its
-- (non-global) free variables, both Ids and TyVars -- (non-global) free variables, both Ids and TyVars
type CoreExprWithFVs = AnnExpr Id VarSet type CoreExprWithFVs = AnnExpr Id DVarSet
freeVarsOf :: CoreExprWithFVs -> IdSet freeVarsOf :: CoreExprWithFVs -> DIdSet
-- ^ Inverse function to 'freeVars' -- ^ Inverse function to 'freeVars'
freeVarsOf (free_vars, _) = free_vars freeVarsOf (free_vars, _) = free_vars
noFVs :: VarSet noFVs :: VarSet
noFVs = emptyVarSet noFVs = emptyVarSet
aFreeVar :: Var -> VarSet aFreeVar :: Var -> DVarSet
aFreeVar = unitVarSet aFreeVar = unitDVarSet
unionFVs :: VarSet -> VarSet -> VarSet unionFVs :: DVarSet -> DVarSet -> DVarSet
unionFVs = unionVarSet unionFVs = unionDVarSet
delBindersFV :: [Var] -> VarSet -> VarSet delBindersFV :: [Var] -> DVarSet -> DVarSet
delBindersFV bs fvs = foldr delBinderFV fvs bs delBindersFV bs fvs = foldr delBinderFV fvs bs
delBinderFV :: Var -> VarSet -> VarSet delBinderFV :: Var -> DVarSet -> DVarSet
-- This way round, so we can do it multiple times using foldr -- This way round, so we can do it multiple times using foldr
-- (b `delBinderFV` s) removes the binder b from the free variable set s, -- (b `delBinderFV` s) removes the binder b from the free variable set s,
...@@ -383,32 +390,47 @@ delBinderFV :: Var -> VarSet -> VarSet ...@@ -383,32 +390,47 @@ delBinderFV :: Var -> VarSet -> VarSet
-- where -- where
-- bottom = bottom -- Never evaluated -- bottom = bottom -- Never evaluated
delBinderFV b s = (s `delVarSet` b) `unionFVs` varTypeTyVars b delBinderFV b s = (s `delDVarSet` b) `unionFVs` dVarTypeTyVars b
-- Include coercion variables too! -- Include coercion variables too!
varTypeTyVars :: Var -> TyVarSet varTypeTyVars :: Var -> TyVarSet
-- Find the type/kind variables free in the type of the id/tyvar -- Find the type/kind variables free in the type of the id/tyvar
varTypeTyVars var = tyVarsOfType (varType var) varTypeTyVars var = runFVSet $ varTypeTyVarsAcc var
dVarTypeTyVars :: Var -> DTyVarSet
-- Find the type/kind variables free in the type of the id/tyvar
dVarTypeTyVars var = runFVDSet $ varTypeTyVarsAcc var
varTypeTyVarsAcc :: Var -> FV
varTypeTyVarsAcc var = tyVarsOfTypeAcc (varType var)
idFreeVars :: Id -> VarSet idFreeVars :: Id -> VarSet
idFreeVars id = ASSERT( isId id) runFVSet $ idFreeVarsAcc id
idFreeVarsAcc :: Id -> FV
-- Type variables, rule variables, and inline variables -- Type variables, rule variables, and inline variables
idFreeVars id = ASSERT( isId id) idFreeVarsAcc id = ASSERT( isId id)
varTypeTyVars id `unionVarSet` varTypeTyVarsAcc id `unionFV`
idRuleAndUnfoldingVars id idRuleAndUnfoldingVarsAcc id
bndrRuleAndUnfoldingVars ::Var -> VarSet bndrRuleAndUnfoldingVarsAcc :: Var -> FV
-- A 'let' can bind a type variable, and idRuleVars assumes bndrRuleAndUnfoldingVarsAcc v | isTyVar v = noVars
-- it's seeing an Id. This function tests first. | otherwise = idRuleAndUnfoldingVarsAcc v
bndrRuleAndUnfoldingVars v | isTyVar v = emptyVarSet
| otherwise = idRuleAndUnfoldingVars v
idRuleAndUnfoldingVars :: Id -> VarSet idRuleAndUnfoldingVars :: Id -> VarSet
idRuleAndUnfoldingVars id = ASSERT( isId id) idRuleAndUnfoldingVars id = runFVSet $ idRuleAndUnfoldingVarsAcc id
idRuleVars id `unionVarSet`
idUnfoldingVars id idRuleAndUnfoldingVarsAcc :: Id -> FV
idRuleAndUnfoldingVarsAcc id = ASSERT( isId id)
idRuleVarsAcc id `unionFV` idUnfoldingVarsAcc id
idRuleVars ::Id -> VarSet -- Does *not* include CoreUnfolding vars idRuleVars ::Id -> VarSet -- Does *not* include CoreUnfolding vars
idRuleVars id = ASSERT( isId id) ruleInfoFreeVars (idSpecialisation id) idRuleVars id = runFVSet $ idRuleVarsAcc id
idRuleVarsAcc :: Id -> FV
idRuleVarsAcc id = ASSERT( isId id)
someVars (dVarSetElems $ ruleInfoFreeVars (idSpecialisation id))
idUnfoldingVars :: Id -> VarSet idUnfoldingVars :: Id -> VarSet
-- Produce free vars for an unfolding, but NOT for an ordinary -- Produce free vars for an unfolding, but NOT for an ordinary
...@@ -416,19 +438,26 @@ idUnfoldingVars :: Id -> VarSet ...@@ -416,19 +438,26 @@ idUnfoldingVars :: Id -> VarSet
-- and we'll get exponential behaviour if we look at both unf and 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 -- But do look at the *real* unfolding, even for loop breakers, else
-- we might get out-of-scope variables -- we might get out-of-scope variables
idUnfoldingVars id = stableUnfoldingVars (realIdUnfolding id) `orElse` emptyVarSet idUnfoldingVars id = runFVSet $ idUnfoldingVarsAcc id
idUnfoldingVarsAcc :: Id -> FV
idUnfoldingVarsAcc id = stableUnfoldingVarsAcc (realIdUnfolding id) `orElse` noVars
stableUnfoldingVars :: Unfolding -> Maybe VarSet stableUnfoldingVars :: Unfolding -> Maybe VarSet
stableUnfoldingVars unf stableUnfoldingVars unf = runFVSet `fmap` stableUnfoldingVarsAcc unf
stableUnfoldingVarsAcc :: Unfolding -> Maybe FV
stableUnfoldingVarsAcc unf
= case unf of = case unf of
CoreUnfolding { uf_tmpl = rhs, uf_src = src } CoreUnfolding { uf_tmpl = rhs, uf_src = src }
| isStableSource src | isStableSource src
-> Just (exprFreeVars rhs) -> Just (filterFV isLocalVar $ expr_fvs rhs)
DFunUnfolding { df_bndrs = bndrs, df_args = args } DFunUnfolding { df_bndrs = bndrs, df_args = args }
-> Just (exprs_fvs args isLocalVar (mkVarSet bndrs)) -> Just (filterFV isLocalVar $ FV.delFVs (mkVarSet bndrs) $ exprs_fvs args)
-- DFuns are top level, so no fvs from types of bndrs -- DFuns are top level, so no fvs from types of bndrs
_other -> Nothing _other -> Nothing
{- {-
************************************************************************ ************************************************************************
* * * *
...@@ -448,9 +477,9 @@ freeVars (Var v) ...@@ -448,9 +477,9 @@ freeVars (Var v)
-- fvs = fvs_v `unionVarSet` idSpecVars v -- fvs = fvs_v `unionVarSet` idSpecVars v
fvs | isLocalVar v = aFreeVar v fvs | isLocalVar v = aFreeVar v
| otherwise = noFVs | otherwise = emptyDVarSet
freeVars (Lit lit) = (noFVs, AnnLit lit) freeVars (Lit lit) = (emptyDVarSet, AnnLit lit)
freeVars (Lam b body) freeVars (Lam b body)
= (b `delBinderFV` freeVarsOf body', AnnLam b body') = (b `delBinderFV` freeVarsOf body', AnnLam b body')
where where
...@@ -463,13 +492,13 @@ freeVars (App fun arg) ...@@ -463,13 +492,13 @@ freeVars (App fun arg)
arg2 = freeVars arg arg2 = freeVars arg
freeVars (Case scrut bndr ty alts) freeVars (Case scrut bndr ty alts)
= ((bndr `delBinderFV` alts_fvs) `unionFVs` freeVarsOf scrut2 `unionFVs` tyVarsOfType ty, = ((bndr `delBinderFV` alts_fvs) `unionFVs` freeVarsOf scrut2 `unionFVs` runFVDSet (tyVarsOfTypeAcc ty),
AnnCase scrut2 bndr ty alts2) AnnCase scrut2 bndr ty alts2)
where where
scrut2 = freeVars scrut scrut2 = freeVars scrut
(alts_fvs_s, alts2) = mapAndUnzip fv_alt alts (alts_fvs_s, alts2) = mapAndUnzip fv_alt alts
alts_fvs = foldr unionFVs noFVs alts_fvs_s alts_fvs = foldr unionFVs emptyDVarSet alts_fvs_s
fv_alt (con,args,rhs) = (delBindersFV args (freeVarsOf rhs2), fv_alt (con,args,rhs) = (delBindersFV args (freeVarsOf rhs2),
(con, args, rhs2)) (con, args, rhs2))
...@@ -479,7 +508,7 @@ freeVars (Case scrut bndr ty alts) ...@@ -479,7 +508,7 @@ freeVars (Case scrut bndr ty alts)
freeVars (Let (NonRec binder rhs) body) freeVars (Let (NonRec binder rhs) body)
= (freeVarsOf rhs2 = (freeVarsOf rhs2