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