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