ghc/compiler/coreSyn/CoreFVs.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
   3 %
   4 Taken quite directly from the Peyton Jones/Lester paper.
   5
   6 \begin{code}
   7 module CoreFVs (
   8         exprFreeVars, exprsFreeVars,
   9         exprSomeFreeVars, exprsSomeFreeVars,
  10         idRuleVars, idFreeVars,
  11         ruleSomeFreeVars, ruleSomeLhsFreeVars, ruleRhsFreeVars,
  12
  13         mustHaveLocalBinding,
  14
  15         CoreExprWithFVs, CoreBindWithFVs, freeVars, freeVarsOf,
  16     ) where
  17
  18 #include "HsVersions.h"
  19
  20 import CoreSyn
  21 import Id               ( Id, idFreeTyVars, hasNoBinding, idSpecialisation )
  22 import VarSet
  23 import Var              ( Var, isId )
  24 import Type             ( tyVarsOfType )
  25 import Util             ( mapAndUnzip )
  26 import Outputable
  27 \end{code}
  28
  29
  30 %************************************************************************
  31 %*                                                                      *
  32 \section{Finding the free variables of an expression}
  33 %*                                                                      *
  34 %************************************************************************
  35
  36 This function simply finds the free variables of an expression.
  37 So far as type variables are concerned, it only finds tyvars that are
  38
  39         * free in type arguments,
  40         * free in the type of a binder,
  41
  42 but not those that are free in the type of variable occurrence.
  43
  44 \begin{code}
  45 exprFreeVars :: CoreExpr -> VarSet      -- Find all locally-defined free Ids or tyvars
  46 exprFreeVars = exprSomeFreeVars isLocalVar
  47
  48 exprsFreeVars :: [CoreExpr] -> VarSet
  49 exprsFreeVars = foldr (unionVarSet . exprFreeVars) emptyVarSet
  50
  51 exprSomeFreeVars :: InterestingVarFun   -- Says which Vars are interesting
  52                  -> CoreExpr
  53                  -> VarSet
  54 exprSomeFreeVars fv_cand e = expr_fvs e fv_cand emptyVarSet
  55
  56 exprsSomeFreeVars :: InterestingVarFun  -- Says which Vars are interesting
  57                   -> [CoreExpr]
  58                   -> VarSet
  59 exprsSomeFreeVars fv_cand = foldr (unionVarSet . exprSomeFreeVars fv_cand) emptyVarSet
  60
  61 type InterestingVarFun = Var -> Bool    -- True <=> interesting
  62 \end{code}
  63
  64
  65 \begin{code}
  66 type FV = InterestingVarFun
  67           -> VarSet             -- In scope
  68           -> VarSet             -- Free vars
  69
  70 union :: FV -> FV -> FV
  71 union fv1 fv2 fv_cand in_scope = fv1 fv_cand in_scope `unionVarSet` fv2 fv_cand in_scope
  72
  73 noVars :: FV
  74 noVars fv_cand in_scope = emptyVarSet
  75
  76 -- At a variable occurrence, add in any free variables of its rule rhss
  77 -- Curiously, we gather the Id's free *type* variables from its binding
  78 -- site, but its free *rule-rhs* variables from its usage sites.  This
  79 -- is a little weird.  The reason is that the former is more efficient,
  80 -- but the latter is more fine grained, and a makes a difference when
  81 -- a variable mentions itself one of its own rule RHSs
  82 oneVar :: Id -> FV
  83 oneVar var fv_cand in_scope
  84   = ASSERT( isId var )
  85     foldVarSet add_rule_var var_itself_set (idRuleVars var)
  86   where
  87     var_itself_set | keep_it fv_cand in_scope var = unitVarSet var
  88                    | otherwise                = emptyVarSet
  89     add_rule_var var set | keep_it fv_cand in_scope var = extendVarSet set var
  90                          | otherwise                    = set
  91
  92 someVars :: VarSet -> FV
  93 someVars vars fv_cand in_scope
  94   = filterVarSet (keep_it fv_cand in_scope) vars
  95
  96 keep_it fv_cand in_scope var
  97   | var `elemVarSet` in_scope = False
  98   | fv_cand var               = True
  99   | otherwise                 = False
 100
 101
 102 addBndr :: CoreBndr -> FV -> FV
 103 addBndr bndr fv fv_cand in_scope
 104   | isId bndr = inside_fvs `unionVarSet` someVars (idFreeTyVars bndr) fv_cand in_scope
 105   | otherwise = inside_fvs
 106   where
 107     inside_fvs = fv fv_cand (in_scope `extendVarSet` bndr)
 108
 109 addBndrs :: [CoreBndr] -> FV -> FV
 110 addBndrs bndrs fv = foldr addBndr fv bndrs
 111 \end{code}
 112
 113
 114 \begin{code}
 115 expr_fvs :: CoreExpr -> FV
 116
 117 expr_fvs (Type ty)       = someVars (tyVarsOfType ty)
 118 expr_fvs (Var var)       = oneVar var
 119 expr_fvs (Lit lit)       = noVars
 120 expr_fvs (Note _ expr)   = expr_fvs expr
 121 expr_fvs (App fun arg)   = expr_fvs fun `union` expr_fvs arg
 122 expr_fvs (Lam bndr body) = addBndr bndr (expr_fvs body)
 123
 124 expr_fvs (Case scrut bndr alts)
 125   = expr_fvs scrut `union` addBndr bndr (foldr (union . alt_fvs) noVars alts)
 126   where
 127     alt_fvs (con, bndrs, rhs) = addBndrs bndrs (expr_fvs rhs)
 128
 129 expr_fvs (Let (NonRec bndr rhs) body)
 130   = expr_fvs rhs `union` addBndr bndr (expr_fvs body)
 131
 132 expr_fvs (Let (Rec pairs) body)
 133   = addBndrs bndrs (foldr (union . expr_fvs) (expr_fvs body) rhss)
 134   where
 135     (bndrs,rhss) = unzip pairs
 136 \end{code}
 137
 138
 139
 140 \begin{code}
 141 idRuleVars ::Id -> VarSet
 142 idRuleVars id = ASSERT( isId id) rulesRhsFreeVars (idSpecialisation id)
 143
 144 idFreeVars :: Id -> VarSet
 145 idFreeVars id = ASSERT( isId id) idRuleVars id `unionVarSet` idFreeTyVars id
 146
 147 rulesSomeFreeVars :: InterestingVarFun -> CoreRules -> VarSet
 148 rulesSomeFreeVars interesting (Rules rules _)
 149   = foldr (unionVarSet . ruleSomeFreeVars interesting) emptyVarSet rules
 150
 151 ruleRhsFreeVars :: CoreRule -> VarSet
 152 ruleRhsFreeVars (BuiltinRule _) = noFVs
 153 ruleRhsFreeVars (Rule str tpl_vars tpl_args rhs)
 154   = rule_fvs isLocalVar emptyVarSet
 155   where
 156     rule_fvs = addBndrs tpl_vars (expr_fvs rhs)
 157
 158 ruleSomeFreeVars :: InterestingVarFun -> CoreRule -> VarSet
 159 ruleSomeFreeVars interesting (BuiltinRule _) = noFVs
 160 ruleSomeFreeVars interesting (Rule _ tpl_vars tpl_args rhs)
 161   = rule_fvs interesting emptyVarSet
 162   where
 163     rule_fvs = addBndrs tpl_vars $
 164                foldr (union . expr_fvs) (expr_fvs rhs) tpl_args
 165
 166 ruleSomeLhsFreeVars :: InterestingVarFun -> CoreRule -> VarSet
 167 ruleSomeLhsFreeVars fn (BuiltinRule _) = noFVs
 168 ruleSomeLhsFreeVars fn (Rule _ tpl_vars tpl_args rhs)
 169   = foldl delVarSet (exprsSomeFreeVars fn tpl_args) tpl_vars
 170 \end{code}
 171
 172
 173 %************************************************************************
 174 %*                                                                      *
 175 \section[freevars-everywhere]{Attaching free variables to every sub-expression}
 176 %*                                                                      *
 177 %************************************************************************
 178
 179 The free variable pass annotates every node in the expression with its
 180 NON-GLOBAL free variables and type variables.
 181
 182 \begin{code}
 183 type CoreBindWithFVs = AnnBind Id VarSet
 184 type CoreExprWithFVs = AnnExpr Id VarSet
 185         -- Every node annotated with its free variables,
 186         -- both Ids and TyVars
 187
 188 freeVarsOf :: CoreExprWithFVs -> IdSet
 189 freeVarsOf (free_vars, _) = free_vars
 190
 191 noFVs    = emptyVarSet
 192 aFreeVar = unitVarSet
 193 unionFVs = unionVarSet
 194
 195 filters :: Var -> VarSet -> VarSet
 196
 197 -- (b `filters` s) removes the binder b from the free variable set s,
 198 -- but *adds* to s
 199 --      (a) the free variables of b's type
 200 --      (b) the idSpecVars of b
 201 --
 202 -- This is really important for some lambdas:
 203 --      In (\x::a -> x) the only mention of "a" is in the binder.
 204 --
 205 -- Also in
 206 --      let x::a = b in ...
 207 -- we should really note that "a" is free in this expression.
 208 -- It'll be pinned inside the /\a by the binding for b, but
 209 -- it seems cleaner to make sure that a is in the free-var set
 210 -- when it is mentioned.
 211 --
 212 -- This also shows up in recursive bindings.  Consider:
 213 --      /\a -> letrec x::a = x in E
 214 -- Now, there are no explicit free type variables in the RHS of x,
 215 -- but nevertheless "a" is free in its definition.  So we add in
 216 -- the free tyvars of the types of the binders, and include these in the
 217 -- free vars of the group, attached to the top level of each RHS.
 218 --
 219 -- This actually happened in the defn of errorIO in IOBase.lhs:
 220 --      errorIO (ST io) = case (errorIO# io) of
 221 --                          _ -> bottom
 222 --                        where
 223 --                          bottom = bottom -- Never evaluated
 224
 225 filters b s | isId b    = (s `delVarSet` b) `unionFVs` idFreeVars b
 226             | otherwise = s `delVarSet` b
 227 \end{code}
 228
 229
 230 %************************************************************************
 231 %*                                                                      *
 232 \subsection{Free variables (and types)}
 233 %*                                                                      *
 234 %************************************************************************
 235
 236 \begin{code}
 237 freeVars :: CoreExpr -> CoreExprWithFVs
 238
 239 freeVars (Var v)
 240   = (fvs, AnnVar v)
 241   where
 242         -- ToDo: insert motivating example for why we *need*
 243         -- to include the idSpecVars in the FV list.
 244         --      Actually [June 98] I don't think it's necessary
 245         -- fvs = fvs_v `unionVarSet` idSpecVars v
 246
 247     fvs | isLocalVar v = aFreeVar v
 248         | otherwise    = noFVs
 249
 250 freeVars (Lit lit) = (noFVs, AnnLit lit)
 251 freeVars (Lam b body)
 252   = (b `filters` freeVarsOf body', AnnLam b body')
 253   where
 254     body' = freeVars body
 255
 256 freeVars (App fun arg)
 257   = (freeVarsOf fun2 `unionFVs` freeVarsOf arg2, AnnApp fun2 arg2)
 258   where
 259     fun2 = freeVars fun
 260     arg2 = freeVars arg
 261
 262 freeVars (Case scrut bndr alts)
 263   = ((bndr `filters` alts_fvs) `unionFVs` freeVarsOf scrut2,
 264      AnnCase scrut2 bndr alts2)
 265   where
 266     scrut2 = freeVars scrut
 267
 268     (alts_fvs_s, alts2) = mapAndUnzip fv_alt alts
 269     alts_fvs            = foldr1 unionFVs alts_fvs_s
 270
 271     fv_alt (con,args,rhs) = (foldr filters (freeVarsOf rhs2) args,
 272                              (con, args, rhs2))
 273                           where
 274                              rhs2 = freeVars rhs
 275
 276 freeVars (Let (NonRec binder rhs) body)
 277   = (freeVarsOf rhs2 `unionFVs` body_fvs,
 278      AnnLet (AnnNonRec binder rhs2) body2)
 279   where
 280     rhs2     = freeVars rhs
 281     body2    = freeVars body
 282     body_fvs = binder `filters` freeVarsOf body2
 283
 284 freeVars (Let (Rec binds) body)
 285   = (foldl delVarSet group_fvs binders,
 286         -- The "filters" part may have added one of the binders
 287         -- via the idSpecVars part, so we must delete it again
 288      AnnLet (AnnRec (binders `zip` rhss2)) body2)
 289   where
 290     (binders, rhss) = unzip binds
 291
 292     rhss2     = map freeVars rhss
 293     all_fvs   = foldr (unionFVs . fst) body_fvs rhss2
 294     group_fvs = foldr filters all_fvs binders
 295
 296     body2     = freeVars body
 297     body_fvs  = freeVarsOf body2
 298
 299 freeVars (Note (Coerce to_ty from_ty) expr)
 300   = (freeVarsOf expr2 `unionFVs` tfvs1 `unionFVs` tfvs2,
 301      AnnNote (Coerce to_ty from_ty) expr2)
 302   where
 303     expr2  = freeVars expr
 304     tfvs1  = tyVarsOfType from_ty
 305     tfvs2  = tyVarsOfType to_ty
 306
 307 freeVars (Note other_note expr)
 308   = (freeVarsOf expr2, AnnNote other_note expr2)
 309   where
 310     expr2 = freeVars expr
 311
 312 freeVars (Type ty) = (tyVarsOfType ty, AnnType ty)
 313 \end{code}
 314