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