%
+% (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_GHC -w #-}
+-- 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/WorkingConventions#Warnings
+-- for details
+
module CoreFVs (
exprFreeVars, -- CoreExpr -> VarSet -- Find all locally-defined free Ids or tyvars
exprsFreeVars, -- [CoreExpr] -> VarSet
exprSomeFreeVars, exprsSomeFreeVars,
exprFreeNames, exprsFreeNames,
- idRuleVars, idFreeVars, idFreeTyVars,
- ruleRhsFreeVars, rulesRhsFreeVars,
+ idRuleVars, idFreeVars, varTypeTyVars,
+ ruleRhsFreeVars, rulesFreeVars,
ruleLhsFreeNames, ruleLhsFreeIds,
CoreExprWithFVs, -- = AnnExpr Id VarSet
#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}
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
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 (Lam v e) = go e `delFromNameSet` idName v
go (Note n e) = go e
go (Cast e co) = go e `unionNameSets` tyClsNamesOfType co
go (Let (NonRec b r) e) = go e `unionNameSets` go r
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
+ruleFreeVars :: CoreRule -> VarSet -- All free variables, both left and right
+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
+
+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
= 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.
%************************************************************************
%* *
-- 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
+idFreeVars :: Id -> VarSet
+idFreeVars id = ASSERT( isId id) idRuleVars id `unionVarSet` varTypeTyVars id
idRuleVars ::Id -> VarSet
idRuleVars id = ASSERT( isId id) specInfoFreeVars (idSpecialisation id)
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` idRuleVars 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 . idRuleVars) 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
projects / ghc-hetmet.git / blobdiff