exprsFreeVars, -- [CoreExpr] -> VarSet
exprSomeFreeVars, exprsSomeFreeVars,
+ exprFreeNames, exprsFreeNames,
- idRuleVars, idFreeVars, idFreeTyVars,
- ruleSomeFreeVars, ruleSomeLhsFreeVars, ruleRhsFreeVars,
+ idRuleVars, idFreeVars, idFreeTyVars,
+ ruleRhsFreeVars, rulesRhsFreeVars,
+ ruleLhsFreeNames, ruleLhsFreeIds,
CoreExprWithFVs, -- = AnnExpr Id VarSet
CoreBindWithFVs, -- = AnnBind Id VarSet
#include "HsVersions.h"
import CoreSyn
-import Id ( Id, idType, isLocalId, hasNoBinding, idSpecialisation )
+import Id ( Id, idType, idSpecialisation, isLocalId )
+import IdInfo ( specInfoFreeVars )
+import NameSet
+import UniqFM ( delFromUFM )
+import Name ( isExternalName )
import VarSet
-import Var ( Var, isId, isLocalVar )
+import Var ( Var, isId, isLocalVar, varName )
import Type ( tyVarsOfType )
+import TcType ( tyClsNamesOfType )
import Util ( mapAndUnzip )
import Outputable
\end{code}
\begin{code}
type FV = InterestingVarFun
- -> VarSet -- In scope
- -> VarSet -- Free vars
+ -> VarSet -- In scope
+ -> VarSet -- Free vars
union :: FV -> FV -> FV
union fv1 fv2 fv_cand in_scope = fv1 fv_cand in_scope `unionVarSet` fv2 fv_cand in_scope
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)
+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)
= addBndrs bndrs (foldr (union . expr_fvs) (expr_fvs body) rhss)
where
(bndrs,rhss) = unzip pairs
+
+---------
+exprs_fvs exprs = foldr (union . expr_fvs) noVars exprs
\end{code}
+%************************************************************************
+%* *
+\section{Free names}
+%* *
+%************************************************************************
+
+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}
-rulesSomeFreeVars :: InterestingVarFun -> CoreRules -> VarSet
-rulesSomeFreeVars interesting (Rules rules _)
- = foldr (unionVarSet . ruleSomeFreeVars interesting) emptyVarSet rules
+ruleLhsFreeNames :: CoreRule -> NameSet
+ruleLhsFreeNames (BuiltinRule { ru_fn = fn }) = unitNameSet fn
+ruleLhsFreeNames (Rule { ru_fn = fn, ru_bndrs = tpl_vars, ru_args = tpl_args })
+ = addOneToNameSet (exprsFreeNames tpl_args) fn
+
+exprFreeNames :: CoreExpr -> NameSet
+-- Find the free *external* names of an expression
+exprFreeNames e
+ = go e
+ where
+ go (Var v)
+ | isExternalName n = unitNameSet n
+ | otherwise = emptyNameSet
+ where n = varName 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 (Let (Rec prs) e) = exprsFreeNames (map snd prs) `unionNameSets` go e
+ go (Case e b ty as) = go e `unionNameSets` tyClsNamesOfType ty
+ `unionNameSets` unionManyNameSets (map go_alt as)
+
+ go_alt (_,_,r) = go r
+
+exprsFreeNames es = foldr (unionNameSets . exprFreeNames) emptyNameSet es
+\end{code}
+%************************************************************************
+%* *
+\section[freevars-everywhere]{Attaching free variables to every sub-expression}
+%* *
+%************************************************************************
+
+
+\begin{code}
ruleRhsFreeVars :: CoreRule -> VarSet
-ruleRhsFreeVars (BuiltinRule _) = noFVs
-ruleRhsFreeVars (Rule str tpl_vars tpl_args rhs)
- = rule_fvs isLocalVar emptyVarSet
+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)
where
- rule_fvs = addBndrs tpl_vars (expr_fvs rhs)
+ fvs = addBndrs bndrs (expr_fvs rhs) isLocalVar emptyVarSet
-ruleSomeFreeVars :: InterestingVarFun -> CoreRule -> VarSet
-ruleSomeFreeVars interesting (BuiltinRule _) = noFVs
-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
+rulesRhsFreeVars :: [CoreRule] -> VarSet
+rulesRhsFreeVars rules
+ = foldr (unionVarSet . ruleRhsFreeVars) emptyVarSet rules
-ruleSomeLhsFreeVars :: InterestingVarFun -> CoreRule -> VarSet
-ruleSomeLhsFreeVars fn (BuiltinRule _) = noFVs
-ruleSomeLhsFreeVars fn (Rule _ tpl_vars tpl_args rhs)
- = foldl delVarSet (exprsSomeFreeVars fn tpl_args) tpl_vars
+ruleLhsFreeIds :: CoreRule -> VarSet
+-- This finds all locally-defined free Ids on the LHS of the rule
+ruleLhsFreeIds (BuiltinRule {}) = noFVs
+ruleLhsFreeIds (Rule { ru_bndrs = bndrs, ru_args = args })
+ = addBndrs bndrs (exprs_fvs args) isLocalId emptyVarSet
\end{code}
-- 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
+-- | isLocalId id = tyVarsOfType (idType id)
+-- | otherwise = emptyVarSet
idRuleVars ::Id -> VarSet
-idRuleVars id = ASSERT( isId id) rulesRhsFreeVars (idSpecialisation id)
+idRuleVars id = ASSERT( isId id) specInfoFreeVars (idSpecialisation id)
\end{code}
fun2 = freeVars fun
arg2 = freeVars arg
-freeVars (Case scrut bndr alts)
- = ((bndr `delBinderFV` alts_fvs) `unionFVs` freeVarsOf scrut2,
- AnnCase scrut2 bndr alts2)
+freeVars (Case scrut bndr ty alts)
+-- gaw 2004
+ = ((bndr `delBinderFV` alts_fvs) `unionFVs` freeVarsOf scrut2 `unionFVs` tyVarsOfType ty,
+ AnnCase scrut2 bndr ty alts2)
where
scrut2 = freeVars scrut
projects / ghc-hetmet.git / blobdiff