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