ghc-8.2.1: coreSyn/CoreFVs.hs
{-
(c) The University of Glasgow 2006
(c) The GRASP/AQUA Project, Glasgow University, 1992-1998
Taken quite directly from the Peyton Jones/Lester paper.
-}
{-# LANGUAGE CPP #-}
-- | A module concerned with finding the free variables of an expression.
module CoreFVs (
-- * Free variables of expressions and binding groups
exprFreeVars,
exprFreeVarsDSet,
exprFreeVarsList,
exprFreeIds,
exprFreeIdsDSet,
exprFreeIdsList,
exprsFreeIdsDSet,
exprsFreeIdsList,
exprsFreeVars,
exprsFreeVarsList,
bindFreeVars,
-- * Selective free variables of expressions
InterestingVarFun,
exprSomeFreeVars, exprsSomeFreeVars,
exprSomeFreeVarsList, exprsSomeFreeVarsList,
-- * Free variables of Rules, Vars and Ids
varTypeTyCoVars,
varTypeTyCoFVs,
idUnfoldingVars, idFreeVars, dIdFreeVars,
bndrRuleAndUnfoldingVarsDSet,
idFVs,
idRuleVars, idRuleRhsVars, stableUnfoldingVars,
ruleRhsFreeVars, ruleFreeVars, rulesFreeVars,
rulesFreeVarsDSet,
ruleLhsFreeIds, ruleLhsFreeIdsList,
vectsFreeVars,
expr_fvs,
-- * Orphan names
orphNamesOfType, orphNamesOfCo, orphNamesOfAxiom,
orphNamesOfTypes, orphNamesOfCoCon,
exprsOrphNames, orphNamesOfFamInst,
-- * Core syntax tree annotation with free variables
FVAnn, -- annotation, abstract
CoreExprWithFVs, -- = AnnExpr Id FVAnn
CoreExprWithFVs', -- = AnnExpr' Id FVAnn
CoreBindWithFVs, -- = AnnBind Id FVAnn
CoreAltWithFVs, -- = AnnAlt Id FVAnn
freeVars, -- CoreExpr -> CoreExprWithFVs
freeVarsBind, -- CoreBind -> DVarSet -> (DVarSet, CoreBindWithFVs)
freeVarsOf, -- CoreExprWithFVs -> DIdSet
freeVarsOfType, -- CoreExprWithFVs -> TyCoVarSet
freeVarsOfAnn, freeVarsOfTypeAnn,
exprTypeFV -- CoreExprWithFVs -> Type
) where
#include "HsVersions.h"
import CoreSyn
import Id
import IdInfo
import NameSet
import UniqSet
import Unique (Uniquable (..))
import Literal ( literalType )
import Name
import VarSet
import Var
import Type
import TyCoRep
import TyCon
import CoAxiom
import FamInstEnv
import TysPrim( funTyConName )
import Coercion
import Maybes( orElse )
import Util
import BasicTypes( Activation )
import Outputable
import FV
{-
************************************************************************
* *
\section{Finding the free variables of an expression}
* *
************************************************************************
This function simply finds the free variables of an expression.
So far as type variables are concerned, it only finds tyvars that are
* free in type arguments,
* free in the type of a binder,
but not those that are free in the type of variable occurrence.
-}
-- | Find all locally-defined free Ids or type variables in an expression
-- returning a non-deterministic set.
exprFreeVars :: CoreExpr -> VarSet
exprFreeVars = fvVarSet . exprFVs
-- | Find all locally-defined free Ids or type variables in an expression
-- returning a composable FV computation. See Note [FV naming conventions] in FV
-- for why export it.
exprFVs :: CoreExpr -> FV
exprFVs = filterFV isLocalVar . expr_fvs
-- | Find all locally-defined free Ids or type variables in an expression
-- returning a deterministic set.
exprFreeVarsDSet :: CoreExpr -> DVarSet
exprFreeVarsDSet = fvDVarSet . exprFVs
-- | Find all locally-defined free Ids or type variables in an expression
-- returning a deterministically ordered list.
exprFreeVarsList :: CoreExpr -> [Var]
exprFreeVarsList = fvVarList . exprFVs
-- | Find all locally-defined free Ids in an expression
exprFreeIds :: CoreExpr -> IdSet -- Find all locally-defined free Ids
exprFreeIds = exprSomeFreeVars isLocalId
-- | Find all locally-defined free Ids in an expression
-- returning a deterministic set.
exprFreeIdsDSet :: CoreExpr -> DIdSet -- Find all locally-defined free Ids
exprFreeIdsDSet = exprSomeFreeVarsDSet isLocalId
-- | Find all locally-defined free Ids in an expression
-- returning a deterministically ordered list.
exprFreeIdsList :: CoreExpr -> [Id] -- Find all locally-defined free Ids
exprFreeIdsList = exprSomeFreeVarsList isLocalId
-- | Find all locally-defined free Ids in several expressions
-- returning a deterministic set.
exprsFreeIdsDSet :: [CoreExpr] -> DIdSet -- Find all locally-defined free Ids
exprsFreeIdsDSet = exprsSomeFreeVarsDSet isLocalId
-- | Find all locally-defined free Ids in several expressions
-- returning a deterministically ordered list.
exprsFreeIdsList :: [CoreExpr] -> [Id] -- Find all locally-defined free Ids
exprsFreeIdsList = exprsSomeFreeVarsList isLocalId
-- | Find all locally-defined free Ids or type variables in several expressions
-- returning a non-deterministic set.
exprsFreeVars :: [CoreExpr] -> VarSet
exprsFreeVars = fvVarSet . exprsFVs
-- | Find all locally-defined free Ids or type variables in several expressions
-- returning a composable FV computation. See Note [FV naming conventions] in FV
-- for why export it.
exprsFVs :: [CoreExpr] -> FV
exprsFVs exprs = mapUnionFV exprFVs exprs
-- | Find all locally-defined free Ids or type variables in several expressions
-- returning a deterministically ordered list.
exprsFreeVarsList :: [CoreExpr] -> [Var]
exprsFreeVarsList = fvVarList . exprsFVs
-- | Find all locally defined free Ids in a binding group
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)
-- | Finds free variables in an expression selected by a predicate
exprSomeFreeVars :: InterestingVarFun -- ^ Says which 'Var's are interesting
-> CoreExpr
-> VarSet
exprSomeFreeVars fv_cand e = fvVarSet $ filterFV fv_cand $ expr_fvs e
-- | Finds free variables in an expression selected by a predicate
-- returning a deterministically ordered list.
exprSomeFreeVarsList :: InterestingVarFun -- ^ Says which 'Var's are interesting
-> CoreExpr
-> [Var]
exprSomeFreeVarsList fv_cand e = fvVarList $ filterFV fv_cand $ expr_fvs e
-- | Finds free variables in an expression selected by a predicate
-- returning a deterministic set.
exprSomeFreeVarsDSet :: InterestingVarFun -- ^ Says which 'Var's are interesting
-> CoreExpr
-> DVarSet
exprSomeFreeVarsDSet fv_cand e = fvDVarSet $ filterFV fv_cand $ expr_fvs e
-- | Finds free variables in several expressions selected by a predicate
exprsSomeFreeVars :: InterestingVarFun -- Says which 'Var's are interesting
-> [CoreExpr]
-> VarSet
exprsSomeFreeVars fv_cand es =
fvVarSet $ filterFV fv_cand $ mapUnionFV expr_fvs es
-- | Finds free variables in several expressions selected by a predicate
-- returning a deterministically ordered list.
exprsSomeFreeVarsList :: InterestingVarFun -- Says which 'Var's are interesting
-> [CoreExpr]
-> [Var]
exprsSomeFreeVarsList fv_cand es =
fvVarList $ filterFV fv_cand $ mapUnionFV expr_fvs es
-- | Finds free variables in several expressions selected by a predicate
-- returning a deterministic set.
exprsSomeFreeVarsDSet :: InterestingVarFun -- ^ Says which 'Var's are interesting
-> [CoreExpr]
-> DVarSet
exprsSomeFreeVarsDSet fv_cand e =
fvDVarSet $ filterFV fv_cand $ mapUnionFV expr_fvs e
-- Comment about obselete code
-- We used to gather the free variables the RULES at a variable occurrence
-- with the following cryptic comment:
-- "At a variable occurrence, add in any free variables of its rule rhss
-- Curiously, we gather the Id's free *type* variables from its binding
-- site, but its free *rule-rhs* variables from its usage sites. This
-- is a little weird. The reason is that the former is more efficient,
-- but the latter is more fine grained, and a makes a difference when
-- a variable mentions itself one of its own rule RHSs"
-- Not only is this "weird", but it's also pretty bad because it can make
-- a function seem more recursive than it is. Suppose
-- f = ...g...
-- g = ...
-- RULE g x = ...f...
-- Then f is not mentioned in its own RHS, and needn't be a loop breaker
-- (though g may be). But if we collect the rule fvs from g's occurrence,
-- it looks as if f mentions itself. (This bites in the eftInt/eftIntFB
-- code in GHC.Enum.)
--
-- Anyway, it seems plain wrong. The RULE is like an extra RHS for the
-- function, so its free variables belong at the definition site.
--
-- Deleted code looked like
-- foldVarSet add_rule_var var_itself_set (idRuleVars var)
-- add_rule_var var set | keep_it fv_cand in_scope var = extendVarSet set var
-- | otherwise = set
-- SLPJ Feb06
addBndr :: CoreBndr -> FV -> FV
addBndr bndr fv fv_cand in_scope acc
= (varTypeTyCoFVs bndr `unionFV`
-- Include type variables in the binder's type
-- (not just Ids; coercion variables too!)
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
-- Treat any RULES as extra RHSs of the binding
---------
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
{-
************************************************************************
* *
\section{Free names}
* *
************************************************************************
-}
-- | Finds the free /external/ names of an expression, notably
-- including the names of type constructors (which of course do not show
-- up in 'exprFreeVars').
exprOrphNames :: CoreExpr -> NameSet
-- There's no need to delete local binders, because they will all
-- be /internal/ names.
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 -- Don't need free tyvars
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
-- | Finds the free /external/ names of several expressions: see 'exprOrphNames' for details
exprsOrphNames :: [CoreExpr] -> NameSet
exprsOrphNames es = foldr (unionNameSet . exprOrphNames) emptyNameSet es
{- **********************************************************************
%* *
orphNamesXXX
%* *
%********************************************************************* -}
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'
-- Look through type synonyms (Trac #4912)
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 -- NB! See Trac #8535
`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
orphNamesOfProv :: UnivCoProvenance -> NameSet
orphNamesOfProv UnsafeCoerceProv = emptyNameSet
orphNamesOfProv (PhantomProv co) = orphNamesOfCo co
orphNamesOfProv (ProofIrrelProv co) = orphNamesOfCo co
orphNamesOfProv (PluginProv _) = emptyNameSet
orphNamesOfProv (HoleProv _) = 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
-- | orphNamesOfAxiom collects the names of the concrete types and
-- type constructors that make up the LHS of a type family instance,
-- including the family name itself.
--
-- For instance, given `type family Foo a b`:
-- `type instance Foo (F (G (H a))) b = ...` would yield [Foo,F,G,H]
--
-- Used in the implementation of ":info" in GHCi.
orphNamesOfFamInst :: FamInst -> NameSet
orphNamesOfFamInst fam_inst = orphNamesOfAxiom (famInstAxiom fam_inst)
{-
************************************************************************
* *
\section[freevars-everywhere]{Attaching free variables to every sub-expression}
* *
************************************************************************
-}
-- | Those variables free in the right hand side of a rule returned as a
-- non-deterministic set
ruleRhsFreeVars :: CoreRule -> VarSet
ruleRhsFreeVars (BuiltinRule {}) = noFVs
ruleRhsFreeVars (Rule { ru_fn = _, ru_bndrs = bndrs, ru_rhs = rhs })
= fvVarSet $ filterFV isLocalVar $ addBndrs bndrs (expr_fvs rhs)
-- See Note [Rule free var hack]
-- | Those variables free in the both the left right hand sides of a rule
-- returned as a non-deterministic set
ruleFreeVars :: CoreRule -> VarSet
ruleFreeVars = fvVarSet . ruleFVs
-- | Those variables free in the both the left right hand sides of a rule
-- returned as FV computation
ruleFVs :: CoreRule -> FV
ruleFVs (BuiltinRule {}) = emptyFV
ruleFVs (Rule { ru_fn = _do_not_include
-- See Note [Rule free var hack]
, ru_bndrs = bndrs
, ru_rhs = rhs, ru_args = args })
= filterFV isLocalVar $ addBndrs bndrs (exprs_fvs (rhs:args))
-- | Those variables free in the both the left right hand sides of rules
-- returned as FV computation
rulesFVs :: [CoreRule] -> FV
rulesFVs = mapUnionFV ruleFVs
-- | Those variables free in the both the left right hand sides of rules
-- returned as a deterministic set
rulesFreeVarsDSet :: [CoreRule] -> DVarSet
rulesFreeVarsDSet rules = fvDVarSet $ rulesFVs rules
idRuleRhsVars :: (Activation -> Bool) -> Id -> VarSet
-- Just the variables free on the *rhs* of a rule
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
-- See Note [Finding rule RHS free vars] in OccAnal.hs
= delOneFromUniqSet_Directly fvs (getUnique fn)
-- Note [Rule free var hack]
where
fvs = fvVarSet $ filterFV isLocalVar $ addBndrs bndrs (expr_fvs rhs)
get_fvs _ = noFVs
-- | Those variables free in the right hand side of several rules
rulesFreeVars :: [CoreRule] -> VarSet
rulesFreeVars rules = mapUnionVarSet ruleFreeVars rules
ruleLhsFreeIds :: CoreRule -> VarSet
-- ^ This finds all locally-defined free Ids on the left hand side of a rule
-- and returns them as a non-deterministic set
ruleLhsFreeIds = fvVarSet . ruleLhsFVIds
ruleLhsFreeIdsList :: CoreRule -> [Var]
-- ^ This finds all locally-defined free Ids on the left hand side of a rule
-- and returns them as a determinisitcally ordered list
ruleLhsFreeIdsList = fvVarList . ruleLhsFVIds
ruleLhsFVIds :: CoreRule -> FV
-- ^ This finds all locally-defined free Ids on the left hand side of a rule
-- and returns an FV computation
ruleLhsFVIds (BuiltinRule {}) = emptyFV
ruleLhsFVIds (Rule { ru_bndrs = bndrs, ru_args = args })
= filterFV isLocalId $ addBndrs bndrs (exprs_fvs args)
{-
Note [Rule free var hack] (Not a hack any more)
~~~~~~~~~~~~~~~~~~~~~~~~~
We used not to include the Id in its own rhs free-var set.
Otherwise the occurrence analyser makes bindings recursive:
f x y = x+y
RULE: f (f x y) z ==> f x (f y z)
However, the occurrence analyser distinguishes "non-rule loop breakers"
from "rule-only loop breakers" (see BasicTypes.OccInfo). So it will
put this 'f' in a Rec block, but will mark the binding as a non-rule loop
breaker, which is perfectly inlinable.
-}
-- |Free variables of a vectorisation declaration
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
-- this function is only concerned with values, not types
{-
************************************************************************
* *
\section[freevars-everywhere]{Attaching free variables to every sub-expression}
* *
************************************************************************
The free variable pass annotates every node in the expression with its
NON-GLOBAL free variables and type variables.
-}
data FVAnn = FVAnn { fva_fvs :: DVarSet -- free in expression
, fva_ty_fvs :: DVarSet -- free only in expression's type
, fva_ty :: Type -- expression's type
}
-- | Every node in a binding group annotated with its
-- (non-global) free variables, both Ids and TyVars, and type.
type CoreBindWithFVs = AnnBind Id FVAnn
-- | Every node in an expression annotated with its
-- (non-global) free variables, both Ids and TyVars, and type.
type CoreExprWithFVs = AnnExpr Id FVAnn
type CoreExprWithFVs' = AnnExpr' Id FVAnn
-- | Every node in an expression annotated with its
-- (non-global) free variables, both Ids and TyVars, and type.
type CoreAltWithFVs = AnnAlt Id FVAnn
freeVarsOf :: CoreExprWithFVs -> DIdSet
-- ^ Inverse function to 'freeVars'
freeVarsOf (FVAnn { fva_fvs = fvs }, _) = fvs
-- | Extract the vars free in an annotated expression's type
freeVarsOfType :: CoreExprWithFVs -> DTyCoVarSet
freeVarsOfType (FVAnn { fva_ty_fvs = ty_fvs }, _) = ty_fvs
-- | Extract the type of an annotated expression. (This is cheap.)
exprTypeFV :: CoreExprWithFVs -> Type
exprTypeFV (FVAnn { fva_ty = ty }, _) = ty
-- | Extract the vars reported in a FVAnn
freeVarsOfAnn :: FVAnn -> DIdSet
freeVarsOfAnn = fva_fvs
-- | Extract the type-level vars reported in a FVAnn
freeVarsOfTypeAnn :: FVAnn -> DTyCoVarSet
freeVarsOfTypeAnn = fva_ty_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
-- 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,
-- but *adds* to s
--
-- the free variables of b's type
--
-- This is really important for some lambdas:
-- In (\x::a -> x) the only mention of "a" is in the binder.
--
-- Also in
-- let x::a = b in ...
-- we should really note that "a" is free in this expression.
-- It'll be pinned inside the /\a by the binding for b, but
-- it seems cleaner to make sure that a is in the free-var set
-- when it is mentioned.
--
-- This also shows up in recursive bindings. Consider:
-- /\a -> letrec x::a = x in E
-- Now, there are no explicit free type variables in the RHS of x,
-- but nevertheless "a" is free in its definition. So we add in
-- the free tyvars of the types of the binders, and include these in the
-- free vars of the group, attached to the top level of each RHS.
--
-- This actually happened in the defn of errorIO in IOBase.hs:
-- errorIO (ST io) = case (errorIO# io) of
-- _ -> bottom
-- where
-- bottom = bottom -- Never evaluated
delBinderFV b s = (s `delDVarSet` b) `unionFVs` dVarTypeTyCoVars b
-- Include coercion variables too!
varTypeTyCoVars :: Var -> TyCoVarSet
-- Find the type/kind variables free in the type of the id/tyvar
varTypeTyCoVars var = fvVarSet $ varTypeTyCoFVs var
dVarTypeTyCoVars :: Var -> DTyCoVarSet
-- Find the type/kind/coercion variables free in the type of the id/tyvar
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
-- Type variables, rule variables, and inline variables
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 -- Does *not* include CoreUnfolding vars
idRuleVars id = fvVarSet $ idRuleFVs id
idRuleFVs :: Id -> FV
idRuleFVs id = ASSERT( isId id)
FV.mkFVs (dVarSetElems $ ruleInfoFreeVars (idSpecialisation 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 = 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)
-- DFuns are top level, so no fvs from types of bndrs
_other -> Nothing
{-
************************************************************************
* *
\subsection{Free variables (and types)}
* *
************************************************************************
-}
freeVarsBind :: CoreBind
-> DVarSet -- Free vars of scope of binding
-> (CoreBindWithFVs, DVarSet) -- Return free vars of binding + scope
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
-- The "delBinderFV" happens after adding the idSpecVars,
-- since the latter may add some of the binders as fvs
freeVars :: CoreExpr -> CoreExprWithFVs
-- ^ Annotate a 'CoreExpr' with its (non-global) free type and value variables at every tree node
freeVars = go
where
go :: CoreExpr -> CoreExprWithFVs
go (Var v)
= (FVAnn fvs ty_fvs (idType v), AnnVar v)
where
-- ToDo: insert motivating example for why we *need*
-- to include the idSpecVars in the FV list.
-- Actually [June 98] I don't think it's necessary
-- fvs = fvs_v `unionVarSet` idSpecVars v
(fvs, ty_fvs)
| isLocalVar v = (aFreeVar v `unionFVs` ty_fvs, dVarTypeTyCoVars v)
| otherwise = (emptyDVarSet, emptyDVarSet)
go (Lit lit) = (FVAnn emptyDVarSet emptyDVarSet (literalType lit), AnnLit lit)
go (Lam b body)
= ( FVAnn { fva_fvs = b_fvs `unionFVs` (b `delBinderFV` body_fvs)
, fva_ty_fvs = b_fvs `unionFVs` (b `delBinderFV` body_ty_fvs)
, fva_ty = mkFunTy b_ty body_ty }
, AnnLam b body' )
where
body'@(FVAnn { fva_fvs = body_fvs, fva_ty_fvs = body_ty_fvs
, fva_ty = body_ty }, _) = go body
b_ty = idType b
b_fvs = tyCoVarsOfTypeDSet b_ty
go (App fun arg)
= ( FVAnn { fva_fvs = freeVarsOf fun' `unionFVs` freeVarsOf arg'
, fva_ty_fvs = tyCoVarsOfTypeDSet res_ty
, fva_ty = res_ty }
, AnnApp fun' arg' )
where
fun' = go fun
fun_ty = exprTypeFV fun'
arg' = go arg
res_ty = applyTypeToArg fun_ty arg
go (Case scrut bndr ty alts)
= ( FVAnn { fva_fvs = (bndr `delBinderFV` alts_fvs)
`unionFVs` freeVarsOf scrut2
`unionFVs` tyCoVarsOfTypeDSet ty
-- don't need to look at (idType bndr)
-- b/c that's redundant with scrut
, fva_ty_fvs = tyCoVarsOfTypeDSet ty
, fva_ty = 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)
= ( FVAnn { fva_fvs = bind_fvs
, fva_ty_fvs = freeVarsOfType body2
, fva_ty = exprTypeFV body2 }
, AnnLet bind2 body2 )
where
(bind2, bind_fvs) = freeVarsBind bind (freeVarsOf body2)
body2 = go body
go (Cast expr co)
= ( FVAnn (freeVarsOf expr2 `unionFVs` cfvs) (tyCoVarsOfTypeDSet to_ty) to_ty
, AnnCast expr2 (c_ann, co) )
where
expr2 = go expr
cfvs = tyCoVarsOfCoDSet co
c_ann = FVAnn cfvs (tyCoVarsOfTypeDSet co_ki) co_ki
co_ki = coercionType co
Just (_, to_ty) = splitCoercionType_maybe co_ki
go (Tick tickish expr)
= ( FVAnn { fva_fvs = tickishFVs tickish `unionFVs` freeVarsOf expr2
, fva_ty_fvs = freeVarsOfType expr2
, fva_ty = exprTypeFV expr2 }
, AnnTick tickish expr2 )
where
expr2 = go expr
tickishFVs (Breakpoint _ ids) = mkDVarSet ids
tickishFVs _ = emptyDVarSet
go (Type ty) = ( FVAnn (tyCoVarsOfTypeDSet ty)
(tyCoVarsOfTypeDSet ki)
ki
, AnnType ty)
where
ki = typeKind ty
go (Coercion co) = ( FVAnn (tyCoVarsOfCoDSet co)
(tyCoVarsOfTypeDSet ki)
ki
, AnnCoercion co)
where
ki = coercionType co