X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FcoreSyn%2FCoreFVs.lhs;h=1e8c9e7b0b226d63bee9664a25803d8f6175ff53;hp=752dcf08f618c4baaa96f269d09b1eb5094aca42;hb=c86161c5cf11de77e911fcb9e1e2bd1f8bd80b42;hpb=ad94d40948668032189ad22a0ad741ac1f645f50 diff --git a/compiler/coreSyn/CoreFVs.lhs b/compiler/coreSyn/CoreFVs.lhs index 752dcf0..1e8c9e7 100644 --- a/compiler/coreSyn/CoreFVs.lhs +++ b/compiler/coreSyn/CoreFVs.lhs @@ -5,25 +5,34 @@ Taken quite directly from the Peyton Jones/Lester paper. \begin{code} -{-# OPTIONS -w #-} +{-# 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/CodingStyle#Warnings +-- 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 ( + -- * 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, varTypeTyVars, + -- * 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 @@ -61,29 +70,39 @@ So far as type variables are concerned, it only finds tyvars that are 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 +-- | Find all locally defined free Ids in a binding group bindFreeVars :: CoreBind -> VarSet -bindFreeVars (NonRec b r) = exprFreeVars r +bindFreeVars (NonRec _ r) = exprFreeVars r bindFreeVars (Rec prs) = addBndrs (map fst prs) (foldr (union . rhs_fvs) noVars prs) isLocalVar emptyVarSet -exprSomeFreeVars :: InterestingVarFun -- Says which Vars are interesting +-- | 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} @@ -96,7 +115,7 @@ union :: FV -> FV -> FV 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 @@ -137,6 +156,7 @@ someVars :: VarSet -> FV 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 @@ -160,7 +180,7 @@ expr_fvs :: CoreExpr -> FV 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) @@ -170,7 +190,7 @@ 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) @@ -180,10 +200,13 @@ expr_fvs (Let (Rec pairs) 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} @@ -194,26 +217,26 @@ exprs_fvs exprs = foldr (union . expr_fvs) noVars exprs %* * %************************************************************************ -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 @@ -225,15 +248,17 @@ exprFreeNames e 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` idName v - go (Note n e) = go e + go (Note _ e) = go e go (Cast e co) = go e `unionNameSets` tyClsNamesOfType co - go (Let (NonRec b r) e) = go e `unionNameSets` go r + 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} @@ -243,8 +268,8 @@ exprsFreeNames es = foldr (unionNameSets . exprFreeNames) emptyNameSet es %* * %************************************************************************ - \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 }) @@ -252,17 +277,20 @@ ruleRhsFreeVars (Rule { ru_fn = fn, ru_bndrs = bndrs, ru_rhs = rhs }) where fvs = addBndrs bndrs (expr_fvs rhs) isLocalVar emptyVarSet -ruleFreeVars :: CoreRule -> VarSet -- All free variables, both left and right +-- | 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 @@ -287,16 +315,24 @@ The free variable pass annotates every node in the expression with its 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 @@ -307,8 +343,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. @@ -343,11 +379,53 @@ 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 +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} @@ -359,7 +437,7 @@ idRuleVars id = ASSERT( isId id) specInfoFreeVars (idSpecialisation id) \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 @@ -398,7 +476,9 @@ freeVars (Case scrut bndr ty alts) rhs2 = freeVars rhs freeVars (Let (NonRec binder rhs) body) - = (freeVarsOf rhs2 `unionFVs` body_fvs `unionFVs` idRuleVars binder, + = (freeVarsOf rhs2 + `unionFVs` body_fvs + `unionFVs` bndrRuleAndUnfoldingVars binder, -- Remember any rules; cf rhs_fvs above AnnLet (AnnNonRec binder rhs2) body2) where @@ -414,7 +494,7 @@ 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