Taken quite directly from the Peyton Jones/Lester paper.
\begin{code}
-module FreeVars (
- freeVars,
- freeVarsOf,
- CoreExprWithFVs, CoreBindWithFVs
+module CoreFVs (
+ exprFreeVars, exprsFreeVars,
+ exprSomeFreeVars, exprsSomeFreeVars,
+ idRuleVars, idFreeVars, ruleSomeFreeVars, ruleSomeLhsFreeVars,
+
+ CoreExprWithFVs, CoreBindWithFVs, freeVars, freeVarsOf,
) where
#include "HsVersions.h"
import CoreSyn
-import CoreUtils ( idFreeVars )
-import Id ( Id )
+import Id ( Id, idFreeTyVars, getIdSpecialisation )
import VarSet
import Var ( IdOrTyVar, isId )
import Name ( isLocallyDefined )
%************************************************************************
%* *
-\section[freevars-everywhere]{Attaching free variables to every sub-expression
+\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.
+
+\begin{code}
+exprFreeVars :: CoreExpr -> IdOrTyVarSet -- Find all locally-defined free Ids or tyvars
+exprFreeVars = exprSomeFreeVars isLocallyDefined
+
+exprsFreeVars :: [CoreExpr] -> IdOrTyVarSet
+exprsFreeVars = foldr (unionVarSet . exprFreeVars) emptyVarSet
+
+exprSomeFreeVars :: InterestingVarFun -- Says which Vars are interesting
+ -> CoreExpr
+ -> IdOrTyVarSet
+exprSomeFreeVars fv_cand e = expr_fvs e fv_cand emptyVarSet
+
+exprsSomeFreeVars :: InterestingVarFun -- Says which Vars are interesting
+ -> [CoreExpr]
+ -> IdOrTyVarSet
+exprsSomeFreeVars fv_cand = foldr (unionVarSet . exprSomeFreeVars fv_cand) emptyVarSet
+
+type InterestingVarFun = IdOrTyVar -> Bool -- True <=> interesting
+\end{code}
+
+
+\begin{code}
+type FV = InterestingVarFun
+ -> IdOrTyVarSet -- In scope
+ -> IdOrTyVarSet -- Free vars
+
+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 fv_cand in_scope = emptyVarSet
+
+-- 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
+oneVar :: IdOrTyVar -> FV
+oneVar var fv_cand in_scope
+ = foldVarSet add_rule_var var_itself_set (idRuleVars var)
+ where
+ var_itself_set | keep_it fv_cand in_scope var = unitVarSet var
+ | otherwise = emptyVarSet
+ add_rule_var var set | keep_it fv_cand in_scope var = extendVarSet set var
+ | otherwise = set
+
+someVars :: IdOrTyVarSet -> FV
+someVars vars fv_cand in_scope
+ = filterVarSet (keep_it fv_cand in_scope) vars
+
+keep_it fv_cand in_scope var
+ | var `elemVarSet` in_scope = False
+ | fv_cand var = True
+ | otherwise = False
+
+
+addBndr :: CoreBndr -> FV -> FV
+addBndr bndr fv fv_cand in_scope
+ | isId bndr = inside_fvs `unionVarSet` someVars (idFreeTyVars bndr) fv_cand in_scope
+ | otherwise = inside_fvs
+ where
+ inside_fvs = fv fv_cand (in_scope `extendVarSet` bndr)
+
+addBndrs :: [CoreBndr] -> FV -> FV
+addBndrs bndrs fv = foldr addBndr fv bndrs
+\end{code}
+
+
+\begin{code}
+expr_fvs :: CoreExpr -> FV
+
+expr_fvs (Type ty) = someVars (tyVarsOfType ty)
+expr_fvs (Var var) = oneVar var
+expr_fvs (Con con args) = foldr (union . expr_fvs) noVars args
+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 (Case scrut bndr alts)
+ = expr_fvs scrut `union` addBndr bndr (foldr (union . alt_fvs) noVars alts)
+ where
+ alt_fvs (con, bndrs, rhs) = addBndrs bndrs (expr_fvs rhs)
+
+expr_fvs (Let (NonRec bndr rhs) body)
+ = expr_fvs rhs `union` addBndr bndr (expr_fvs body)
+
+expr_fvs (Let (Rec pairs) body)
+ = addBndrs bndrs (foldr (union . expr_fvs) (expr_fvs body) rhss)
+ where
+ (bndrs,rhss) = unzip pairs
+\end{code}
+
+
+
+\begin{code}
+idRuleVars ::Id -> IdOrTyVarSet
+idRuleVars id = rulesRhsFreeVars (getIdSpecialisation id)
+
+idFreeVars :: Id -> IdOrTyVarSet
+idFreeVars id = idRuleVars id `unionVarSet` idFreeTyVars id
+
+rulesSomeFreeVars :: InterestingVarFun -> CoreRules -> IdOrTyVarSet
+rulesSomeFreeVars interesting (Rules rules _)
+ = foldr (unionVarSet . ruleSomeFreeVars interesting) emptyVarSet rules
+
+ruleSomeFreeVars :: InterestingVarFun -> CoreRule -> IdOrTyVarSet
+ruleSomeFreeVars interesting (Rule _ tpl_vars tpl_args rhs)
+ = rule_fvs interesting emptyVarSet
+ where
+ rule_fvs = addBndrs tpl_vars $
+ foldr (union . expr_fvs) (expr_fvs rhs) tpl_args
+
+ruleSomeLhsFreeVars :: InterestingVarFun -> CoreRule -> IdOrTyVarSet
+ruleSomeLhsFreeVars fn (Rule _ tpl_vars tpl_args rhs)
+ = foldl delVarSet (exprsSomeFreeVars fn tpl_args) tpl_vars
+\end{code}
+
+
+%************************************************************************
+%* *
+\section[freevars-everywhere]{Attaching free variables to every sub-expression}
%* *
%************************************************************************
projects / ghc-hetmet.git / blobdiff