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         ruleRhsFreeVars, ruleLhsFreeNames, ruleLhsFreeIds,
  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, idSpecialisation )
  26 import NameSet
  27 import VarSet
  28 import Var              ( Var, isId, isLocalVar, varName )
  29 import Type             ( tyVarsOfType )
  30 import TcType           ( tyClsNamesOfType )
  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 whether a 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)   = tyClsNamesOfType ty -- Don't need free tyvars
 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 ruleLhsFreeIds :: CoreRule -> VarSet
 210 -- This finds all the free Ids on the LHS of the rule
 211 -- *including* imported ids
 212 ruleLhsFreeIds (BuiltinRule _ _) = noFVs
 213 ruleLhsFreeIds (Rule _ _ tpl_vars tpl_args rhs)
 214   = foldl delVarSet (exprsSomeFreeVars isId tpl_args) tpl_vars
 215 \end{code}
 216
 217
 218 %************************************************************************
 219 %*                                                                      *
 220 \section[freevars-everywhere]{Attaching free variables to every sub-expression}
 221 %*                                                                      *
 222 %************************************************************************
 223
 224 The free variable pass annotates every node in the expression with its
 225 NON-GLOBAL free variables and type variables.
 226
 227 \begin{code}
 228 type CoreBindWithFVs = AnnBind Id VarSet
 229 type CoreExprWithFVs = AnnExpr Id VarSet
 230         -- Every node annotated with its free variables,
 231         -- both Ids and TyVars
 232
 233 freeVarsOf :: CoreExprWithFVs -> IdSet
 234 freeVarsOf (free_vars, _) = free_vars
 235
 236 noFVs    = emptyVarSet
 237 aFreeVar = unitVarSet
 238 unionFVs = unionVarSet
 239
 240 delBindersFV :: [Var] -> VarSet -> VarSet
 241 delBindersFV bs fvs = foldr delBinderFV fvs bs
 242
 243 delBinderFV :: Var -> VarSet -> VarSet
 244 -- This way round, so we can do it multiple times using foldr
 245
 246 -- (b `delBinderFV` s) removes the binder b from the free variable set s,
 247 -- but *adds* to s
 248 --      (a) the free variables of b's type
 249 --      (b) the idSpecVars of b
 250 --
 251 -- This is really important for some lambdas:
 252 --      In (\x::a -> x) the only mention of "a" is in the binder.
 253 --
 254 -- Also in
 255 --      let x::a = b in ...
 256 -- we should really note that "a" is free in this expression.
 257 -- It'll be pinned inside the /\a by the binding for b, but
 258 -- it seems cleaner to make sure that a is in the free-var set
 259 -- when it is mentioned.
 260 --
 261 -- This also shows up in recursive bindings.  Consider:
 262 --      /\a -> letrec x::a = x in E
 263 -- Now, there are no explicit free type variables in the RHS of x,
 264 -- but nevertheless "a" is free in its definition.  So we add in
 265 -- the free tyvars of the types of the binders, and include these in the
 266 -- free vars of the group, attached to the top level of each RHS.
 267 --
 268 -- This actually happened in the defn of errorIO in IOBase.lhs:
 269 --      errorIO (ST io) = case (errorIO# io) of
 270 --                          _ -> bottom
 271 --                        where
 272 --                          bottom = bottom -- Never evaluated
 273
 274 delBinderFV b s | isId b    = (s `delVarSet` b) `unionFVs` idFreeVars b
 275                 | otherwise = s `delVarSet` b
 276
 277 idFreeVars :: Id -> VarSet
 278 idFreeVars id = ASSERT( isId id) idRuleVars id `unionVarSet` idFreeTyVars id
 279
 280 idFreeTyVars :: Id -> TyVarSet
 281 -- Only local Ids conjured up locally, can have free type variables.
 282 -- (During type checking top-level Ids can have free tyvars)
 283 idFreeTyVars id = tyVarsOfType (idType id)
 284 -- | isLocalId id = tyVarsOfType (idType id)
 285 -- | otherwise    = emptyVarSet
 286
 287 idRuleVars ::Id -> VarSet
 288 idRuleVars id = ASSERT( isId id) rulesRhsFreeVars (idSpecialisation id)
 289 \end{code}
 290
 291
 292 %************************************************************************
 293 %*                                                                      *
 294 \subsection{Free variables (and types)}
 295 %*                                                                      *
 296 %************************************************************************
 297
 298 \begin{code}
 299 freeVars :: CoreExpr -> CoreExprWithFVs
 300
 301 freeVars (Var v)
 302   = (fvs, AnnVar v)
 303   where
 304         -- ToDo: insert motivating example for why we *need*
 305         -- to include the idSpecVars in the FV list.
 306         --      Actually [June 98] I don't think it's necessary
 307         -- fvs = fvs_v `unionVarSet` idSpecVars v
 308
 309     fvs | isLocalVar v = aFreeVar v
 310         | otherwise    = noFVs
 311
 312 freeVars (Lit lit) = (noFVs, AnnLit lit)
 313 freeVars (Lam b body)
 314   = (b `delBinderFV` freeVarsOf body', AnnLam b body')
 315   where
 316     body' = freeVars body
 317
 318 freeVars (App fun arg)
 319   = (freeVarsOf fun2 `unionFVs` freeVarsOf arg2, AnnApp fun2 arg2)
 320   where
 321     fun2 = freeVars fun
 322     arg2 = freeVars arg
 323
 324 freeVars (Case scrut bndr alts)
 325   = ((bndr `delBinderFV` alts_fvs) `unionFVs` freeVarsOf scrut2,
 326      AnnCase scrut2 bndr alts2)
 327   where
 328     scrut2 = freeVars scrut
 329
 330     (alts_fvs_s, alts2) = mapAndUnzip fv_alt alts
 331     alts_fvs            = foldr1 unionFVs alts_fvs_s
 332
 333     fv_alt (con,args,rhs) = (delBindersFV args (freeVarsOf rhs2),
 334                              (con, args, rhs2))
 335                           where
 336                              rhs2 = freeVars rhs
 337
 338 freeVars (Let (NonRec binder rhs) body)
 339   = (freeVarsOf rhs2 `unionFVs` body_fvs,
 340      AnnLet (AnnNonRec binder rhs2) body2)
 341   where
 342     rhs2     = freeVars rhs
 343     body2    = freeVars body
 344     body_fvs = binder `delBinderFV` freeVarsOf body2
 345
 346 freeVars (Let (Rec binds) body)
 347   = (foldl delVarSet group_fvs binders,
 348         -- The "delBinderFV" part may have added one of the binders
 349         -- via the idSpecVars part, so we must delete it again
 350      AnnLet (AnnRec (binders `zip` rhss2)) body2)
 351   where
 352     (binders, rhss) = unzip binds
 353
 354     rhss2     = map freeVars rhss
 355     all_fvs   = foldr (unionFVs . fst) body_fvs rhss2
 356     group_fvs = delBindersFV binders all_fvs
 357
 358     body2     = freeVars body
 359     body_fvs  = freeVarsOf body2
 360
 361 freeVars (Note (Coerce to_ty from_ty) expr)
 362   = (freeVarsOf expr2 `unionFVs` tfvs1 `unionFVs` tfvs2,
 363      AnnNote (Coerce to_ty from_ty) expr2)
 364   where
 365     expr2  = freeVars expr
 366     tfvs1  = tyVarsOfType from_ty
 367     tfvs2  = tyVarsOfType to_ty
 368
 369 freeVars (Note other_note expr)
 370   = (freeVarsOf expr2, AnnNote other_note expr2)
 371   where
 372     expr2 = freeVars expr
 373
 374 freeVars (Type ty) = (tyVarsOfType ty, AnnType ty)
 375 \end{code}
 376