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