module CoreFVs (
exprFreeVars,
exprFreeIds,
exprsFreeVars,
bindFreeVars,
InterestingVarFun,
exprSomeFreeVars, exprsSomeFreeVars,
varTypeTyVars,
idUnfoldingVars, idFreeVars, idRuleAndUnfoldingVars,
idRuleVars, idRuleRhsVars, stableUnfoldingVars,
ruleRhsFreeVars, ruleFreeVars, rulesFreeVars,
ruleLhsOrphNames, ruleLhsFreeIds,
vectsFreeVars,
CoreExprWithFVs,
CoreBindWithFVs,
freeVars,
freeVarsOf
) where
#include "HsVersions.h"
import CoreSyn
import Id
import IdInfo
import NameSet
import UniqFM
import Name
import VarSet
import Var
import TcType
import Coercion
import Maybes( orElse )
import Util
import BasicTypes( Activation )
import Outputable
exprFreeVars :: CoreExpr -> VarSet
exprFreeVars = exprSomeFreeVars isLocalVar
exprFreeIds :: CoreExpr -> IdSet
exprFreeIds = exprSomeFreeVars isLocalId
exprsFreeVars :: [CoreExpr] -> VarSet
exprsFreeVars = mapUnionVarSet exprFreeVars
bindFreeVars :: CoreBind -> VarSet
bindFreeVars (NonRec b r) = rhs_fvs (b,r) isLocalVar emptyVarSet
bindFreeVars (Rec prs) = addBndrs (map fst prs)
(foldr (union . rhs_fvs) noVars prs)
isLocalVar emptyVarSet
exprSomeFreeVars :: InterestingVarFun
-> CoreExpr
-> VarSet
exprSomeFreeVars fv_cand e = expr_fvs e fv_cand emptyVarSet
exprsSomeFreeVars :: InterestingVarFun
-> [CoreExpr]
-> VarSet
exprsSomeFreeVars fv_cand = mapUnionVarSet (exprSomeFreeVars fv_cand)
type InterestingVarFun = Var -> Bool
type FV = InterestingVarFun
-> VarSet
-> VarSet
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
oneVar :: Id -> FV
oneVar var fv_cand in_scope
= ASSERT( isId var )
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 bndr fv fv_cand in_scope
= someVars (varTypeTyVars bndr) fv_cand in_scope
`unionVarSet` fv fv_cand (in_scope `extendVarSet` bndr)
addBndrs :: [CoreBndr] -> FV -> FV
addBndrs bndrs fv = foldr addBndr fv bndrs
expr_fvs :: CoreExpr -> FV
expr_fvs (Type ty) = someVars (tyVarsOfType ty)
expr_fvs (Coercion co) = someVars (tyCoVarsOfCo co)
expr_fvs (Var var) = oneVar var
expr_fvs (Lit _) = noVars
expr_fvs (Tick t expr) = tickish_fvs t `union` expr_fvs expr
expr_fvs (App fun arg) = expr_fvs fun `union` expr_fvs arg
expr_fvs (Lam bndr body) = addBndr bndr (expr_fvs body)
expr_fvs (Cast expr co) = expr_fvs expr `union` someVars (tyCoVarsOfCo co)
expr_fvs (Case scrut bndr ty alts)
= expr_fvs scrut `union` someVars (tyVarsOfType ty) `union` addBndr bndr
(foldr (union . alt_fvs) noVars alts)
where
alt_fvs (_, bndrs, rhs) = addBndrs bndrs (expr_fvs rhs)
expr_fvs (Let (NonRec bndr rhs) body)
= rhs_fvs (bndr, rhs) `union` addBndr bndr (expr_fvs body)
expr_fvs (Let (Rec pairs) body)
= addBndrs (map fst pairs)
(foldr (union . rhs_fvs) (expr_fvs body) pairs)
rhs_fvs :: (Id,CoreExpr) -> FV
rhs_fvs (bndr, rhs) = expr_fvs rhs `union`
someVars (bndrRuleAndUnfoldingVars bndr)
exprs_fvs :: [CoreExpr] -> FV
exprs_fvs exprs = foldr (union . expr_fvs) noVars exprs
tickish_fvs :: Tickish Id -> FV
tickish_fvs (Breakpoint _ ids) = someVars (mkVarSet ids)
tickish_fvs _ = noVars
ruleLhsOrphNames :: CoreRule -> NameSet
ruleLhsOrphNames (BuiltinRule { ru_fn = fn }) = unitNameSet fn
ruleLhsOrphNames (Rule { ru_fn = fn, ru_args = tpl_args })
= extendNameSet (exprsOrphNames tpl_args) fn
exprOrphNames :: CoreExpr -> NameSet
exprOrphNames e
= go e
where
go (Var v)
| isExternalName n = unitNameSet n
| otherwise = emptyNameSet
where n = idName v
go (Lit _) = emptyNameSet
go (Type ty) = orphNamesOfType ty
go (Coercion co) = orphNamesOfCo co
go (App e1 e2) = go e1 `unionNameSet` go e2
go (Lam v e) = go e `delFromNameSet` idName v
go (Tick _ e) = go e
go (Cast e co) = go e `unionNameSet` orphNamesOfCo co
go (Let (NonRec _ r) e) = go e `unionNameSet` go r
go (Let (Rec prs) e) = exprsOrphNames (map snd prs) `unionNameSet` go e
go (Case e _ ty as) = go e `unionNameSet` orphNamesOfType ty
`unionNameSet` unionNameSets (map go_alt as)
go_alt (_,_,r) = go r
exprsOrphNames :: [CoreExpr] -> NameSet
exprsOrphNames es = foldr (unionNameSet . exprOrphNames) emptyNameSet es
ruleRhsFreeVars :: CoreRule -> VarSet
ruleRhsFreeVars (BuiltinRule {}) = noFVs
ruleRhsFreeVars (Rule { ru_fn = _, ru_bndrs = bndrs, ru_rhs = rhs })
= addBndrs bndrs (expr_fvs rhs) isLocalVar emptyVarSet
ruleFreeVars :: CoreRule -> VarSet
ruleFreeVars (BuiltinRule {}) = noFVs
ruleFreeVars (Rule { ru_fn = _, ru_bndrs = bndrs, ru_rhs = rhs, ru_args = args })
= addBndrs bndrs (exprs_fvs (rhs:args)) isLocalVar emptyVarSet
idRuleRhsVars :: (Activation -> Bool) -> Id -> VarSet
idRuleRhsVars is_active id
= mapUnionVarSet get_fvs (idCoreRules id)
where
get_fvs (Rule { ru_fn = fn, ru_bndrs = bndrs
, ru_rhs = rhs, ru_act = act })
| is_active act
= delFromUFM fvs fn
where
fvs = addBndrs bndrs (expr_fvs rhs) isLocalVar emptyVarSet
get_fvs _ = noFVs
rulesFreeVars :: [CoreRule] -> VarSet
rulesFreeVars rules = mapUnionVarSet ruleFreeVars rules
ruleLhsFreeIds :: CoreRule -> VarSet
ruleLhsFreeIds (BuiltinRule {}) = noFVs
ruleLhsFreeIds (Rule { ru_bndrs = bndrs, ru_args = args })
= addBndrs bndrs (exprs_fvs args) isLocalId emptyVarSet
vectsFreeVars :: [CoreVect] -> VarSet
vectsFreeVars = mapUnionVarSet vectFreeVars
where
vectFreeVars (Vect _ rhs) = expr_fvs rhs isLocalId emptyVarSet
vectFreeVars (NoVect _) = noFVs
vectFreeVars (VectType _ _ _) = noFVs
vectFreeVars (VectClass _) = noFVs
vectFreeVars (VectInst _) = noFVs
type CoreBindWithFVs = AnnBind Id VarSet
type CoreExprWithFVs = AnnExpr Id VarSet
freeVarsOf :: CoreExprWithFVs -> IdSet
freeVarsOf (free_vars, _) = free_vars
noFVs :: VarSet
noFVs = emptyVarSet
aFreeVar :: Var -> VarSet
aFreeVar = unitVarSet
unionFVs :: VarSet -> VarSet -> VarSet
unionFVs = unionVarSet
delBindersFV :: [Var] -> VarSet -> VarSet
delBindersFV bs fvs = foldr delBinderFV fvs bs
delBinderFV :: Var -> VarSet -> VarSet
delBinderFV b s = (s `delVarSet` b) `unionFVs` varTypeTyVars b
varTypeTyVars :: Var -> TyVarSet
varTypeTyVars var = tyVarsOfType (varType var)
idFreeVars :: Id -> VarSet
idFreeVars id = ASSERT( isId id)
varTypeTyVars id `unionVarSet`
idRuleAndUnfoldingVars id
bndrRuleAndUnfoldingVars ::Var -> VarSet
bndrRuleAndUnfoldingVars v | isTyVar v = emptyVarSet
| otherwise = idRuleAndUnfoldingVars v
idRuleAndUnfoldingVars :: Id -> VarSet
idRuleAndUnfoldingVars id = ASSERT( isId id)
idRuleVars id `unionVarSet`
idUnfoldingVars id
idRuleVars ::Id -> VarSet
idRuleVars id = ASSERT( isId id) specInfoFreeVars (idSpecialisation id)
idUnfoldingVars :: Id -> VarSet
idUnfoldingVars id = stableUnfoldingVars (realIdUnfolding id) `orElse` emptyVarSet
stableUnfoldingVars :: Unfolding -> Maybe VarSet
stableUnfoldingVars unf
= case unf of
CoreUnfolding { uf_tmpl = rhs, uf_src = src }
| isStableSource src
-> Just (exprFreeVars rhs)
DFunUnfolding { df_bndrs = bndrs, df_args = args }
-> Just (exprs_fvs args isLocalVar (mkVarSet bndrs))
_other -> Nothing
freeVars :: CoreExpr -> CoreExprWithFVs
freeVars (Var v)
= (fvs, AnnVar v)
where
fvs | isLocalVar v = aFreeVar v
| otherwise = noFVs
freeVars (Lit lit) = (noFVs, AnnLit lit)
freeVars (Lam b body)
= (b `delBinderFV` freeVarsOf body', AnnLam b body')
where
body' = freeVars body
freeVars (App fun arg)
= (freeVarsOf fun2 `unionFVs` freeVarsOf arg2, AnnApp fun2 arg2)
where
fun2 = freeVars fun
arg2 = freeVars arg
freeVars (Case scrut bndr ty alts)
= ((bndr `delBinderFV` alts_fvs) `unionFVs` freeVarsOf scrut2 `unionFVs` tyVarsOfType ty,
AnnCase scrut2 bndr ty alts2)
where
scrut2 = freeVars scrut
(alts_fvs_s, alts2) = mapAndUnzip fv_alt alts
alts_fvs = foldr unionFVs noFVs alts_fvs_s
fv_alt (con,args,rhs) = (delBindersFV args (freeVarsOf rhs2),
(con, args, rhs2))
where
rhs2 = freeVars rhs
freeVars (Let (NonRec binder rhs) body)
= (freeVarsOf rhs2
`unionFVs` body_fvs
`unionFVs` bndrRuleAndUnfoldingVars binder,
AnnLet (AnnNonRec binder rhs2) body2)
where
rhs2 = freeVars rhs
body2 = freeVars body
body_fvs = binder `delBinderFV` freeVarsOf body2
freeVars (Let (Rec binds) body)
= (delBindersFV binders all_fvs,
AnnLet (AnnRec (binders `zip` rhss2)) body2)
where
(binders, rhss) = unzip binds
rhss2 = map freeVars rhss
rhs_body_fvs = foldr (unionFVs . freeVarsOf) body_fvs rhss2
all_fvs = foldr (unionFVs . idRuleAndUnfoldingVars) rhs_body_fvs binders
body2 = freeVars body
body_fvs = freeVarsOf body2
freeVars (Cast expr co)
= (freeVarsOf expr2 `unionFVs` cfvs, AnnCast expr2 (cfvs, co))
where
expr2 = freeVars expr
cfvs = tyCoVarsOfCo co
freeVars (Tick tickish expr)
= (tickishFVs tickish `unionFVs` freeVarsOf expr2, AnnTick tickish expr2)
where
expr2 = freeVars expr
tickishFVs (Breakpoint _ ids) = mkVarSet ids
tickishFVs _ = emptyVarSet
freeVars (Type ty) = (tyVarsOfType ty, AnnType ty)
freeVars (Coercion co) = (tyCoVarsOfCo co, AnnCoercion co)