-- * Selective free variables of expressions
InterestingVarFun,
exprSomeFreeVars, exprsSomeFreeVars,
- exprFreeNames, exprsFreeNames,
-- * Free variables of Rules, Vars and Ids
- idRuleVars, idRuleRhsVars, idFreeVars, idInlineFreeVars,
- varTypeTyVars,
+ varTypeTyVars, varTypeTcTyVars,
+ idUnfoldingVars, idFreeVars, idRuleAndUnfoldingVars,
+ idRuleVars, idRuleRhsVars, stableUnfoldingVars,
ruleRhsFreeVars, rulesFreeVars,
- ruleLhsFreeNames, ruleLhsFreeIds,
+ ruleLhsOrphNames, ruleLhsFreeIds,
-- * Core syntax tree annotation with free variables
CoreExprWithFVs, -- = AnnExpr Id VarSet
import VarSet
import Var
import TcType
+import Coercion
import Util
+import BasicTypes( Activation )
import Outputable
\end{code}
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
---------
rhs_fvs :: (Id,CoreExpr) -> FV
-rhs_fvs (bndr, rhs) = expr_fvs rhs `union` someVars (bndrRuleVars bndr)
+rhs_fvs (bndr, rhs) = expr_fvs rhs `union`
+ someVars (bndrRuleAndUnfoldingVars bndr)
-- Treat any RULES as extra RHSs of the binding
---------
%************************************************************************
\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:
--
--
-- 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)
| 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}
%************************************************************************
-- | 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
+idRuleRhsVars :: (Activation -> Bool) -> Id -> VarSet
+-- Just the variables free on the *rhs* of a rule
+idRuleRhsVars is_active id
+ = foldr (unionVarSet . get_fvs) emptyVarSet (idCoreRules id)
+ where
+ 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]
+ where
+ fvs = addBndrs bndrs (expr_fvs rhs) isLocalVar emptyVarSet
+ get_fvs _ = noFVs
+
-- | Those variables free in the right hand side of several rules
rulesFreeVars :: [CoreRule] -> VarSet
rulesFreeVars rules = foldr (unionVarSet . ruleFreeVars) emptyVarSet rules
-- (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.
-- 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
-
-idFreeVars :: Id -> VarSet
-idFreeVars id = ASSERT( isId id) idRuleVars id `unionVarSet` varTypeTyVars id
-
-bndrRuleVars ::Var -> VarSet
-bndrRuleVars v | isTyVar v = emptyVarSet
- | otherwise = idRuleVars v
+ | isLocalId var = tyVarsOfType (idType var)
+ | otherwise = emptyVarSet -- Global Ids and non-coercion TyVars
-idRuleVars ::Id -> VarSet
-idRuleVars id = ASSERT( isId id)
- specInfoFreeVars (idSpecialisation id) `unionVarSet`
- idInlineFreeVars id -- And the variables in an INLINE rule
+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 = tcTyVarsOfType (idType var)
+ | otherwise = emptyVarSet -- Global Ids and non-coercion TyVars
-idRuleRhsVars :: Id -> VarSet
--- Just the variables free on the *rhs* of a rule
--- See Note [Choosing loop breakers] in Simplify.lhs
-idRuleRhsVars id = foldr (unionVarSet . ruleRhsFreeVars)
- (idInlineFreeVars id)
- (idCoreRules id)
-
-idInlineFreeVars :: Id -> VarSet
--- Produce free vars for an InlineRule, BUT NOT for an ordinary unfolding
--- An InlineRule behaves *very like* a RULE, and that is what we are after here
-idInlineFreeVars id
- = case idUnfolding id of
- InlineRule { uf_tmpl = tmpl } -> exprFreeVars tmpl
- _ -> emptyVarSet
+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)
+
+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 = stableUnfoldingVars (realIdUnfolding id)
+
+stableUnfoldingVars :: Unfolding -> VarSet
+stableUnfoldingVars (CoreUnfolding { uf_tmpl = rhs, uf_src = src })
+ | isStableSource src = exprFreeVars rhs
+stableUnfoldingVars (DFunUnfolding _ _ args) = exprsFreeVars (dfunArgExprs args)
+stableUnfoldingVars _ = emptyVarSet
\end{code}
rhs2 = freeVars rhs
freeVars (Let (NonRec binder rhs) body)
- = (freeVarsOf rhs2 `unionFVs` body_fvs `unionFVs` bndrRuleVars binder,
+ = (freeVarsOf rhs2
+ `unionFVs` body_fvs
+ `unionFVs` bndrRuleAndUnfoldingVars binder,
-- Remember any rules; cf rhs_fvs above
AnnLet (AnnNonRec binder rhs2) body2)
where
rhss2 = map freeVars rhss
rhs_body_fvs = foldr (unionFVs . freeVarsOf) body_fvs rhss2
- all_fvs = foldr (unionFVs . idRuleVars) rhs_body_fvs binders
+ 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 (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)
expr2 = freeVars expr
freeVars (Type ty) = (tyVarsOfType ty, AnnType ty)
+
+freeVars (Coercion co) = (tyCoVarsOfCo co, AnnCoercion co)
\end{code}