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