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