ghc/compiler/coreSyn/FreeVars.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
   3 %
   4 Taken quite directly from the Peyton Jones/Lester paper.
   5
   6 \begin{code}
   7 module FreeVars (
   8         -- Cheap and cheerful variant...
   9         exprFreeVars,
  10
  11         -- Complicated and expensive variant for float-out
  12         freeVars,
  13         freeVarsOf, freeTyVarsOf,
  14         CoreExprWithFVs,                -- For the above functions
  15         AnnCoreExpr,                    -- Dito
  16         FVInfo(..), LeakInfo(..)
  17     ) where
  18
  19 #include "HsVersions.h"
  20
  21 import AnnCoreSyn       -- output
  22
  23 import CoreSyn
  24 import CoreUtils        ( idSpecVars )
  25 import Id               ( idType, getIdArity, isBottomingId,
  26                           emptyIdSet, unitIdSet, mkIdSet, unionIdSets,
  27                           elementOfIdSet, minusIdSet, unionManyIdSets,
  28                           IdSet, Id
  29                         )
  30 import IdInfo           ( ArityInfo(..) )
  31 import PrimOp           ( PrimOp(..) )
  32 import Type             ( tyVarsOfType, Type )
  33 import TyVar            ( emptyTyVarSet, unitTyVarSet, minusTyVarSet,
  34                           intersectTyVarSets,
  35                           TyVarSet, TyVar
  36                         )
  37 import BasicTypes       ( Unused )
  38 import UniqSet          ( unionUniqSets, addOneToUniqSet )
  39 import Util             ( panic, assertPanic )
  40
  41 \end{code}
  42
  43 %************************************************************************
  44 %*                                                                      *
  45 \section[freevars-everywhere]{Attaching free variables to every sub-expression
  46 %*                                                                      *
  47 %************************************************************************
  48
  49 The free variable pass annotates every node in the expression with its
  50 NON-GLOBAL free variables and type variables.
  51
  52 The ``free type variables'' are defined to be those which are mentioned
  53 in type applications, {\em not} ones which lie buried in the types of Ids.
  54
  55 *** ALAS: we *do* need to collect tyvars from lambda-bound ids. ***
  56 I've half-convinced myself we don't for case- and letrec bound ids
  57 but I might be wrong. (SLPJ, date unknown)
  58
  59 \begin{code}
  60 type CoreExprWithFVs =  AnnCoreExpr Id Id Unused FVInfo
  61
  62 type TyVarCands = TyVarSet  -- for when we carry around lists of
  63 type IdCands    = IdSet     -- "candidate" TyVars/Ids.
  64 noTyVarCands    = emptyTyVarSet
  65 noIdCands       = emptyIdSet
  66
  67 data FVInfo
  68   = FVInfo  IdSet       -- Free ids
  69             TyVarSet    -- Free tyvars
  70             LeakInfo
  71
  72 noFreeIds      = emptyIdSet
  73 noFreeTyVars   = emptyTyVarSet
  74 noFreeAnything = (noFreeIds, noFreeTyVars)
  75 aFreeId i      = unitIdSet i
  76 aFreeTyVar t   = unitTyVarSet t
  77 is_among       = elementOfIdSet
  78 munge_id_ty  i = tyVarsOfType (idType i)
  79 combine        = unionUniqSets -- used both for {Id,TyVar}Sets
  80 add            = addOneToUniqSet
  81
  82 combineFVInfo (FVInfo fvs1 tfvs1 leak1) (FVInfo fvs2 tfvs2 leak2)
  83   = FVInfo (fvs1  `combine` fvs2)
  84            (tfvs1 `combine` tfvs2)
  85            (leak1 `orLeak`  leak2)
  86 \end{code}
  87
  88 Leak-free-ness is based only on the value, not the type.  In
  89 particular, nested collections of constructors are guaranteed leak
  90 free.  Function applications are not, except for PAPs.
  91
  92 Applications of error gets (LeakFree bigArity) -- a hack!
  93
  94 \begin{code}
  95 data LeakInfo
  96   = MightLeak
  97   | LeakFree Int    -- Leak free, and guarantees to absorb this # of
  98                     -- args before becoming leaky.
  99
 100 lEAK_FREE_0   = LeakFree 0
 101 lEAK_FREE_BIG = LeakFree bigArity
 102               where
 103                 bigArity = 1000::Int    -- NB: arbitrary
 104
 105 orLeak :: LeakInfo -> LeakInfo -> LeakInfo
 106 orLeak MightLeak     _           = MightLeak
 107 orLeak _             MightLeak   = MightLeak
 108 orLeak (LeakFree n) (LeakFree m) = LeakFree (n `min` m)
 109 \end{code}
 110
 111 Main public interface:
 112 \begin{code}
 113 freeVars :: CoreExpr -> CoreExprWithFVs
 114
 115 freeVars expr = fvExpr noIdCands noTyVarCands expr
 116
 117 \end{code}
 118
 119 %************************************************************************
 120 %*                                                                      *
 121 \subsection{Free variables (and types)}
 122 %*                                                                      *
 123 %************************************************************************
 124
 125 We do the free-variable stuff by passing around ``candidates lists''
 126 of @Ids@ and @TyVars@ that may be considered free.  This is useful,
 127 e.g., to avoid considering top-level binders as free variables---don't
 128 put them on the candidates list.
 129
 130 \begin{code}
 131
 132 fvExpr :: IdCands           -- In-scope Ids
 133        -> TyVarCands        -- In-scope tyvars
 134        -> CoreExpr
 135        -> CoreExprWithFVs
 136
 137 fvExpr id_cands tyvar_cands (Var v)
 138   = (FVInfo fvs noFreeTyVars leakiness, AnnVar v)
 139   where
 140     {-
 141      ToDo: insert motivating example for why we *need*
 142      to include the idSpecVars in the FV list.
 143     -}
 144     fvs = fvs_v `unionIdSets` mkIdSet (idSpecVars v)
 145
 146     fvs_v
 147      | v `is_among` id_cands = aFreeId v
 148      | otherwise             = noFreeIds
 149
 150     leakiness
 151       | isBottomingId v = lEAK_FREE_BIG -- Hack
 152       | otherwise       = case getIdArity v of
 153                             UnknownArity       -> lEAK_FREE_0
 154                             ArityAtLeast arity -> LeakFree arity
 155                             ArityExactly arity -> LeakFree arity
 156
 157 fvExpr id_cands tyvar_cands (Lit k)
 158   = (FVInfo noFreeIds noFreeTyVars lEAK_FREE_0, AnnLit k)
 159
 160 fvExpr id_cands tyvar_cands (Con c args)
 161   = (FVInfo args_fvs tfvs lEAK_FREE_0, AnnCon c args)
 162   where
 163     (args_fvs, tfvs) = freeArgs id_cands tyvar_cands args
 164
 165 fvExpr id_cands tyvar_cands (Prim op args)
 166   = (FVInfo args_fvs tfvs lEAK_FREE_0, AnnPrim op args)
 167   where
 168     (args_fvs, tfvs) = freeArgs id_cands tyvar_cands args_to_use{-NB-}
 169     args_to_use
 170       = case op of
 171           CCallOp _ _ _ _ res_ty -> TyArg res_ty : args
 172           _                      -> args
 173
 174 -- this Lam stuff could probably be improved by rewriting (WDP 96/03)
 175
 176 fvExpr id_cands tyvar_cands (Lam b@(ValBinder binder) body)
 177   = (FVInfo (freeVarsOf body2   `minusIdSet` unitIdSet binder)
 178             (freeTyVarsOf body2 `combine`    munge_id_ty binder)
 179             leakiness,
 180      AnnLam b body2)
 181   where
 182         -- We need to collect free tyvars from the binders
 183     body2 = fvExpr (unitIdSet binder `combine` id_cands) tyvar_cands body
 184
 185     leakiness = case leakinessOf body2 of
 186                   MightLeak  -> LeakFree 1
 187                   LeakFree n -> LeakFree (n + 1)
 188
 189 fvExpr id_cands tyvar_cands (Lam b@(TyBinder tyvar) body)
 190   = (FVInfo (freeVarsOf body2)
 191             (freeTyVarsOf body2 `minusTyVarSet` aFreeTyVar tyvar)
 192             (leakinessOf body2),
 193      AnnLam b body2)
 194   where
 195     body2 = fvExpr id_cands (aFreeTyVar tyvar `combine` tyvar_cands) body
 196
 197 -- ditto on rewriting this App stuff (WDP 96/03)
 198
 199 fvExpr id_cands tyvar_cands (App fun arg)
 200   = (FVInfo (freeVarsOf fun2   `combine` fvs_arg)
 201             (freeTyVarsOf fun2 `combine` tfvs_arg)
 202             leakiness,
 203      AnnApp fun2 arg)
 204   where
 205     fun2 = fvExpr id_cands tyvar_cands fun
 206     fun2_leakiness = leakinessOf fun2
 207
 208     (fvs_arg, tfvs_arg) = freeArgs id_cands tyvar_cands [arg]
 209
 210     leakiness = if (notValArg arg) then
 211                     fun2_leakiness
 212                 else
 213                     case fun2_leakiness of
 214                        LeakFree n | n>1 -> LeakFree (n-1) -- Note > not >=
 215                        other            -> MightLeak
 216
 217 fvExpr id_cands tyvar_cands (Case expr alts)
 218   = (combineFVInfo expr_fvinfo alts_fvinfo,
 219      AnnCase expr2 alts')
 220   where
 221     expr2@(expr_fvinfo,_) = fvExpr id_cands tyvar_cands expr
 222     (alts_fvinfo, alts') = annotate_alts alts
 223
 224     annotate_alts (AlgAlts alts deflt)
 225       = (fvinfo, AnnAlgAlts alts' deflt')
 226       where
 227         (alts_fvinfo_s, alts') = unzip (map ann_boxed_alt alts)
 228         (deflt_fvinfo, deflt') = annotate_default deflt
 229         fvinfo = foldr combineFVInfo deflt_fvinfo alts_fvinfo_s
 230
 231         ann_boxed_alt (con, params, rhs)
 232           = (FVInfo (freeVarsOf rhs' `minusIdSet` mkIdSet params)
 233                     (freeTyVarsOf rhs' `combine` param_ftvs)
 234                     (leakinessOf rhs'),
 235              (con, params, rhs'))
 236           where
 237             rhs' = fvExpr (mkIdSet params `combine` id_cands) tyvar_cands rhs
 238             param_ftvs = foldr (combine . munge_id_ty) noFreeTyVars params
 239                 -- We need to collect free tyvars from the binders
 240
 241     annotate_alts (PrimAlts alts deflt)
 242       = (fvinfo, AnnPrimAlts alts' deflt')
 243       where
 244         (alts_fvinfo_s, alts') = unzip (map ann_unboxed_alt alts)
 245         (deflt_fvinfo, deflt') = annotate_default deflt
 246         fvinfo  = foldr combineFVInfo deflt_fvinfo alts_fvinfo_s
 247
 248         ann_unboxed_alt (lit, rhs) = (rhs_info, (lit, rhs'))
 249           where
 250             rhs'@(rhs_info,_) = fvExpr id_cands tyvar_cands rhs
 251
 252     annotate_default NoDefault = (FVInfo noFreeIds noFreeTyVars lEAK_FREE_BIG,
 253                                     AnnNoDefault)
 254
 255     annotate_default (BindDefault binder rhs)
 256       = (FVInfo (freeVarsOf   rhs' `minusIdSet` aFreeId binder)
 257                 (freeTyVarsOf rhs' `combine` binder_ftvs)
 258                 (leakinessOf rhs'),
 259          AnnBindDefault binder rhs')
 260       where
 261         rhs' = fvExpr (aFreeId binder `combine` id_cands) tyvar_cands rhs
 262         binder_ftvs = munge_id_ty binder
 263             -- We need to collect free tyvars from the binder
 264
 265 fvExpr id_cands tyvar_cands (Let (NonRec binder rhs) body)
 266   = (FVInfo (freeVarsOf rhs'   `combine` body_fvs)
 267             (freeTyVarsOf rhs' `combine` freeTyVarsOf body2 `combine` binder_ftvs)
 268             (leakinessOf rhs' `orLeak` leakinessOf body2),
 269      AnnLet (AnnNonRec binder rhs') body2)
 270   where
 271     rhs'        = fvRhs id_cands tyvar_cands (binder, rhs)
 272     body2       = fvExpr (aFreeId binder `combine` id_cands) tyvar_cands body
 273     body_fvs    = freeVarsOf body2 `minusIdSet` aFreeId binder
 274     binder_ftvs = munge_id_ty binder
 275         -- We need to collect free tyvars from the binder
 276
 277 fvExpr id_cands tyvar_cands (Let (Rec binds) body)
 278   = (FVInfo (binds_fvs `combine` body_fvs)
 279             (rhss_tfvs `combine` freeTyVarsOf body2 `combine` binders_ftvs)
 280             (leakiness_of_rhss `orLeak` leakinessOf body2),
 281      AnnLet (AnnRec (binders `zip` rhss')) body2)
 282   where
 283     (binders, rhss)   = unzip binds
 284     new_id_cands      = binders_set `combine` id_cands
 285     binders_set       = mkIdSet binders
 286     rhss'             = map (fvRhs new_id_cands tyvar_cands) binds
 287
 288     FVInfo rhss_fvs rhss_tfvs leakiness_of_rhss
 289         = foldr1 combineFVInfo [info | (info,_) <- rhss']
 290
 291     binds_fvs         = rhss_fvs `minusIdSet` binders_set
 292     body2             = fvExpr new_id_cands tyvar_cands body
 293     body_fvs          = freeVarsOf body2 `minusIdSet` binders_set
 294     binders_ftvs      = foldr (combine . munge_id_ty) noFreeTyVars binders
 295         -- We need to collect free tyvars from the binders
 296
 297 fvExpr id_cands tyvar_cands (Note (Coerce to_ty from_ty) expr)
 298   = (FVInfo (freeVarsOf   expr2)
 299             (freeTyVarsOf expr2 `combine` tfvs1 `combine` tfvs2)
 300             (leakinessOf  expr2),
 301      AnnNote (Coerce to_ty from_ty) expr2)
 302   where
 303     expr2 = fvExpr id_cands tyvar_cands expr
 304     tfvs1  = freeTy tyvar_cands from_ty
 305     tfvs2  = freeTy tyvar_cands to_ty
 306
 307 fvExpr id_cands tyvar_cands (Note other_note expr)
 308   = (fvinfo, AnnNote other_note expr2)
 309   where
 310     expr2@(fvinfo,_) = fvExpr id_cands tyvar_cands expr
 311
 312 -- fvRhs returns the annotated RHS, but it adds to the
 313 -- free vars of the RHS the idSpecVars of the binder,
 314 -- since those are, in truth, free in the definition.
 315 fvRhs id_cands tyvar_cands (bndr,rhs)
 316   = (FVInfo fvs' ftvs leak, rhs')
 317   where
 318     (FVInfo fvs ftvs leak, rhs') = fvExpr id_cands tyvar_cands rhs
 319     fvs' = fvs `unionIdSets` mkIdSet (idSpecVars bndr)
 320
 321 \end{code}
 322
 323 \begin{code}
 324 freeArgs :: IdCands -> TyVarCands
 325          -> [CoreArg]
 326          -> (IdSet, TyVarSet)
 327
 328 freeArgs icands tcands [] = noFreeAnything
 329 freeArgs icands tcands (arg:args)
 330   -- this code is written this funny way only for "efficiency" purposes
 331   = let
 332         free_first_arg@(arg_fvs, tfvs) = free_arg arg
 333     in
 334     if (null args) then
 335         free_first_arg
 336     else
 337         case (freeArgs icands tcands args) of { (irest, trest) ->
 338         (arg_fvs `combine` irest, tfvs `combine` trest) }
 339   where
 340     free_arg (LitArg   _) = noFreeAnything
 341     free_arg (TyArg   ty) = (noFreeIds, freeTy tcands ty)
 342     free_arg (VarArg   v)
 343       | v `is_among` icands = (aFreeId v, noFreeTyVars)
 344       | otherwise           = noFreeAnything
 345
 346 ---------
 347 freeTy :: TyVarCands -> Type -> TyVarSet
 348
 349 freeTy cands ty = tyVarsOfType ty `intersectTyVarSets` cands
 350
 351 freeVarsOf :: CoreExprWithFVs -> IdSet
 352 freeVarsOf (FVInfo free_vars _ _, _) = free_vars
 353
 354 freeTyVarsOf :: CoreExprWithFVs -> TyVarSet
 355 freeTyVarsOf (FVInfo _ free_tyvars _, _) = free_tyvars
 356
 357 leakinessOf :: CoreExprWithFVs -> LeakInfo
 358 leakinessOf (FVInfo _ _ leakiness, _) = leakiness
 359 \end{code}
 360
 361
 362 %************************************************************************
 363 %*                                                                      *
 364 \section{Finding the free variables of an expression}
 365 %*                                                                      *
 366 %************************************************************************
 367
 368 This function simply finds the free variables of an expression.
 369
 370 \begin{code}
 371 type InterestingIdFun
 372   =  Id         -- The Id being looked at
 373   -> Bool       -- True <=> interesting
 374
 375 exprFreeVars :: InterestingIdFun -> CoreExpr -> IdSet
 376 exprFreeVars fv_cand e = expr_fvs fv_cand emptyIdSet e
 377 \end{code}
 378
 379
 380 \begin{code}
 381 expr_fvs :: InterestingIdFun    -- "Interesting id" predicate
 382          -> IdSet               -- In scope ids
 383          -> CoreExpr
 384          -> IdSet
 385
 386 expr_fvs fv_cand in_scope (Var v)        = id_fvs fv_cand in_scope v
 387 expr_fvs fv_cand in_scope (Lit lit)      = noFreeIds
 388 expr_fvs fv_cand in_scope (Con con args) = args_fvs fv_cand in_scope args
 389 expr_fvs fv_cand in_scope (Prim op args) = args_fvs fv_cand in_scope args
 390 expr_fvs fv_cand in_scope (Note _ expr)  = expr_fvs fv_cand in_scope expr
 391 expr_fvs fv_cand in_scope (App fun arg)  = expr_fvs fv_cand in_scope fun `combine`
 392                                            arg_fvs fv_cand in_scope arg
 393
 394
 395 expr_fvs fv_cand in_scope (Lam (ValBinder b) body)
 396   = (expr_fvs fv_cand (in_scope `add` b) body)
 397 expr_fvs fv_cand in_scope (Lam (TyBinder b) body)
 398   = expr_fvs fv_cand in_scope body
 399
 400 expr_fvs fv_cand in_scope (Case scrut alts)
 401   = expr_fvs fv_cand in_scope scrut `combine` alts_fvs
 402   where
 403     alts_fvs
 404       = case alts of
 405           AlgAlts alg_alts deflt -> unionManyIdSets (deflt_fvs : alt_fvs)
 406             where
 407               alt_fvs   = map do_alg_alt alg_alts
 408               deflt_fvs = do_deflt deflt
 409
 410           PrimAlts prim_alts deflt -> unionManyIdSets (deflt_fvs : alt_fvs)
 411             where
 412               alt_fvs   = map do_prim_alt prim_alts
 413               deflt_fvs = do_deflt deflt
 414
 415     do_alg_alt :: (Id, [Id], CoreExpr) -> IdSet
 416     do_alg_alt (con, args, rhs) = expr_fvs fv_cand new_in_scope rhs
 417       where
 418         new_in_scope = in_scope `combine` mkIdSet args
 419
 420     do_prim_alt (lit, rhs) = expr_fvs fv_cand in_scope rhs
 421
 422     do_deflt NoDefault           = noFreeIds
 423     do_deflt (BindDefault b rhs) = expr_fvs fv_cand (in_scope `add` b) rhs
 424
 425 expr_fvs fv_cand in_scope (Let (NonRec b r) body)
 426   = expr_fvs fv_cand in_scope r `combine`
 427     expr_fvs fv_cand (in_scope `add` b) body
 428
 429 expr_fvs fv_cand in_scope (Let (Rec pairs) body)
 430   = foldr (combine . expr_fvs fv_cand in_scope' . snd) noFreeIds pairs `combine`
 431     expr_fvs fv_cand in_scope' body
 432   where
 433     in_scope' = in_scope `combine` mkIdSet (map fst pairs)
 434
 435
 436
 437
 438 --------------------------------------
 439 arg_fvs fv_cand in_scope (VarArg v) = id_fvs fv_cand in_scope v
 440 arg_fvs fv_cand in_scope other_arg  = noFreeIds
 441
 442 --------------------------------------
 443 args_fvs fv_cand in_scope args = foldr (combine . arg_fvs fv_cand in_scope) noFreeIds args
 444
 445
 446 --------------------------------------
 447 id_fvs fv_cand in_scope v
 448   | v `elementOfIdSet` in_scope = noFreeIds
 449   | fv_cand v                   = aFreeId v
 450   | otherwise                   = noFreeIds
 451 \end{code}