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