compiler/coreSyn/CoreFVs.lhs

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