{-# LANGUAGE CPP #-}
module CoreFVs (
exprFreeVars,
exprFreeVarsDSet,
exprFreeVarsList,
exprFreeIds,
exprFreeIdsDSet,
exprFreeIdsList,
exprsFreeIdsDSet,
exprsFreeIdsList,
exprsFreeVars,
exprsFreeVarsList,
bindFreeVars,
InterestingVarFun,
exprSomeFreeVars, exprsSomeFreeVars,
exprSomeFreeVarsList, exprsSomeFreeVarsList,
varTypeTyCoVars,
varTypeTyCoFVs,
idUnfoldingVars, idFreeVars, dIdFreeVars,
bndrRuleAndUnfoldingVarsDSet,
idFVs,
idRuleVars, idRuleRhsVars, stableUnfoldingVars,
ruleRhsFreeVars, ruleFreeVars, rulesFreeVars,
rulesFreeVarsDSet,
ruleLhsFreeIds, ruleLhsFreeIdsList,
vectsFreeVars,
expr_fvs,
orphNamesOfType, orphNamesOfCo, orphNamesOfAxiom,
orphNamesOfTypes, orphNamesOfCoCon,
exprsOrphNames, orphNamesOfFamInst,
FVAnn,
CoreExprWithFVs,
CoreExprWithFVs',
CoreBindWithFVs,
CoreAltWithFVs,
freeVars,
freeVarsBind,
freeVarsOf,
freeVarsOfAnn
) where
#include "HsVersions.h"
import GhcPrelude
import CoreSyn
import Id
import IdInfo
import NameSet
import UniqSet
import Unique (Uniquable (..))
import Name
import VarSet
import Var
import Type
import TyCoRep
import TyCon
import CoAxiom
import FamInstEnv
import TysPrim( funTyConName )
import Maybes( orElse )
import Util
import BasicTypes( Activation )
import Outputable
import FV
exprFreeVars :: CoreExpr -> VarSet
exprFreeVars = fvVarSet . exprFVs
exprFVs :: CoreExpr -> FV
exprFVs = filterFV isLocalVar . expr_fvs
exprFreeVarsDSet :: CoreExpr -> DVarSet
exprFreeVarsDSet = fvDVarSet . exprFVs
exprFreeVarsList :: CoreExpr -> [Var]
exprFreeVarsList = fvVarList . exprFVs
exprFreeIds :: CoreExpr -> IdSet
exprFreeIds = exprSomeFreeVars isLocalId
exprFreeIdsDSet :: CoreExpr -> DIdSet
exprFreeIdsDSet = exprSomeFreeVarsDSet isLocalId
exprFreeIdsList :: CoreExpr -> [Id]
exprFreeIdsList = exprSomeFreeVarsList isLocalId
exprsFreeIdsDSet :: [CoreExpr] -> DIdSet
exprsFreeIdsDSet = exprsSomeFreeVarsDSet isLocalId
exprsFreeIdsList :: [CoreExpr] -> [Id]
exprsFreeIdsList = exprsSomeFreeVarsList isLocalId
exprsFreeVars :: [CoreExpr] -> VarSet
exprsFreeVars = fvVarSet . exprsFVs
exprsFVs :: [CoreExpr] -> FV
exprsFVs exprs = mapUnionFV exprFVs exprs
exprsFreeVarsList :: [CoreExpr] -> [Var]
exprsFreeVarsList = fvVarList . exprsFVs
bindFreeVars :: CoreBind -> VarSet
bindFreeVars (NonRec b r) = fvVarSet $ filterFV isLocalVar $ rhs_fvs (b,r)
bindFreeVars (Rec prs) = fvVarSet $ filterFV isLocalVar $
addBndrs (map fst prs)
(mapUnionFV rhs_fvs prs)
exprSomeFreeVars :: InterestingVarFun
-> CoreExpr
-> VarSet
exprSomeFreeVars fv_cand e = fvVarSet $ filterFV fv_cand $ expr_fvs e
exprSomeFreeVarsList :: InterestingVarFun
-> CoreExpr
-> [Var]
exprSomeFreeVarsList fv_cand e = fvVarList $ filterFV fv_cand $ expr_fvs e
exprSomeFreeVarsDSet :: InterestingVarFun
-> CoreExpr
-> DVarSet
exprSomeFreeVarsDSet fv_cand e = fvDVarSet $ filterFV fv_cand $ expr_fvs e
exprsSomeFreeVars :: InterestingVarFun
-> [CoreExpr]
-> VarSet
exprsSomeFreeVars fv_cand es =
fvVarSet $ filterFV fv_cand $ mapUnionFV expr_fvs es
exprsSomeFreeVarsList :: InterestingVarFun
-> [CoreExpr]
-> [Var]
exprsSomeFreeVarsList fv_cand es =
fvVarList $ filterFV fv_cand $ mapUnionFV expr_fvs es
exprsSomeFreeVarsDSet :: InterestingVarFun
-> [CoreExpr]
-> DVarSet
exprsSomeFreeVarsDSet fv_cand e =
fvDVarSet $ filterFV fv_cand $ mapUnionFV expr_fvs e
addBndr :: CoreBndr -> FV -> FV
addBndr bndr fv fv_cand in_scope acc
= (varTypeTyCoFVs bndr `unionFV`
FV.delFV bndr fv) fv_cand in_scope acc
addBndrs :: [CoreBndr] -> FV -> FV
addBndrs bndrs fv = foldr addBndr fv bndrs
expr_fvs :: CoreExpr -> FV
expr_fvs (Type ty) fv_cand in_scope acc =
tyCoFVsOfType ty fv_cand in_scope acc
expr_fvs (Coercion co) fv_cand in_scope acc =
tyCoFVsOfCo co fv_cand in_scope acc
expr_fvs (Var var) fv_cand in_scope acc = FV.unitFV var fv_cand in_scope acc
expr_fvs (Lit _) fv_cand in_scope acc = emptyFV fv_cand in_scope acc
expr_fvs (Tick t expr) fv_cand in_scope acc =
(tickish_fvs t `unionFV` expr_fvs expr) fv_cand in_scope acc
expr_fvs (App fun arg) fv_cand in_scope acc =
(expr_fvs fun `unionFV` expr_fvs arg) fv_cand in_scope acc
expr_fvs (Lam bndr body) fv_cand in_scope acc =
addBndr bndr (expr_fvs body) fv_cand in_scope acc
expr_fvs (Cast expr co) fv_cand in_scope acc =
(expr_fvs expr `unionFV` tyCoFVsOfCo co) fv_cand in_scope acc
expr_fvs (Case scrut bndr ty alts) fv_cand in_scope acc
= (expr_fvs scrut `unionFV` tyCoFVsOfType ty `unionFV` addBndr bndr
(mapUnionFV alt_fvs alts)) fv_cand in_scope acc
where
alt_fvs (_, bndrs, rhs) = addBndrs bndrs (expr_fvs rhs)
expr_fvs (Let (NonRec bndr rhs) body) fv_cand in_scope acc
= (rhs_fvs (bndr, rhs) `unionFV` addBndr bndr (expr_fvs body))
fv_cand in_scope acc
expr_fvs (Let (Rec pairs) body) fv_cand in_scope acc
= addBndrs (map fst pairs)
(mapUnionFV rhs_fvs pairs `unionFV` expr_fvs body)
fv_cand in_scope acc
rhs_fvs :: (Id, CoreExpr) -> FV
rhs_fvs (bndr, rhs) = expr_fvs rhs `unionFV`
bndrRuleAndUnfoldingFVs bndr
exprs_fvs :: [CoreExpr] -> FV
exprs_fvs exprs = mapUnionFV expr_fvs exprs
tickish_fvs :: Tickish Id -> FV
tickish_fvs (Breakpoint _ ids) = FV.mkFVs ids
tickish_fvs _ = emptyFV
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
orphNamesOfTyCon :: TyCon -> NameSet
orphNamesOfTyCon tycon = unitNameSet (getName tycon) `unionNameSet` case tyConClass_maybe tycon of
Nothing -> emptyNameSet
Just cls -> unitNameSet (getName cls)
orphNamesOfType :: Type -> NameSet
orphNamesOfType ty | Just ty' <- coreView ty = orphNamesOfType ty'
orphNamesOfType (TyVarTy _) = emptyNameSet
orphNamesOfType (LitTy {}) = emptyNameSet
orphNamesOfType (TyConApp tycon tys) = orphNamesOfTyCon tycon
`unionNameSet` orphNamesOfTypes tys
orphNamesOfType (ForAllTy bndr res) = orphNamesOfType (binderKind bndr)
`unionNameSet` orphNamesOfType res
orphNamesOfType (FunTy arg res) = unitNameSet funTyConName
`unionNameSet` orphNamesOfType arg
`unionNameSet` orphNamesOfType res
orphNamesOfType (AppTy fun arg) = orphNamesOfType fun `unionNameSet` orphNamesOfType arg
orphNamesOfType (CastTy ty co) = orphNamesOfType ty `unionNameSet` orphNamesOfCo co
orphNamesOfType (CoercionTy co) = orphNamesOfCo co
orphNamesOfThings :: (a -> NameSet) -> [a] -> NameSet
orphNamesOfThings f = foldr (unionNameSet . f) emptyNameSet
orphNamesOfTypes :: [Type] -> NameSet
orphNamesOfTypes = orphNamesOfThings orphNamesOfType
orphNamesOfCo :: Coercion -> NameSet
orphNamesOfCo (Refl _ ty) = orphNamesOfType ty
orphNamesOfCo (TyConAppCo _ tc cos) = unitNameSet (getName tc) `unionNameSet` orphNamesOfCos cos
orphNamesOfCo (AppCo co1 co2) = orphNamesOfCo co1 `unionNameSet` orphNamesOfCo co2
orphNamesOfCo (ForAllCo _ kind_co co)
= orphNamesOfCo kind_co `unionNameSet` orphNamesOfCo co
orphNamesOfCo (FunCo _ co1 co2) = orphNamesOfCo co1 `unionNameSet` orphNamesOfCo co2
orphNamesOfCo (CoVarCo _) = emptyNameSet
orphNamesOfCo (AxiomInstCo con _ cos) = orphNamesOfCoCon con `unionNameSet` orphNamesOfCos cos
orphNamesOfCo (UnivCo p _ t1 t2) = orphNamesOfProv p `unionNameSet` orphNamesOfType t1 `unionNameSet` orphNamesOfType t2
orphNamesOfCo (SymCo co) = orphNamesOfCo co
orphNamesOfCo (TransCo co1 co2) = orphNamesOfCo co1 `unionNameSet` orphNamesOfCo co2
orphNamesOfCo (NthCo _ co) = orphNamesOfCo co
orphNamesOfCo (LRCo _ co) = orphNamesOfCo co
orphNamesOfCo (InstCo co arg) = orphNamesOfCo co `unionNameSet` orphNamesOfCo arg
orphNamesOfCo (CoherenceCo co1 co2) = orphNamesOfCo co1 `unionNameSet` orphNamesOfCo co2
orphNamesOfCo (KindCo co) = orphNamesOfCo co
orphNamesOfCo (SubCo co) = orphNamesOfCo co
orphNamesOfCo (AxiomRuleCo _ cs) = orphNamesOfCos cs
orphNamesOfCo (HoleCo _) = emptyNameSet
orphNamesOfProv :: UnivCoProvenance -> NameSet
orphNamesOfProv UnsafeCoerceProv = emptyNameSet
orphNamesOfProv (PhantomProv co) = orphNamesOfCo co
orphNamesOfProv (ProofIrrelProv co) = orphNamesOfCo co
orphNamesOfProv (PluginProv _) = emptyNameSet
orphNamesOfCos :: [Coercion] -> NameSet
orphNamesOfCos = orphNamesOfThings orphNamesOfCo
orphNamesOfCoCon :: CoAxiom br -> NameSet
orphNamesOfCoCon (CoAxiom { co_ax_tc = tc, co_ax_branches = branches })
= orphNamesOfTyCon tc `unionNameSet` orphNamesOfCoAxBranches branches
orphNamesOfAxiom :: CoAxiom br -> NameSet
orphNamesOfAxiom axiom
= orphNamesOfTypes (concatMap coAxBranchLHS $ fromBranches $ coAxiomBranches axiom)
`extendNameSet` getName (coAxiomTyCon axiom)
orphNamesOfCoAxBranches :: Branches br -> NameSet
orphNamesOfCoAxBranches
= foldr (unionNameSet . orphNamesOfCoAxBranch) emptyNameSet . fromBranches
orphNamesOfCoAxBranch :: CoAxBranch -> NameSet
orphNamesOfCoAxBranch (CoAxBranch { cab_lhs = lhs, cab_rhs = rhs })
= orphNamesOfTypes lhs `unionNameSet` orphNamesOfType rhs
orphNamesOfFamInst :: FamInst -> NameSet
orphNamesOfFamInst fam_inst = orphNamesOfAxiom (famInstAxiom fam_inst)
ruleRhsFreeVars :: CoreRule -> VarSet
ruleRhsFreeVars (BuiltinRule {}) = noFVs
ruleRhsFreeVars (Rule { ru_fn = _, ru_bndrs = bndrs, ru_rhs = rhs })
= fvVarSet $ filterFV isLocalVar $ addBndrs bndrs (expr_fvs rhs)
ruleFreeVars :: CoreRule -> VarSet
ruleFreeVars = fvVarSet . ruleFVs
ruleFVs :: CoreRule -> FV
ruleFVs (BuiltinRule {}) = emptyFV
ruleFVs (Rule { ru_fn = _do_not_include
, ru_bndrs = bndrs
, ru_rhs = rhs, ru_args = args })
= filterFV isLocalVar $ addBndrs bndrs (exprs_fvs (rhs:args))
rulesFVs :: [CoreRule] -> FV
rulesFVs = mapUnionFV ruleFVs
rulesFreeVarsDSet :: [CoreRule] -> DVarSet
rulesFreeVarsDSet rules = fvDVarSet $ rulesFVs rules
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
= delOneFromUniqSet_Directly fvs (getUnique fn)
where
fvs = fvVarSet $ filterFV isLocalVar $ addBndrs bndrs (expr_fvs rhs)
get_fvs _ = noFVs
rulesFreeVars :: [CoreRule] -> VarSet
rulesFreeVars rules = mapUnionVarSet ruleFreeVars rules
ruleLhsFreeIds :: CoreRule -> VarSet
ruleLhsFreeIds = fvVarSet . ruleLhsFVIds
ruleLhsFreeIdsList :: CoreRule -> [Var]
ruleLhsFreeIdsList = fvVarList . ruleLhsFVIds
ruleLhsFVIds :: CoreRule -> FV
ruleLhsFVIds (BuiltinRule {}) = emptyFV
ruleLhsFVIds (Rule { ru_bndrs = bndrs, ru_args = args })
= filterFV isLocalId $ addBndrs bndrs (exprs_fvs args)
vectsFreeVars :: [CoreVect] -> VarSet
vectsFreeVars = mapUnionVarSet vectFreeVars
where
vectFreeVars (Vect _ rhs) = fvVarSet $ filterFV isLocalId $ expr_fvs rhs
vectFreeVars (NoVect _) = noFVs
vectFreeVars (VectType _ _ _) = noFVs
vectFreeVars (VectClass _) = noFVs
vectFreeVars (VectInst _) = noFVs
type FVAnn = DVarSet
type CoreBindWithFVs = AnnBind Id FVAnn
type CoreExprWithFVs = AnnExpr Id FVAnn
type CoreExprWithFVs' = AnnExpr' Id FVAnn
type CoreAltWithFVs = AnnAlt Id FVAnn
freeVarsOf :: CoreExprWithFVs -> DIdSet
freeVarsOf (fvs, _) = fvs
freeVarsOfAnn :: FVAnn -> DIdSet
freeVarsOfAnn fvs = fvs
noFVs :: VarSet
noFVs = emptyVarSet
aFreeVar :: Var -> DVarSet
aFreeVar = unitDVarSet
unionFVs :: DVarSet -> DVarSet -> DVarSet
unionFVs = unionDVarSet
unionFVss :: [DVarSet] -> DVarSet
unionFVss = unionDVarSets
delBindersFV :: [Var] -> DVarSet -> DVarSet
delBindersFV bs fvs = foldr delBinderFV fvs bs
delBinderFV :: Var -> DVarSet -> DVarSet
delBinderFV b s = (s `delDVarSet` b) `unionFVs` dVarTypeTyCoVars b
varTypeTyCoVars :: Var -> TyCoVarSet
varTypeTyCoVars var = fvVarSet $ varTypeTyCoFVs var
dVarTypeTyCoVars :: Var -> DTyCoVarSet
dVarTypeTyCoVars var = fvDVarSet $ varTypeTyCoFVs var
varTypeTyCoFVs :: Var -> FV
varTypeTyCoFVs var = tyCoFVsOfType (varType var)
idFreeVars :: Id -> VarSet
idFreeVars id = ASSERT( isId id) fvVarSet $ idFVs id
dIdFreeVars :: Id -> DVarSet
dIdFreeVars id = fvDVarSet $ idFVs id
idFVs :: Id -> FV
idFVs id = ASSERT( isId id)
varTypeTyCoFVs id `unionFV`
bndrRuleAndUnfoldingFVs id
bndrRuleAndUnfoldingVarsDSet :: Id -> DVarSet
bndrRuleAndUnfoldingVarsDSet id = fvDVarSet $ bndrRuleAndUnfoldingFVs id
bndrRuleAndUnfoldingFVs :: Id -> FV
bndrRuleAndUnfoldingFVs id
| isId id = idRuleFVs id `unionFV` idUnfoldingFVs id
| otherwise = emptyFV
idRuleVars ::Id -> VarSet
idRuleVars id = fvVarSet $ idRuleFVs id
idRuleFVs :: Id -> FV
idRuleFVs id = ASSERT( isId id)
FV.mkFVs (dVarSetElems $ ruleInfoFreeVars (idSpecialisation id))
idUnfoldingVars :: Id -> VarSet
idUnfoldingVars id = fvVarSet $ idUnfoldingFVs id
idUnfoldingFVs :: Id -> FV
idUnfoldingFVs id = stableUnfoldingFVs (realIdUnfolding id) `orElse` emptyFV
stableUnfoldingVars :: Unfolding -> Maybe VarSet
stableUnfoldingVars unf = fvVarSet `fmap` stableUnfoldingFVs unf
stableUnfoldingFVs :: Unfolding -> Maybe FV
stableUnfoldingFVs unf
= case unf of
CoreUnfolding { uf_tmpl = rhs, uf_src = src }
| isStableSource src
-> Just (filterFV isLocalVar $ expr_fvs rhs)
DFunUnfolding { df_bndrs = bndrs, df_args = args }
-> Just (filterFV isLocalVar $ FV.delFVs (mkVarSet bndrs) $ exprs_fvs args)
_other -> Nothing
freeVarsBind :: CoreBind
-> DVarSet
-> (CoreBindWithFVs, DVarSet)
freeVarsBind (NonRec binder rhs) body_fvs
= ( AnnNonRec binder rhs2
, freeVarsOf rhs2 `unionFVs` body_fvs2
`unionFVs` bndrRuleAndUnfoldingVarsDSet binder )
where
rhs2 = freeVars rhs
body_fvs2 = binder `delBinderFV` body_fvs
freeVarsBind (Rec binds) body_fvs
= ( AnnRec (binders `zip` rhss2)
, delBindersFV binders all_fvs )
where
(binders, rhss) = unzip binds
rhss2 = map freeVars rhss
rhs_body_fvs = foldr (unionFVs . freeVarsOf) body_fvs rhss2
binders_fvs = fvDVarSet $ mapUnionFV bndrRuleAndUnfoldingFVs binders
all_fvs = rhs_body_fvs `unionFVs` binders_fvs
freeVars :: CoreExpr -> CoreExprWithFVs
freeVars = go
where
go :: CoreExpr -> CoreExprWithFVs
go (Var v)
| isLocalVar v = (aFreeVar v `unionFVs` ty_fvs, AnnVar v)
| otherwise = (emptyDVarSet, AnnVar v)
where
ty_fvs = dVarTypeTyCoVars v
go (Lit lit) = (emptyDVarSet, AnnLit lit)
go (Lam b body)
= ( b_fvs `unionFVs` (b `delBinderFV` body_fvs)
, AnnLam b body' )
where
body'@(body_fvs, _) = go body
b_ty = idType b
b_fvs = tyCoVarsOfTypeDSet b_ty
go (App fun arg)
= ( freeVarsOf fun' `unionFVs` freeVarsOf arg'
, AnnApp fun' arg' )
where
fun' = go fun
arg' = go arg
go (Case scrut bndr ty alts)
= ( (bndr `delBinderFV` alts_fvs)
`unionFVs` freeVarsOf scrut2
`unionFVs` tyCoVarsOfTypeDSet ty
, AnnCase scrut2 bndr ty alts2 )
where
scrut2 = go scrut
(alts_fvs_s, alts2) = mapAndUnzip fv_alt alts
alts_fvs = unionFVss alts_fvs_s
fv_alt (con,args,rhs) = (delBindersFV args (freeVarsOf rhs2),
(con, args, rhs2))
where
rhs2 = go rhs
go (Let bind body)
= (bind_fvs, AnnLet bind2 body2)
where
(bind2, bind_fvs) = freeVarsBind bind (freeVarsOf body2)
body2 = go body
go (Cast expr co)
= ( freeVarsOf expr2 `unionFVs` cfvs
, AnnCast expr2 (cfvs, co) )
where
expr2 = go expr
cfvs = tyCoVarsOfCoDSet co
go (Tick tickish expr)
= ( tickishFVs tickish `unionFVs` freeVarsOf expr2
, AnnTick tickish expr2 )
where
expr2 = go expr
tickishFVs (Breakpoint _ ids) = mkDVarSet ids
tickishFVs _ = emptyDVarSet
go (Type ty) = (tyCoVarsOfTypeDSet ty, AnnType ty)
go (Coercion co) = (tyCoVarsOfCoDSet co, AnnCoercion co)