X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FcoreSyn%2FCoreFVs.lhs;h=33017227b429748d93054ae98cd1ca0eebd9f8ca;hp=24af9e2256402386a2523f93f8e5ee180cdc15ed;hb=c5b178be60a5a44abd2f4ddf8c399857678326e2;hpb=5e218036aabd1666ff2b509436e4e88491596c37 diff --git a/compiler/coreSyn/CoreFVs.lhs b/compiler/coreSyn/CoreFVs.lhs index 24af9e2..3301722 100644 --- a/compiler/coreSyn/CoreFVs.lhs +++ b/compiler/coreSyn/CoreFVs.lhs @@ -15,28 +15,28 @@ Taken quite directly from the Peyton Jones/Lester paper. -- | A module concerned with finding the free variables of an expression. module CoreFVs ( -- * Free variables of expressions and binding groups - exprFreeVars, -- CoreExpr -> VarSet -- Find all locally-defined free Ids or tyvars - exprFreeIds, -- CoreExpr -> IdSet -- Find all locally-defined free Ids - exprsFreeVars, -- [CoreExpr] -> VarSet - bindFreeVars, -- CoreBind -> VarSet + exprFreeVars, -- CoreExpr -> VarSet -- Find all locally-defined free Ids or tyvars + exprFreeIds, -- CoreExpr -> IdSet -- Find all locally-defined free Ids + exprsFreeVars, -- [CoreExpr] -> VarSet + bindFreeVars, -- CoreBind -> VarSet -- * Selective free variables of expressions InterestingVarFun, - exprSomeFreeVars, exprsSomeFreeVars, - exprFreeNames, exprsFreeNames, + exprSomeFreeVars, exprsSomeFreeVars, -- * Free variables of Rules, Vars and Ids varTypeTyVars, varTypeTcTyVars, - idUnfoldingVars, idFreeVars, idRuleAndUnfoldingVars, + idUnfoldingVars, idFreeVars, idRuleAndUnfoldingVars, idRuleVars, idRuleRhsVars, stableUnfoldingVars, - ruleRhsFreeVars, rulesFreeVars, - ruleLhsFreeNames, ruleLhsFreeIds, + ruleRhsFreeVars, rulesFreeVars, + ruleLhsOrphNames, ruleLhsFreeIds, + vectsFreeVars, -- * Core syntax tree annotation with free variables - CoreExprWithFVs, -- = AnnExpr Id VarSet - CoreBindWithFVs, -- = AnnBind Id VarSet - freeVars, -- CoreExpr -> CoreExprWithFVs - freeVarsOf -- CoreExprWithFVs -> IdSet + CoreExprWithFVs, -- = AnnExpr Id VarSet + CoreBindWithFVs, -- = AnnBind Id VarSet + freeVars, -- CoreExpr -> CoreExprWithFVs + freeVarsOf -- CoreExprWithFVs -> IdSet ) where #include "HsVersions.h" @@ -50,6 +50,7 @@ import Name import VarSet import Var import TcType +import Coercion import Util import BasicTypes( Activation ) import Outputable @@ -180,12 +181,13 @@ 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 (Note _ expr) = 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 (tyVarsOfType co) +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 @@ -219,7 +221,7 @@ exprs_fvs exprs = foldr (union . expr_fvs) noVars exprs %************************************************************************ \begin{code} --- | Similar to 'exprFreeNames'. However, this is used when deciding whether +-- | ruleLhsOrphNames is used when deciding whether -- a rule is an orphan. In particular, suppose that T is defined in this -- module; we want to avoid declaring that a rule like: -- @@ -227,18 +229,20 @@ exprs_fvs exprs = foldr (union . expr_fvs) noVars exprs -- -- is an orphan. Of course it isn't, and declaring it an orphan would -- make the whole module an orphan module, which is bad. -ruleLhsFreeNames :: CoreRule -> NameSet -ruleLhsFreeNames (BuiltinRule { ru_fn = fn }) = unitNameSet fn -ruleLhsFreeNames (Rule { ru_fn = fn, ru_args = tpl_args }) - = addOneToNameSet (exprsFreeNames tpl_args) fn +ruleLhsOrphNames :: CoreRule -> NameSet +ruleLhsOrphNames (BuiltinRule { ru_fn = fn }) = unitNameSet fn +ruleLhsOrphNames (Rule { ru_fn = fn, ru_args = tpl_args }) + = addOneToNameSet (exprsOrphNames tpl_args) fn + -- No need to delete bndrs, because + -- exprsOrphNames finds only External 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'). -exprFreeNames :: CoreExpr -> NameSet +exprOrphNames :: CoreExpr -> NameSet -- There's no need to delete local binders, because they will all -- be /internal/ names. -exprFreeNames e +exprOrphNames e = go e where go (Var v) @@ -246,27 +250,28 @@ exprFreeNames e | otherwise = emptyNameSet where n = idName v go (Lit _) = emptyNameSet - go (Type ty) = tyClsNamesOfType ty -- Don't need free tyvars + go (Type ty) = orphNamesOfType ty -- Don't need free tyvars + go (Coercion co) = orphNamesOfCo co go (App e1 e2) = go e1 `unionNameSets` go e2 go (Lam v e) = go e `delFromNameSet` idName v go (Note _ e) = go e - go (Cast e co) = go e `unionNameSets` tyClsNamesOfType co + go (Cast e co) = go e `unionNameSets` orphNamesOfCo co go (Let (NonRec _ r) e) = go e `unionNameSets` go r - go (Let (Rec prs) e) = exprsFreeNames (map snd prs) `unionNameSets` go e - go (Case e _ ty as) = go e `unionNameSets` tyClsNamesOfType ty + go (Let (Rec prs) e) = exprsOrphNames (map snd prs) `unionNameSets` go e + go (Case e _ ty as) = go e `unionNameSets` orphNamesOfType ty `unionNameSets` unionManyNameSets (map go_alt as) go_alt (_,_,r) = go r --- | Finds the free /external/ names of several expressions: see 'exprFreeNames' for details -exprsFreeNames :: [CoreExpr] -> NameSet -exprsFreeNames es = foldr (unionNameSets . exprFreeNames) emptyNameSet es +-- | Finds the free /external/ names of several expressions: see 'exprOrphNames' for details +exprsOrphNames :: [CoreExpr] -> NameSet +exprsOrphNames es = foldr (unionNameSets . exprOrphNames) emptyNameSet es \end{code} %************************************************************************ -%* * +%* * \section[freevars-everywhere]{Attaching free variables to every sub-expression} -%* * +%* * %************************************************************************ \begin{code} @@ -274,7 +279,7 @@ exprsFreeNames es = foldr (unionNameSets . exprFreeNames) emptyNameSet es ruleRhsFreeVars :: CoreRule -> VarSet ruleRhsFreeVars (BuiltinRule {}) = noFVs ruleRhsFreeVars (Rule { ru_fn = fn, ru_bndrs = bndrs, ru_rhs = rhs }) - = delFromUFM fvs fn -- Note [Rule free var hack] + = delFromUFM fvs fn -- Note [Rule free var hack] where fvs = addBndrs bndrs (expr_fvs rhs) isLocalVar emptyVarSet @@ -282,7 +287,7 @@ ruleRhsFreeVars (Rule { ru_fn = fn, ru_bndrs = bndrs, ru_rhs = rhs }) ruleFreeVars :: CoreRule -> VarSet ruleFreeVars (BuiltinRule {}) = noFVs ruleFreeVars (Rule { ru_fn = fn, ru_bndrs = bndrs, ru_rhs = rhs, ru_args = args }) - = delFromUFM fvs fn -- Note [Rule free var hack] + = delFromUFM fvs fn -- Note [Rule free var hack] where fvs = addBndrs bndrs (exprs_fvs (rhs:args)) isLocalVar emptyVarSet @@ -294,8 +299,8 @@ idRuleRhsVars is_active id 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] + -- 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 @@ -311,19 +316,32 @@ ruleLhsFreeIds (Rule { ru_bndrs = bndrs, ru_args = args }) = addBndrs bndrs (exprs_fvs args) isLocalId emptyVarSet \end{code} + Note [Rule free var hack] ~~~~~~~~~~~~~~~~~~~~~~~~~ Don't include the Id in its own rhs free-var set. Otherwise the occurrence analyser makes bindings recursive that shoudn't be. E.g. - RULE: f (f x y) z ==> f x (f y z) + RULE: f (f x y) z ==> f x (f y z) Also since rule_fn is a Name, not a Var, we have to use the grungy delUFM. + +\begin{code} +-- |Free variables of a vectorisation declaration +vectsFreeVars :: [CoreVect] -> VarSet +vectsFreeVars = foldr (unionVarSet . vectFreeVars) emptyVarSet + where + vectFreeVars (Vect _ Nothing) = noFVs + vectFreeVars (Vect _ (Just rhs)) = expr_fvs rhs isLocalId emptyVarSet + vectFreeVars (NoVect _) = noFVs +\end{code} + + %************************************************************************ -%* * +%* * \section[freevars-everywhere]{Attaching free variables to every sub-expression} -%* * +%* * %************************************************************************ The free variable pass annotates every node in the expression with its @@ -391,15 +409,15 @@ varTypeTyVars :: Var -> TyVarSet -- Find the type variables free in the type of the variable -- Remember, coercion variables can mention type variables... varTypeTyVars var - | isLocalId var || isCoVar var = tyVarsOfType (idType var) - | otherwise = emptyVarSet -- Global Ids and non-coercion TyVars + | isLocalId var = tyVarsOfType (idType var) + | otherwise = emptyVarSet -- Global Ids and non-coercion TyVars varTypeTcTyVars :: Var -> TyVarSet -- Find the type variables free in the type of the variable -- Remember, coercion variables can mention type variables... varTypeTcTyVars var - | isLocalId var || isCoVar var = tcTyVarsOfType (idType var) - | otherwise = emptyVarSet -- Global Ids and non-coercion TyVars + | isLocalId var = tcTyVarsOfType (idType var) + | otherwise = emptyVarSet -- Global Ids and non-coercion TyVars idFreeVars :: Id -> VarSet -- Type variables, rule variables, and inline variables @@ -410,7 +428,7 @@ idFreeVars id = ASSERT( isId id) bndrRuleAndUnfoldingVars ::Var -> VarSet -- A 'let' can bind a type variable, and idRuleVars assumes -- it's seeing an Id. This function tests first. -bndrRuleAndUnfoldingVars v | isTyCoVar v = emptyVarSet +bndrRuleAndUnfoldingVars v | isTyVar v = emptyVarSet | otherwise = idRuleAndUnfoldingVars v idRuleAndUnfoldingVars :: Id -> VarSet @@ -432,7 +450,7 @@ 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 (DFunUnfolding _ _ args) = exprsFreeVars (dfunArgExprs args) stableUnfoldingVars _ = emptyVarSet \end{code} @@ -509,12 +527,11 @@ freeVars (Let (Rec binds) body) body2 = freeVars body body_fvs = freeVarsOf body2 - freeVars (Cast expr co) - = (freeVarsOf expr2 `unionFVs` cfvs, AnnCast expr2 co) + = (freeVarsOf expr2 `unionFVs` cfvs, AnnCast expr2 (cfvs, co)) where expr2 = freeVars expr - cfvs = tyVarsOfType co + cfvs = tyCoVarsOfCo co freeVars (Note other_note expr) = (freeVarsOf expr2, AnnNote other_note expr2) @@ -522,5 +539,7 @@ freeVars (Note other_note expr) expr2 = freeVars expr freeVars (Type ty) = (tyVarsOfType ty, AnnType ty) + +freeVars (Coercion co) = (tyCoVarsOfCo co, AnnCoercion co) \end{code}