X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FcoreSyn%2FCoreFVs.lhs;h=88509f90f32c8a63e2896fb495dc66daa7405851;hp=e2eb3a2e82b2d4de9540870b0743d30a4418ffb0;hb=f8f0e76ad302fda30196ebc9230e5fcbc97be537;hpb=296058a1cafa80dec0b3f998348bce7c65f668b0 diff --git a/compiler/coreSyn/CoreFVs.lhs b/compiler/coreSyn/CoreFVs.lhs index e2eb3a2..88509f9 100644 --- a/compiler/coreSyn/CoreFVs.lhs +++ b/compiler/coreSyn/CoreFVs.lhs @@ -16,18 +16,20 @@ Taken quite directly from the Peyton Jones/Lester paper. module CoreFVs ( -- * 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, -- * Free variables of Rules, Vars and Ids - idRuleVars, idFreeVars, varTypeTyVars, varTypeTcTyVars, + 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 @@ -47,7 +49,9 @@ import Name import VarSet import Var import TcType +import Coercion import Util +import BasicTypes( Activation ) import Outputable \end{code} @@ -71,6 +75,10 @@ but not those that are free in the type of variable occurrence. 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 @@ -172,12 +180,13 @@ addBndrs bndrs fv = foldr addBndr fv bndrs 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 @@ -194,7 +203,8 @@ expr_fvs (Let (Rec pairs) body) --------- 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 --------- @@ -210,7 +220,7 @@ exprs_fvs exprs = foldr (union . expr_fvs) noVars exprs %************************************************************************ \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: -- @@ -218,18 +228,20 @@ exprs_fvs exprs = foldr (union . expr_fvs) noVars exprs -- -- 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) @@ -237,21 +249,22 @@ exprFreeNames e | 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} %************************************************************************ @@ -271,11 +284,26 @@ ruleRhsFreeVars (Rule { ru_fn = fn, ru_bndrs = bndrs, ru_rhs = rhs }) -- | 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 @@ -334,8 +362,8 @@ delBinderFV :: 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. @@ -367,25 +395,49 @@ 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 + | isLocalId var = tyVarsOfType (idType var) + | otherwise = emptyVarSet -- Global Ids and non-coercion TyVars 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 + | isLocalId var = tcTyVarsOfType (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 - -idRuleVars ::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} @@ -436,7 +488,9 @@ freeVars (Case scrut bndr ty alts) 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 @@ -452,19 +506,18 @@ freeVars (Let (Rec binds) body) 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) @@ -472,5 +525,7 @@ freeVars (Note other_note expr) expr2 = freeVars expr freeVars (Type ty) = (tyVarsOfType ty, AnnType ty) + +freeVars (Coercion co) = (tyCoVarsOfCo co, AnnCoercion co) \end{code}