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