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