compiler/coreSyn/CoreFVs.lhs

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