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