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, exprFreeTyVars,
  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, unionManyTyVarSets,
  35                           TyVarSet, TyVar
  36                         )
  37 import BasicTypes       ( Unused )
  38 import UniqSet          ( unionUniqSets, addOneToUniqSet, delOneFromUniqSet )
  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 without        = delOneFromUniqSet
  81 add            = addOneToUniqSet
  82
  83 combineFVInfo (FVInfo fvs1 tfvs1 leak1) (FVInfo fvs2 tfvs2 leak2)
  84   = FVInfo (fvs1  `combine` fvs2)
  85            (tfvs1 `combine` tfvs2)
  86            (leak1 `orLeak`  leak2)
  87 \end{code}
  88
  89 Leak-free-ness is based only on the value, not the type.  In
  90 particular, nested collections of constructors are guaranteed leak
  91 free.  Function applications are not, except for PAPs.
  92
  93 Applications of error gets (LeakFree bigArity) -- a hack!
  94
  95 \begin{code}
  96 data LeakInfo
  97   = MightLeak
  98   | LeakFree Int    -- Leak free, and guarantees to absorb this # of
  99                     -- args before becoming leaky.
 100
 101 lEAK_FREE_0   = LeakFree 0
 102 lEAK_FREE_BIG = LeakFree bigArity
 103               where
 104                 bigArity = 1000::Int    -- NB: arbitrary
 105
 106 orLeak :: LeakInfo -> LeakInfo -> LeakInfo
 107 orLeak MightLeak     _           = MightLeak
 108 orLeak _             MightLeak   = MightLeak
 109 orLeak (LeakFree n) (LeakFree m) = LeakFree (n `min` m)
 110 \end{code}
 111
 112 Main public interface:
 113 \begin{code}
 114 freeVars :: CoreExpr -> CoreExprWithFVs
 115
 116 freeVars expr = fvExpr noIdCands noTyVarCands expr
 117
 118 \end{code}
 119
 120 %************************************************************************
 121 %*                                                                      *
 122 \subsection{Free variables (and types)}
 123 %*                                                                      *
 124 %************************************************************************
 125
 126 We do the free-variable stuff by passing around ``candidates lists''
 127 of @Ids@ and @TyVars@ that may be considered free.  This is useful,
 128 e.g., to avoid considering top-level binders as free variables---don't
 129 put them on the candidates list.
 130
 131 \begin{code}
 132
 133 fvExpr :: IdCands           -- In-scope Ids
 134        -> TyVarCands        -- In-scope tyvars
 135        -> CoreExpr
 136        -> CoreExprWithFVs
 137
 138 fvExpr id_cands tyvar_cands (Var v)
 139   = (FVInfo fvs noFreeTyVars leakiness, AnnVar v)
 140   where
 141     {-
 142      ToDo: insert motivating example for why we *need*
 143      to include the idSpecVars in the FV list.
 144     -}
 145     fvs = fvs_v `unionIdSets` mkIdSet (idSpecVars v)
 146
 147     fvs_v
 148      | v `is_among` id_cands = aFreeId v
 149      | otherwise             = noFreeIds
 150
 151     leakiness
 152       | isBottomingId v = lEAK_FREE_BIG -- Hack
 153       | otherwise       = case getIdArity v of
 154                             UnknownArity       -> lEAK_FREE_0
 155                             ArityAtLeast arity -> LeakFree arity
 156                             ArityExactly arity -> LeakFree arity
 157
 158 fvExpr id_cands tyvar_cands (Lit k)
 159   = (FVInfo noFreeIds noFreeTyVars lEAK_FREE_0, AnnLit k)
 160
 161 fvExpr id_cands tyvar_cands (Con c args)
 162   = (FVInfo args_fvs tfvs lEAK_FREE_0, AnnCon c args)
 163   where
 164     (args_fvs, tfvs) = freeArgs id_cands tyvar_cands args
 165
 166 fvExpr id_cands tyvar_cands (Prim op args)
 167   = (FVInfo args_fvs tfvs lEAK_FREE_0, AnnPrim op args)
 168   where
 169     (args_fvs, tfvs) = freeArgs id_cands tyvar_cands args_to_use{-NB-}
 170     args_to_use
 171       = case op of
 172           CCallOp _ _ _ _ res_ty -> TyArg res_ty : args
 173           _                      -> args
 174
 175 -- this Lam stuff could probably be improved by rewriting (WDP 96/03)
 176
 177 fvExpr id_cands tyvar_cands (Lam b@(ValBinder binder) body)
 178   = (FVInfo (freeVarsOf body2   `minusIdSet` unitIdSet binder)
 179             (freeTyVarsOf body2 `combine`    munge_id_ty binder)
 180             leakiness,
 181      AnnLam b body2)
 182   where
 183         -- We need to collect free tyvars from the binders
 184     body2 = fvExpr (unitIdSet binder `combine` id_cands) tyvar_cands body
 185
 186     leakiness = case leakinessOf body2 of
 187                   MightLeak  -> LeakFree 1
 188                   LeakFree n -> LeakFree (n + 1)
 189
 190 fvExpr id_cands tyvar_cands (Lam b@(TyBinder tyvar) body)
 191   = (FVInfo (freeVarsOf body2)
 192             (freeTyVarsOf body2 `minusTyVarSet` aFreeTyVar tyvar)
 193             (leakinessOf body2),
 194      AnnLam b body2)
 195   where
 196     body2 = fvExpr id_cands (aFreeTyVar tyvar `combine` tyvar_cands) body
 197
 198 -- ditto on rewriting this App stuff (WDP 96/03)
 199
 200 fvExpr id_cands tyvar_cands (App fun arg)
 201   = (FVInfo (freeVarsOf fun2   `combine` fvs_arg)
 202             (freeTyVarsOf fun2 `combine` tfvs_arg)
 203             leakiness,
 204      AnnApp fun2 arg)
 205   where
 206     fun2 = fvExpr id_cands tyvar_cands fun
 207     fun2_leakiness = leakinessOf fun2
 208
 209     (fvs_arg, tfvs_arg) = freeArgs id_cands tyvar_cands [arg]
 210
 211     leakiness = if (notValArg arg) then
 212                     fun2_leakiness
 213                 else
 214                     case fun2_leakiness of
 215                        LeakFree n | n>1 -> LeakFree (n-1) -- Note > not >=
 216                        other            -> MightLeak
 217
 218 fvExpr id_cands tyvar_cands (Case expr alts)
 219   = (combineFVInfo expr_fvinfo alts_fvinfo,
 220      AnnCase expr2 alts')
 221   where
 222     expr2@(expr_fvinfo,_) = fvExpr id_cands tyvar_cands expr
 223     (alts_fvinfo, alts') = annotate_alts alts
 224
 225     annotate_alts (AlgAlts alts deflt)
 226       = (fvinfo, AnnAlgAlts alts' deflt')
 227       where
 228         (alts_fvinfo_s, alts') = unzip (map ann_boxed_alt alts)
 229         (deflt_fvinfo, deflt') = annotate_default deflt
 230         fvinfo = foldr combineFVInfo deflt_fvinfo alts_fvinfo_s
 231
 232         ann_boxed_alt (con, params, rhs)
 233           = (FVInfo (freeVarsOf rhs' `minusIdSet` mkIdSet params)
 234                     (freeTyVarsOf rhs' `combine` param_ftvs)
 235                     (leakinessOf rhs'),
 236              (con, params, rhs'))
 237           where
 238             rhs' = fvExpr (mkIdSet params `combine` id_cands) tyvar_cands rhs
 239             param_ftvs = foldr (combine . munge_id_ty) noFreeTyVars params
 240                 -- We need to collect free tyvars from the binders
 241
 242     annotate_alts (PrimAlts alts deflt)
 243       = (fvinfo, AnnPrimAlts alts' deflt')
 244       where
 245         (alts_fvinfo_s, alts') = unzip (map ann_unboxed_alt alts)
 246         (deflt_fvinfo, deflt') = annotate_default deflt
 247         fvinfo  = foldr combineFVInfo deflt_fvinfo alts_fvinfo_s
 248
 249         ann_unboxed_alt (lit, rhs) = (rhs_info, (lit, rhs'))
 250           where
 251             rhs'@(rhs_info,_) = fvExpr id_cands tyvar_cands rhs
 252
 253     annotate_default NoDefault = (FVInfo noFreeIds noFreeTyVars lEAK_FREE_BIG,
 254                                     AnnNoDefault)
 255
 256     annotate_default (BindDefault binder rhs)
 257       = (FVInfo (freeVarsOf   rhs' `minusIdSet` aFreeId binder)
 258                 (freeTyVarsOf rhs' `combine` binder_ftvs)
 259                 (leakinessOf rhs'),
 260          AnnBindDefault binder rhs')
 261       where
 262         rhs' = fvExpr (aFreeId binder `combine` id_cands) tyvar_cands rhs
 263         binder_ftvs = munge_id_ty binder
 264             -- We need to collect free tyvars from the binder
 265
 266 -- Don't forget to notice that the idSpecVars of the binder
 267 -- are free in the whole expression; albeit not in the RHS or body
 268
 269 fvExpr id_cands tyvar_cands (Let (NonRec binder rhs) body)
 270   = (FVInfo (freeVarsOf rhs'   `combine` body_fvs `combine` mkIdSet (idSpecVars binder))
 271             (freeTyVarsOf rhs' `combine` freeTyVarsOf body2 `combine` binder_ftvs)
 272             (leakinessOf rhs' `orLeak` leakinessOf body2),
 273      AnnLet (AnnNonRec binder rhs') body2)
 274   where
 275     rhs'        = fvRhs id_cands tyvar_cands (binder, rhs)
 276     body2       = fvExpr (aFreeId binder `combine` id_cands) tyvar_cands body
 277     body_fvs    = freeVarsOf body2 `minusIdSet` aFreeId binder
 278     binder_ftvs = munge_id_ty binder
 279         -- We need to collect free tyvars from the binder
 280
 281 fvExpr id_cands tyvar_cands (Let (Rec binds) body)
 282   = (FVInfo (binds_fvs `combine` body_fvs)
 283             (rhss_tfvs `combine` freeTyVarsOf body2 `combine` binders_ftvs)
 284             (leakiness_of_rhss `orLeak` leakinessOf body2),
 285      AnnLet (AnnRec (binders `zip` rhss')) body2)
 286   where
 287     (binders, rhss)   = unzip binds
 288     new_id_cands      = binders_set `combine` id_cands
 289     binders_set       = mkIdSet binders
 290     rhss'             = map (fvRhs new_id_cands tyvar_cands) binds
 291
 292     FVInfo rhss_fvs rhss_tfvs leakiness_of_rhss
 293         = foldr1 combineFVInfo [info | (info,_) <- rhss']
 294
 295         -- Don't forget to notice that the idSpecVars of the binder
 296         -- are free in the whole expression; albeit not in the RHS or body
 297     binds_fvs         = (foldr (unionIdSets . mkIdSet . idSpecVars) rhss_fvs binders)
 298                         `minusIdSet`
 299                         binders_set
 300
 301     body2             = fvExpr new_id_cands tyvar_cands body
 302     body_fvs          = freeVarsOf body2 `minusIdSet` binders_set
 303     binders_ftvs      = foldr (combine . munge_id_ty) noFreeTyVars binders
 304         -- We need to collect free tyvars from the binders
 305
 306 fvExpr id_cands tyvar_cands (Note (Coerce to_ty from_ty) expr)
 307   = (FVInfo (freeVarsOf   expr2)
 308             (freeTyVarsOf expr2 `combine` tfvs1 `combine` tfvs2)
 309             (leakinessOf  expr2),
 310      AnnNote (Coerce to_ty from_ty) expr2)
 311   where
 312     expr2 = fvExpr id_cands tyvar_cands expr
 313     tfvs1  = freeTy tyvar_cands from_ty
 314     tfvs2  = freeTy tyvar_cands to_ty
 315
 316 fvExpr id_cands tyvar_cands (Note other_note expr)
 317   = (fvinfo, AnnNote other_note expr2)
 318   where
 319     expr2@(fvinfo,_) = fvExpr id_cands tyvar_cands expr
 320
 321 fvRhs id_cands tyvar_cands (bndr,rhs)
 322   = fvExpr id_cands tyvar_cands rhs
 323 \end{code}
 324
 325 \begin{code}
 326 freeArgs :: IdCands -> TyVarCands
 327          -> [CoreArg]
 328          -> (IdSet, TyVarSet)
 329
 330 freeArgs icands tcands [] = noFreeAnything
 331 freeArgs icands tcands (arg:args)
 332   -- this code is written this funny way only for "efficiency" purposes
 333   = let
 334         free_first_arg@(arg_fvs, tfvs) = free_arg arg
 335     in
 336     if (null args) then
 337         free_first_arg
 338     else
 339         case (freeArgs icands tcands args) of { (irest, trest) ->
 340         (arg_fvs `combine` irest, tfvs `combine` trest) }
 341   where
 342     free_arg (LitArg   _) = noFreeAnything
 343     free_arg (TyArg   ty) = (noFreeIds, freeTy tcands ty)
 344     free_arg (VarArg   v)
 345       | v `is_among` icands = (aFreeId v, noFreeTyVars)
 346       | otherwise           = noFreeAnything
 347
 348 ---------
 349 freeTy :: TyVarCands -> Type -> TyVarSet
 350
 351 freeTy cands ty = tyVarsOfType ty `intersectTyVarSets` cands
 352
 353 freeVarsOf :: CoreExprWithFVs -> IdSet
 354 freeVarsOf (FVInfo free_vars _ _, _) = free_vars
 355
 356 freeTyVarsOf :: CoreExprWithFVs -> TyVarSet
 357 freeTyVarsOf (FVInfo _ free_tyvars _, _) = free_tyvars
 358
 359 leakinessOf :: CoreExprWithFVs -> LeakInfo
 360 leakinessOf (FVInfo _ _ leakiness, _) = leakiness
 361 \end{code}
 362
 363
 364 %************************************************************************
 365 %*                                                                      *
 366 \section{Finding the free variables of an expression}
 367 %*                                                                      *
 368 %************************************************************************
 369
 370 This function simply finds the free variables of an expression.
 371
 372 \begin{code}
 373 type InterestingIdFun
 374   =  Id         -- The Id being looked at
 375   -> Bool       -- True <=> interesting
 376
 377 exprFreeVars :: InterestingIdFun -> CoreExpr -> IdSet
 378 exprFreeVars fv_cand e = expr_fvs fv_cand emptyIdSet e
 379 \end{code}
 380
 381
 382 \begin{code}
 383 expr_fvs :: InterestingIdFun    -- "Interesting id" predicate
 384          -> IdSet               -- In scope ids
 385          -> CoreExpr
 386          -> IdSet
 387
 388 expr_fvs fv_cand in_scope (Var v)        = id_fvs fv_cand in_scope v
 389 expr_fvs fv_cand in_scope (Lit lit)      = noFreeIds
 390 expr_fvs fv_cand in_scope (Con con args) = args_fvs fv_cand in_scope args
 391 expr_fvs fv_cand in_scope (Prim op args) = args_fvs fv_cand in_scope args
 392 expr_fvs fv_cand in_scope (Note _ expr)  = expr_fvs fv_cand in_scope expr
 393 expr_fvs fv_cand in_scope (App fun arg)  = expr_fvs fv_cand in_scope fun `combine`
 394                                            arg_fvs fv_cand in_scope arg
 395
 396
 397 expr_fvs fv_cand in_scope (Lam (ValBinder b) body)
 398   = (expr_fvs fv_cand (in_scope `add` b) body)
 399 expr_fvs fv_cand in_scope (Lam (TyBinder b) body)
 400   = expr_fvs fv_cand in_scope body
 401
 402 expr_fvs fv_cand in_scope (Case scrut alts)
 403   = expr_fvs fv_cand in_scope scrut `combine` alts_fvs
 404   where
 405     alts_fvs
 406       = case alts of
 407           AlgAlts alg_alts deflt -> unionManyIdSets (deflt_fvs : alt_fvs)
 408             where
 409               alt_fvs   = map do_alg_alt alg_alts
 410               deflt_fvs = do_deflt deflt
 411
 412           PrimAlts prim_alts deflt -> unionManyIdSets (deflt_fvs : alt_fvs)
 413             where
 414               alt_fvs   = map do_prim_alt prim_alts
 415               deflt_fvs = do_deflt deflt
 416
 417     do_alg_alt :: (Id, [Id], CoreExpr) -> IdSet
 418     do_alg_alt (con, args, rhs) = expr_fvs fv_cand new_in_scope rhs
 419       where
 420         new_in_scope = in_scope `combine` mkIdSet args
 421
 422     do_prim_alt (lit, rhs) = expr_fvs fv_cand in_scope rhs
 423
 424     do_deflt NoDefault           = noFreeIds
 425     do_deflt (BindDefault b rhs) = expr_fvs fv_cand (in_scope `add` b) rhs
 426
 427 expr_fvs fv_cand in_scope (Let (NonRec b r) body)
 428   = expr_fvs fv_cand in_scope r `combine`
 429     expr_fvs fv_cand (in_scope `add` b) body
 430
 431 expr_fvs fv_cand in_scope (Let (Rec pairs) body)
 432   = foldr (combine . expr_fvs fv_cand in_scope' . snd) noFreeIds pairs `combine`
 433     expr_fvs fv_cand in_scope' body
 434   where
 435     in_scope' = in_scope `combine` mkIdSet (map fst pairs)
 436
 437
 438
 439
 440 --------------------------------------
 441 arg_fvs fv_cand in_scope (VarArg v) = id_fvs fv_cand in_scope v
 442 arg_fvs fv_cand in_scope other_arg  = noFreeIds
 443
 444 --------------------------------------
 445 args_fvs fv_cand in_scope args = foldr (combine . arg_fvs fv_cand in_scope) noFreeIds args
 446
 447
 448 --------------------------------------
 449 id_fvs fv_cand in_scope v
 450   | v `elementOfIdSet` in_scope = noFreeIds
 451   | fv_cand v                   = aFreeId v
 452   | otherwise                   = noFreeIds
 453 \end{code}
 454
 455
 456 \begin{code}
 457 exprFreeTyVars ::  CoreExpr -> TyVarSet
 458 exprFreeTyVars = expr_ftvs
 459
 460 expr_ftvs :: CoreExpr -> TyVarSet
 461 expr_ftvs (Var v)        = noFreeTyVars
 462 expr_ftvs (Lit lit)      = noFreeTyVars
 463 expr_ftvs (Con con args) = args_ftvs args
 464 expr_ftvs (Prim op args) = args_ftvs args
 465 expr_ftvs (Note _ expr)  = expr_ftvs expr
 466 expr_ftvs (App fun arg)  = expr_ftvs fun `combine` arg_ftvs arg
 467
 468 expr_ftvs (Lam (ValBinder b) body) = expr_ftvs body
 469 expr_ftvs (Lam (TyBinder b)  body) = expr_ftvs body `without` b
 470
 471 expr_ftvs (Case scrut alts)
 472   = expr_ftvs scrut `combine` alts_ftvs
 473   where
 474     alts_ftvs
 475       = case alts of
 476           AlgAlts alg_alts deflt -> unionManyTyVarSets (deflt_ftvs : alt_ftvs)
 477             where
 478               alt_ftvs   = map do_alg_alt alg_alts
 479               deflt_ftvs = do_deflt deflt
 480
 481           PrimAlts prim_alts deflt -> unionManyTyVarSets (deflt_ftvs : alt_ftvs)
 482             where
 483               alt_ftvs   = map do_prim_alt prim_alts
 484               deflt_ftvs = do_deflt deflt
 485
 486     do_alg_alt :: (Id, [Id], CoreExpr) -> TyVarSet
 487     do_alg_alt (con, args, rhs) = expr_ftvs rhs
 488
 489     do_prim_alt (lit, rhs) = expr_ftvs rhs
 490
 491     do_deflt NoDefault           = noFreeTyVars
 492     do_deflt (BindDefault b rhs) = expr_ftvs rhs
 493
 494 expr_ftvs (Let (NonRec b r) body)
 495   = bind_ftvs (b,r) `combine` expr_ftvs body
 496
 497 expr_ftvs (Let (Rec pairs) body)
 498   = foldr (combine . bind_ftvs) noFreeTyVars pairs `combine`
 499     expr_ftvs body
 500
 501 --------------------------------------
 502 bind_ftvs (b,e) = tyVarsOfType (idType b) `combine` expr_ftvs e
 503
 504 --------------------------------------
 505 arg_ftvs (TyArg ty) = tyVarsOfType ty
 506 arg_ftvs other_arg  = noFreeTyVars
 507
 508 --------------------------------------
 509 args_ftvs args = foldr (combine . arg_ftvs) noFreeTyVars args
 510 \end{code}