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 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)   = 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