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, idFreeTyVars,
  17         ruleRhsFreeVars, rulesRhsFreeVars,
  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   | isId bndr = inside_fvs `unionVarSet` someVars (idFreeTyVars bndr) fv_cand in_scope
 142   | otherwise = inside_fvs
 143   where
 144     inside_fvs = 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
 245         -- Hack alert!
 246         -- Don't include the Id in its own rhs free-var set.
 247         -- Otherwise the occurrence analyser makes bindings recursive
 248         -- that shoudn't be.  E.g.
 249         --      RULE:  f (f x y) z  ==>  f x (f y z)
 250   where
 251     fvs = addBndrs bndrs (expr_fvs rhs) isLocalVar emptyVarSet
 252
 253 rulesRhsFreeVars :: [CoreRule] -> VarSet
 254 rulesRhsFreeVars rules
 255   = foldr (unionVarSet . ruleRhsFreeVars) 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
 265 %************************************************************************
 266 %*                                                                      *
 267 \section[freevars-everywhere]{Attaching free variables to every sub-expression}
 268 %*                                                                      *
 269 %************************************************************************
 270
 271 The free variable pass annotates every node in the expression with its
 272 NON-GLOBAL free variables and type variables.
 273
 274 \begin{code}
 275 type CoreBindWithFVs = AnnBind Id VarSet
 276 type CoreExprWithFVs = AnnExpr Id VarSet
 277         -- Every node annotated with its free variables,
 278         -- both Ids and TyVars
 279
 280 freeVarsOf :: CoreExprWithFVs -> IdSet
 281 freeVarsOf (free_vars, _) = free_vars
 282
 283 noFVs    = emptyVarSet
 284 aFreeVar = unitVarSet
 285 unionFVs = unionVarSet
 286
 287 delBindersFV :: [Var] -> VarSet -> VarSet
 288 delBindersFV bs fvs = foldr delBinderFV fvs bs
 289
 290 delBinderFV :: Var -> VarSet -> VarSet
 291 -- This way round, so we can do it multiple times using foldr
 292
 293 -- (b `delBinderFV` s) removes the binder b from the free variable set s,
 294 -- but *adds* to s
 295 --      (a) the free variables of b's type
 296 --      (b) the idSpecVars of b
 297 --
 298 -- This is really important for some lambdas:
 299 --      In (\x::a -> x) the only mention of "a" is in the binder.
 300 --
 301 -- Also in
 302 --      let x::a = b in ...
 303 -- we should really note that "a" is free in this expression.
 304 -- It'll be pinned inside the /\a by the binding for b, but
 305 -- it seems cleaner to make sure that a is in the free-var set
 306 -- when it is mentioned.
 307 --
 308 -- This also shows up in recursive bindings.  Consider:
 309 --      /\a -> letrec x::a = x in E
 310 -- Now, there are no explicit free type variables in the RHS of x,
 311 -- but nevertheless "a" is free in its definition.  So we add in
 312 -- the free tyvars of the types of the binders, and include these in the
 313 -- free vars of the group, attached to the top level of each RHS.
 314 --
 315 -- This actually happened in the defn of errorIO in IOBase.lhs:
 316 --      errorIO (ST io) = case (errorIO# io) of
 317 --                          _ -> bottom
 318 --                        where
 319 --                          bottom = bottom -- Never evaluated
 320
 321 delBinderFV b s | isId b    = (s `delVarSet` b) `unionFVs` idFreeVars b
 322                 | otherwise = s `delVarSet` b
 323
 324 idFreeVars :: Id -> VarSet
 325 idFreeVars id = ASSERT( isId id) idRuleVars id `unionVarSet` idFreeTyVars id
 326
 327 idFreeTyVars :: Id -> TyVarSet
 328 -- Only local Ids conjured up locally, can have free type variables.
 329 -- (During type checking top-level Ids can have free tyvars)
 330 idFreeTyVars id = tyVarsOfType (idType id)
 331 --  | isLocalId id = tyVarsOfType (idType id)
 332 --  | otherwise    = emptyVarSet
 333
 334 idRuleVars ::Id -> VarSet
 335 idRuleVars id = ASSERT( isId id) specInfoFreeVars (idSpecialisation id)
 336 \end{code}
 337
 338
 339 %************************************************************************
 340 %*                                                                      *
 341 \subsection{Free variables (and types)}
 342 %*                                                                      *
 343 %************************************************************************
 344
 345 \begin{code}
 346 freeVars :: CoreExpr -> CoreExprWithFVs
 347
 348 freeVars (Var v)
 349   = (fvs, AnnVar v)
 350   where
 351         -- ToDo: insert motivating example for why we *need*
 352         -- to include the idSpecVars in the FV list.
 353         --      Actually [June 98] I don't think it's necessary
 354         -- fvs = fvs_v `unionVarSet` idSpecVars v
 355
 356     fvs | isLocalVar v = aFreeVar v
 357         | otherwise    = noFVs
 358
 359 freeVars (Lit lit) = (noFVs, AnnLit lit)
 360 freeVars (Lam b body)
 361   = (b `delBinderFV` freeVarsOf body', AnnLam b body')
 362   where
 363     body' = freeVars body
 364
 365 freeVars (App fun arg)
 366   = (freeVarsOf fun2 `unionFVs` freeVarsOf arg2, AnnApp fun2 arg2)
 367   where
 368     fun2 = freeVars fun
 369     arg2 = freeVars arg
 370
 371 freeVars (Case scrut bndr ty alts)
 372 -- gaw 2004
 373   = ((bndr `delBinderFV` alts_fvs) `unionFVs` freeVarsOf scrut2 `unionFVs` tyVarsOfType ty,
 374      AnnCase scrut2 bndr ty alts2)
 375   where
 376     scrut2 = freeVars scrut
 377
 378     (alts_fvs_s, alts2) = mapAndUnzip fv_alt alts
 379     alts_fvs            = foldr1 unionFVs alts_fvs_s
 380
 381     fv_alt (con,args,rhs) = (delBindersFV args (freeVarsOf rhs2),
 382                              (con, args, rhs2))
 383                           where
 384                              rhs2 = freeVars rhs
 385
 386 freeVars (Let (NonRec binder rhs) body)
 387   = (freeVarsOf rhs2 `unionFVs` body_fvs,
 388      AnnLet (AnnNonRec binder rhs2) body2)
 389   where
 390     rhs2     = freeVars rhs
 391     body2    = freeVars body
 392     body_fvs = binder `delBinderFV` freeVarsOf body2
 393
 394 freeVars (Let (Rec binds) body)
 395   = (foldl delVarSet group_fvs binders,
 396         -- The "delBinderFV" part may have added one of the binders
 397         -- via the idSpecVars part, so we must delete it again
 398      AnnLet (AnnRec (binders `zip` rhss2)) body2)
 399   where
 400     (binders, rhss) = unzip binds
 401
 402     rhss2     = map freeVars rhss
 403     all_fvs   = foldr (unionFVs . fst) body_fvs rhss2
 404     group_fvs = delBindersFV binders all_fvs
 405
 406     body2     = freeVars body
 407     body_fvs  = freeVarsOf body2
 408
 409
 410 freeVars (Cast expr co)
 411   = (freeVarsOf expr2 `unionFVs` cfvs, AnnCast expr2 co)
 412   where
 413     expr2 = freeVars expr
 414     cfvs  = tyVarsOfType co
 415
 416 freeVars (Note other_note expr)
 417   = (freeVarsOf expr2, AnnNote other_note expr2)
 418   where
 419     expr2 = freeVars expr
 420
 421 freeVars (Type ty) = (tyVarsOfType ty, AnnType ty)
 422 \end{code}
 423