%
+% (c) The University of Glasgow 2006
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
Taken quite directly from the Peyton Jones/Lester paper.
\begin{code}
+{-# OPTIONS -fno-warn-incomplete-patterns #-}
+-- The above warning supression flag is a temporary kludge.
+-- While working on this module you are encouraged to remove it and fix
+-- any warnings in the module. See
+-- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
+-- for details
+
+-- | A module concerned with finding the free variables of an expression.
module CoreFVs (
- exprFreeVars, -- CoreExpr -> VarSet -- Find all locally-defined free Ids or tyvars
+ -- * 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
+ -- * Selective free variables of expressions
+ InterestingVarFun,
exprSomeFreeVars, exprsSomeFreeVars,
exprFreeNames, exprsFreeNames,
- idRuleVars, idFreeVars, idFreeTyVars,
- ruleRhsFreeVars, rulesRhsFreeVars,
+ -- * Free variables of Rules, Vars and Ids
+ varTypeTyVars, varTypeTcTyVars,
+ idUnfoldingVars, idFreeVars, idRuleAndUnfoldingVars,
+ idRuleVars, idRuleRhsVars,
+ ruleRhsFreeVars, rulesFreeVars,
ruleLhsFreeNames, ruleLhsFreeIds,
+ -- * Core syntax tree annotation with free variables
CoreExprWithFVs, -- = AnnExpr Id VarSet
CoreBindWithFVs, -- = AnnBind Id VarSet
freeVars, -- CoreExpr -> CoreExprWithFVs
#include "HsVersions.h"
import CoreSyn
-import Id ( Id, idType, idSpecialisation, isLocalId )
-import IdInfo ( specInfoFreeVars )
+import Id
+import IdInfo
import NameSet
-import UniqFM ( delFromUFM )
-import Name ( isExternalName )
+import UniqFM
+import Name
import VarSet
-import Var ( Var, isId, isLocalVar, varName )
-import Type ( tyVarsOfType )
-import TcType ( tyClsNamesOfType )
-import Util ( mapAndUnzip )
+import Var
+import TcType
+import Util
import Outputable
\end{code}
but not those that are free in the type of variable occurrence.
\begin{code}
-exprFreeVars :: CoreExpr -> VarSet -- Find all locally-defined free Ids or tyvars
+-- | Find all locally-defined free Ids or type variables in an expression
+exprFreeVars :: CoreExpr -> VarSet
exprFreeVars = exprSomeFreeVars isLocalVar
+-- | 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 or type variables in several expressions
exprsFreeVars :: [CoreExpr] -> VarSet
exprsFreeVars = foldr (unionVarSet . exprFreeVars) emptyVarSet
-exprSomeFreeVars :: InterestingVarFun -- Says which Vars are interesting
+-- | Find all locally defined free Ids in a binding group
+bindFreeVars :: CoreBind -> VarSet
+bindFreeVars (NonRec _ r) = exprFreeVars r
+bindFreeVars (Rec prs) = addBndrs (map fst prs)
+ (foldr (union . rhs_fvs) noVars prs)
+ isLocalVar emptyVarSet
+
+-- | Finds free variables in an expression selected by a predicate
+exprSomeFreeVars :: InterestingVarFun -- ^ Says which 'Var's are interesting
-> CoreExpr
-> VarSet
exprSomeFreeVars fv_cand e = expr_fvs e fv_cand emptyVarSet
-exprsSomeFreeVars :: InterestingVarFun -- Says which Vars are interesting
+-- | Finds free variables in several expressions selected by a predicate
+exprsSomeFreeVars :: InterestingVarFun -- Says which 'Var's are interesting
-> [CoreExpr]
-> VarSet
exprsSomeFreeVars fv_cand = foldr (unionVarSet . exprSomeFreeVars fv_cand) emptyVarSet
-type InterestingVarFun = Var -> Bool -- True <=> interesting
+-- | Predicate on possible free variables: returns @True@ iff the variable is interesting
+type InterestingVarFun = Var -> Bool
\end{code}
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
+noVars _ _ = emptyVarSet
-- Comment about obselete code
-- We used to gather the free variables the RULES at a variable occurrence
someVars vars fv_cand in_scope
= filterVarSet (keep_it fv_cand in_scope) vars
+keep_it :: InterestingVarFun -> VarSet -> Var -> Bool
keep_it fv_cand in_scope var
| var `elemVarSet` in_scope = False
| fv_cand var = True
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)
+ = someVars (varTypeTyVars bndr) fv_cand in_scope
+ -- Include type varibles in the binder's type
+ -- (not just Ids; coercion variables too!)
+ `unionVarSet` fv fv_cand (in_scope `extendVarSet` bndr)
addBndrs :: [CoreBndr] -> FV -> FV
addBndrs bndrs fv = foldr addBndr fv bndrs
expr_fvs (Type ty) = someVars (tyVarsOfType ty)
expr_fvs (Var var) = oneVar var
-expr_fvs (Lit lit) = noVars
+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 (Case scrut bndr ty alts)
= expr_fvs scrut `union` someVars (tyVarsOfType ty) `union` addBndr bndr
(foldr (union . alt_fvs) noVars alts)
where
- alt_fvs (con, bndrs, rhs) = addBndrs bndrs (expr_fvs rhs)
+ 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)
(foldr (union . rhs_fvs) (expr_fvs body) pairs)
---------
-rhs_fvs (bndr, rhs) = expr_fvs rhs `union` someVars (idRuleVars bndr)
+rhs_fvs :: (Id,CoreExpr) -> FV
+rhs_fvs (bndr, rhs) = expr_fvs rhs `union`
+ someVars (bndrRuleAndUnfoldingVars bndr)
-- Treat any RULES as extra RHSs of the binding
---------
+exprs_fvs :: [CoreExpr] -> FV
exprs_fvs exprs = foldr (union . expr_fvs) noVars exprs
\end{code}
%* *
%************************************************************************
-exprFreeNames finds the free *external* *names* of an expression, notably
-including the names of type constructors (which of course do not show
-up in exprFreeVars). Similarly ruleLhsFreeNames. The latter 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
- fromIntegral T = fromIntegral_T
-is an orphan. Of course it isn't, an declaring it an orphan would
-make the whole module an orphan module, which is bad.
-
-There's no need to delete local binders, because they will all
-be *internal* names.
-
\begin{code}
+-- | Similar to 'exprFreeNames'. However, this 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:
+--
+-- > fromIntegral T = fromIntegral_T
+--
+-- 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_bndrs = tpl_vars, ru_args = tpl_args })
+ruleLhsFreeNames (Rule { ru_fn = fn, ru_args = tpl_args })
= addOneToNameSet (exprsFreeNames tpl_args) fn
+-- | 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
--- Find the free *external* names of an expression
+-- There's no need to delete local binders, because they will all
+-- be /internal/ names.
exprFreeNames e
= go e
where
go (Var v)
| isExternalName n = unitNameSet n
| otherwise = emptyNameSet
- where n = varName v
+ where n = idName v
go (Lit _) = emptyNameSet
go (Type ty) = tyClsNamesOfType ty -- Don't need free tyvars
go (App e1 e2) = go e1 `unionNameSets` go e2
- go (Lam v e) = go e `delFromNameSet` varName v
- go (Note n e) = go e
- go (Let (NonRec b r) e) = go e `unionNameSets` go r
+ go (Lam v e) = go e `delFromNameSet` idName v
+ go (Note _ e) = go e
+ go (Cast e co) = go e `unionNameSets` tyClsNamesOfType 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 b ty as) = go e `unionNameSets` tyClsNamesOfType ty
+ go (Case e _ ty as) = go e `unionNameSets` tyClsNamesOfType 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
\end{code}
%* *
%************************************************************************
-
\begin{code}
+-- | Those variables free in the right hand side of a rule
ruleRhsFreeVars :: CoreRule -> VarSet
ruleRhsFreeVars (BuiltinRule {}) = noFVs
ruleRhsFreeVars (Rule { ru_fn = fn, ru_bndrs = bndrs, ru_rhs = rhs })
- = delFromUFM fvs fn
- -- Hack alert!
- -- 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)
+ = delFromUFM fvs fn -- Note [Rule free var hack]
where
fvs = addBndrs bndrs (expr_fvs rhs) isLocalVar emptyVarSet
-rulesRhsFreeVars :: [CoreRule] -> VarSet
-rulesRhsFreeVars rules
- = foldr (unionVarSet . ruleRhsFreeVars) emptyVarSet rules
+-- | Those variables free in the both the left right hand sides of a rule
+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]
+ where
+ fvs = addBndrs bndrs (exprs_fvs (rhs:args)) isLocalVar emptyVarSet
+
+-- | Those variables free in the right hand side of several rules
+rulesFreeVars :: [CoreRule] -> VarSet
+rulesFreeVars rules = foldr (unionVarSet . ruleFreeVars) emptyVarSet rules
ruleLhsFreeIds :: CoreRule -> VarSet
--- This finds all locally-defined free Ids on the LHS of the rule
+-- ^ This finds all locally-defined free Ids on the left hand side of a rule
ruleLhsFreeIds (BuiltinRule {}) = noFVs
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)
+
+Also since rule_fn is a Name, not a Var, we have to use the grungy delUFM.
%************************************************************************
%* *
NON-GLOBAL free variables and type variables.
\begin{code}
+-- | Every node in a binding group annotated with its
+-- (non-global) free variables, both Ids and TyVars
type CoreBindWithFVs = AnnBind Id VarSet
+-- | Every node in an expression annotated with its
+-- (non-global) free variables, both Ids and TyVars
type CoreExprWithFVs = AnnExpr Id VarSet
- -- Every node annotated with its free variables,
- -- both Ids and TyVars
freeVarsOf :: CoreExprWithFVs -> IdSet
+-- ^ Inverse function to 'freeVars'
freeVarsOf (free_vars, _) = free_vars
+noFVs :: VarSet
noFVs = emptyVarSet
+
+aFreeVar :: Var -> VarSet
aFreeVar = unitVarSet
+
+unionFVs :: VarSet -> VarSet -> VarSet
unionFVs = unionVarSet
delBindersFV :: [Var] -> VarSet -> VarSet
-- (b `delBinderFV` s) removes the binder b from the free variable set s,
-- but *adds* to s
--- (a) the free variables of b's type
--- (b) the idSpecVars of b
+--
+-- 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.
-- where
-- bottom = bottom -- Never evaluated
-delBinderFV b s | isId b = (s `delVarSet` b) `unionFVs` idFreeVars b
- | otherwise = s `delVarSet` b
+delBinderFV b s = (s `delVarSet` b) `unionFVs` varTypeTyVars b
+ -- Include coercion variables too!
-idFreeVars :: Id -> VarSet
-idFreeVars id = ASSERT( isId id) idRuleVars id `unionVarSet` idFreeTyVars id
+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
-idFreeTyVars :: Id -> TyVarSet
--- Only local Ids conjured up locally, can have free type variables.
--- (During type checking top-level Ids can have free tyvars)
-idFreeTyVars id = tyVarsOfType (idType id)
--- | isLocalId id = tyVarsOfType (idType id)
--- | otherwise = emptyVarSet
+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
-idRuleVars ::Id -> VarSet
+idFreeVars :: Id -> VarSet
+-- Type variables, rule variables, and inline variables
+idFreeVars id = ASSERT( isId id)
+ varTypeTyVars id `unionVarSet`
+ idRuleAndUnfoldingVars 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 | isTyVar v = emptyVarSet
+ | otherwise = idRuleAndUnfoldingVars v
+
+idRuleAndUnfoldingVars :: Id -> VarSet
+idRuleAndUnfoldingVars id = ASSERT( isId id)
+ idRuleVars id `unionVarSet`
+ idUnfoldingVars id
+
+idRuleVars ::Id -> VarSet -- Does *not* include CoreUnfolding vars
idRuleVars id = ASSERT( isId id) specInfoFreeVars (idSpecialisation id)
+
+idRuleRhsVars :: Id -> VarSet -- Does *not* include the CoreUnfolding vars
+-- Just the variables free on the *rhs* of a rule
+-- See Note [Choosing loop breakers] in Simplify.lhs
+idRuleRhsVars id = foldr (unionVarSet . ruleRhsFreeVars)
+ emptyVarSet
+ (idCoreRules 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
+ = case realIdUnfolding id of
+ CoreUnfolding { uf_tmpl = rhs, uf_src = src }
+ | isInlineRuleSource src
+ -> exprFreeVars rhs
+ DFunUnfolding _ _ args -> exprsFreeVars args
+ _ -> emptyVarSet
\end{code}
\begin{code}
freeVars :: CoreExpr -> CoreExprWithFVs
-
+-- ^ Annotate a 'CoreExpr' with its (non-global) free type and value variables at every tree node
freeVars (Var v)
= (fvs, AnnVar v)
where
arg2 = freeVars arg
freeVars (Case scrut bndr ty alts)
--- gaw 2004
= ((bndr `delBinderFV` alts_fvs) `unionFVs` freeVarsOf scrut2 `unionFVs` tyVarsOfType ty,
AnnCase scrut2 bndr ty alts2)
where
rhs2 = freeVars rhs
freeVars (Let (NonRec binder rhs) body)
- = (freeVarsOf rhs2 `unionFVs` body_fvs,
+ = (freeVarsOf rhs2
+ `unionFVs` body_fvs
+ `unionFVs` bndrRuleAndUnfoldingVars binder,
+ -- Remember any rules; cf rhs_fvs above
AnnLet (AnnNonRec binder rhs2) body2)
where
rhs2 = freeVars rhs
body_fvs = binder `delBinderFV` freeVarsOf body2
freeVars (Let (Rec binds) body)
- = (foldl delVarSet group_fvs binders,
- -- The "delBinderFV" part may have added one of the binders
- -- via the idSpecVars part, so we must delete it again
+ = (delBindersFV binders all_fvs,
AnnLet (AnnRec (binders `zip` rhss2)) body2)
where
(binders, rhss) = unzip binds
rhss2 = map freeVars rhss
- all_fvs = foldr (unionFVs . fst) body_fvs rhss2
- group_fvs = delBindersFV binders all_fvs
+ rhs_body_fvs = foldr (unionFVs . freeVarsOf) body_fvs rhss2
+ all_fvs = foldr (unionFVs . idRuleAndUnfoldingVars) rhs_body_fvs binders
+ -- The "delBinderFV" happens after adding the idSpecVars,
+ -- since the latter may add some of the binders as fvs
body2 = freeVars body
body_fvs = freeVarsOf body2
-freeVars (Note (Coerce to_ty from_ty) expr)
- = (freeVarsOf expr2 `unionFVs` tfvs1 `unionFVs` tfvs2,
- AnnNote (Coerce to_ty from_ty) expr2)
+
+freeVars (Cast expr co)
+ = (freeVarsOf expr2 `unionFVs` cfvs, AnnCast expr2 co)
where
- expr2 = freeVars expr
- tfvs1 = tyVarsOfType from_ty
- tfvs2 = tyVarsOfType to_ty
+ expr2 = freeVars expr
+ cfvs = tyVarsOfType co
freeVars (Note other_note expr)
= (freeVarsOf expr2, AnnNote other_note expr2)