ghc/compiler/coreSyn/FreeVars.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
   3 %
   4 Taken quite directly from the Peyton Jones/Lester paper.
   5
   6 \begin{code}
   7 #include "HsVersions.h"
   8
   9 module FreeVars (
  10         freeVars,
  11
  12         -- cheap and cheerful variant...
  13         addTopBindsFVs,
  14
  15         freeVarsOf, freeTyVarsOf,
  16         FVCoreExpr(..), FVCoreBinding(..),
  17
  18         CoreExprWithFVs(..),            -- For the above functions
  19         AnnCoreExpr(..),                -- Dito
  20         FVInfo(..), LeakInfo(..)
  21
  22         -- and to make the interface self-sufficient...
  23     ) where
  24
  25
  26 import AnnCoreSyn       -- output
  27
  28 import PrelInfo         ( PrimOp(..), PrimRep -- for CCallOp
  29                           IF_ATTACK_PRAGMAS(COMMA tagOf_PrimOp)
  30                           IF_ATTACK_PRAGMAS(COMMA pprPrimOp)
  31                         )
  32 import Type             ( extractTyVarsFromTy )
  33 import Id               ( idType, getIdArity, toplevelishId, isBottomingId )
  34 import IdInfo           -- Wanted for arityMaybe, but it seems you have
  35                         -- to import it all...  (Death to the Instance Virus!)
  36 import Maybes
  37 import UniqSet
  38 import Util
  39 \end{code}
  40
  41 %************************************************************************
  42 %*                                                                      *
  43 \section[freevars-everywhere]{Attaching free variables to every sub-expression
  44 %*                                                                      *
  45 %************************************************************************
  46
  47 The free variable pass annotates every node in the expression with its
  48 NON-GLOBAL free variables and type variables.
  49
  50 The ``free type variables'' are defined to be those which are mentioned
  51 in type applications, {\em not} ones which lie buried in the types of Ids.
  52
  53 *** ALAS: we *do* need to collect tyvars from lambda-bound ids. ***
  54 I've half-convinced myself we don't for case- and letrec bound ids
  55 but I might be wrong. (SLPJ, date unknown)
  56
  57 \begin{code}
  58 type CoreExprWithFVs =  AnnCoreExpr Id Id FVInfo
  59
  60 type TyVarCands = TyVarSet  -- for when we carry around lists of
  61 type IdCands    = IdSet     -- "candidate" TyVars/Ids.
  62 noTyVarCands    = emptyUniqSet
  63 noIdCands       = emptyUniqSet
  64
  65 data FVInfo = FVInfo
  66                 IdSet       -- Free ids
  67                 TyVarSet    -- Free tyvars
  68                 LeakInfo
  69
  70 noFreeIds      = emptyUniqSet
  71 noFreeTyVars   = emptyUniqSet
  72 aFreeId i      = singletonUniqSet i
  73 aFreeTyVar t   = singletonUniqSet t
  74 is_among       = elementOfUniqSet
  75 combine        = unionUniqSets
  76 munge_id_ty  i = mkUniqSet (extractTyVarsFromTy (idType i))
  77
  78 combineFVInfo (FVInfo fvs1 tfvs1 leak1) (FVInfo fvs2 tfvs2 leak2)
  79   = FVInfo (fvs1  `combine` fvs2)
  80            (tfvs1 `combine` tfvs2)
  81            (leak1 `orLeak`        leak2)
  82 \end{code}
  83
  84 Leak-free-ness is based only on the value, not the type.
  85 In particular, nested collections of constructors are guaranteed leak free.
  86 Function applications are not, except for PAPs.
  87
  88 Applications of error gets (LeakFree bigArity) -- a hack!
  89
  90 \begin{code}
  91 data LeakInfo
  92   = MightLeak
  93   | LeakFree Int    -- Leak free, and guarantees to absorb this # of
  94                     -- args before becoming leaky.
  95
  96 lEAK_FREE_0   = LeakFree 0
  97 lEAK_FREE_BIG = LeakFree bigArity
  98               where
  99                 bigArity = 1000::Int    -- NB: arbitrary
 100
 101 orLeak :: LeakInfo -> LeakInfo -> LeakInfo
 102 orLeak MightLeak     _           = MightLeak
 103 orLeak _             MightLeak   = MightLeak
 104 orLeak (LeakFree n) (LeakFree m) = LeakFree (n `min` m)
 105 \end{code}
 106
 107 Main public interface:
 108 \begin{code}
 109 freeVars :: CoreExpr -> CoreExprWithFVs
 110
 111 freeVars expr = fvExpr noIdCands noTyVarCands expr
 112 \end{code}
 113
 114 \subsection{Free variables (and types)}
 115
 116 We do the free-variable stuff by passing around ``candidates lists''
 117 of @Ids@ and @TyVars@ that may be considered free.  This is useful,
 118 e.g., to avoid considering top-level binders as free variables---don't
 119 put them on the candidates list.
 120
 121 \begin{code}
 122
 123 fvExpr :: IdCands           -- In-scope Ids
 124        -> TyVarCands        -- In-scope tyvars
 125        -> CoreExpr
 126        -> CoreExprWithFVs
 127
 128 fvExpr id_cands tyvar_cands (Var v)
 129   = (FVInfo (if (v `is_among` id_cands)
 130              then aFreeId v
 131              else noFreeIds)
 132             noFreeTyVars
 133             leakiness,
 134      AnnCoVar v)
 135   where
 136     leakiness
 137       | isBottomingId v = lEAK_FREE_BIG -- Hack
 138       | otherwise       = case arityMaybe (getIdArity v) of
 139                             Nothing    -> lEAK_FREE_0
 140                             Just arity -> LeakFree arity
 141
 142 fvExpr id_cands tyvar_cands (Lit k)
 143   = (FVInfo noFreeIds noFreeTyVars lEAK_FREE_0, AnnCoLit k)
 144
 145 fvExpr id_cands tyvar_cands (Con c tys args)
 146   = (FVInfo args_fvs tfvs lEAK_FREE_0, AnnCoCon c tys args)
 147   where
 148     args_fvs = foldr (combine . freeAtom id_cands)  noFreeIds    args
 149     tfvs     = foldr (combine . freeTy tyvar_cands) noFreeTyVars tys
 150
 151 fvExpr id_cands tyvar_cands (Prim op@(CCallOp _ _ _ _ res_ty) tys args)
 152   = ASSERT (null tys)
 153     (FVInfo args_fvs tfvs lEAK_FREE_0, AnnCoPrim op tys args)
 154   where
 155     args_fvs = foldr (combine . freeAtom id_cands)  noFreeIds    args
 156     tfvs     = foldr (combine . freeTy tyvar_cands) noFreeTyVars (res_ty:tys)
 157
 158 fvExpr id_cands tyvar_cands (Prim op tys args)
 159   = (FVInfo args_fvs tfvs lEAK_FREE_0, AnnCoPrim op tys args)
 160   where
 161     args_fvs = foldr (combine . freeAtom id_cands)  noFreeIds    args
 162     tfvs     = foldr (combine . freeTy tyvar_cands) noFreeTyVars tys
 163
 164 fvExpr id_cands tyvar_cands (Lam binder body)
 165   = (FVInfo (freeVarsOf body2   `minusUniqSet`  singletonUniqSet binder)
 166             (freeTyVarsOf body2 `combine` munge_id_ty binder)
 167             leakiness,
 168      AnnCoLam binder body2)
 169   where
 170         -- We need to collect free tyvars from the binders
 171     body2 = fvExpr (singletonUniqSet binder `combine` id_cands) tyvar_cands body
 172
 173     leakiness = case leakinessOf body2 of
 174                   MightLeak  -> LeakFree 1
 175                   LeakFree n -> LeakFree (n + 1)
 176
 177 fvExpr id_cands tyvar_cands (CoTyLam tyvar body)
 178   = (FVInfo (freeVarsOf body2)
 179             (freeTyVarsOf body2 `minusUniqSet` aFreeTyVar tyvar)
 180             (leakinessOf body2),
 181      AnnCoTyLam tyvar body2)
 182   where
 183     body2 = fvExpr id_cands (aFreeTyVar tyvar `combine` tyvar_cands) body
 184
 185 fvExpr id_cands tyvar_cands (App fun arg)
 186   = (FVInfo (freeVarsOf fun2 `combine` fvs_arg)
 187             (freeTyVarsOf fun2)
 188             leakiness,
 189      AnnCoApp fun2 arg)
 190   where
 191     fun2 = fvExpr id_cands tyvar_cands fun
 192     fvs_arg = freeAtom id_cands arg
 193
 194     leakiness = case leakinessOf fun2 of
 195                    LeakFree n | n>1 -> LeakFree (n-1)   -- Note > not >=
 196                    other            -> MightLeak
 197
 198 fvExpr id_cands tyvar_cands (CoTyApp expr ty)
 199   = (FVInfo (freeVarsOf expr2)
 200             (freeTyVarsOf expr2 `combine` tfvs_arg)
 201             (leakinessOf expr2),
 202      AnnCoTyApp expr2 ty)
 203   where
 204     expr2    = fvExpr id_cands tyvar_cands expr
 205     tfvs_arg = freeTy tyvar_cands ty
 206
 207 fvExpr id_cands tyvar_cands (Case expr alts)
 208   = (combineFVInfo expr_fvinfo alts_fvinfo,
 209      AnnCoCase expr2 alts')
 210   where
 211     expr2@(expr_fvinfo,_) = fvExpr id_cands tyvar_cands expr
 212     (alts_fvinfo, alts') = annotate_alts alts
 213
 214     annotate_alts (AlgAlts alts deflt)
 215       = (fvinfo, AnnCoAlgAlts alts' deflt')
 216       where
 217         (alts_fvinfo_s, alts') = unzip (map ann_boxed_alt alts)
 218         (deflt_fvinfo, deflt') = annotate_default deflt
 219         fvinfo = foldr combineFVInfo deflt_fvinfo alts_fvinfo_s
 220
 221         ann_boxed_alt (con, params, rhs)
 222           = (FVInfo (freeVarsOf rhs' `minusUniqSet` mkUniqSet params)
 223                     (freeTyVarsOf rhs' `combine` param_ftvs)
 224                     (leakinessOf rhs'),
 225              (con, params, rhs'))
 226           where
 227             rhs' = fvExpr (mkUniqSet params `combine` id_cands) tyvar_cands rhs
 228             param_ftvs = foldr (combine . munge_id_ty) noFreeTyVars params
 229                 -- We need to collect free tyvars from the binders
 230
 231     annotate_alts (PrimAlts alts deflt)
 232       = (fvinfo, AnnCoPrimAlts alts' deflt')
 233       where
 234         (alts_fvinfo_s, alts') = unzip (map ann_unboxed_alt alts)
 235         (deflt_fvinfo, deflt') = annotate_default deflt
 236         fvinfo  = foldr combineFVInfo deflt_fvinfo alts_fvinfo_s
 237
 238         ann_unboxed_alt (lit, rhs) = (rhs_info, (lit, rhs'))
 239           where
 240             rhs'@(rhs_info,_) = fvExpr id_cands tyvar_cands rhs
 241
 242     annotate_default NoDefault = (FVInfo noFreeIds noFreeTyVars lEAK_FREE_BIG,
 243                                     AnnCoNoDefault)
 244
 245     annotate_default (BindDefault binder rhs)
 246       = (FVInfo (freeVarsOf   rhs' `minusUniqSet` aFreeId binder)
 247                 (freeTyVarsOf rhs' `combine` binder_ftvs)
 248                 (leakinessOf rhs'),
 249          AnnCoBindDefault binder rhs')
 250       where
 251         rhs' = fvExpr (aFreeId binder `combine` id_cands) tyvar_cands rhs
 252         binder_ftvs = munge_id_ty binder
 253             -- We need to collect free tyvars from the binder
 254
 255 fvExpr id_cands tyvar_cands (Let (NonRec binder rhs) body)
 256   = (FVInfo (freeVarsOf rhs'   `combine` body_fvs)
 257             (freeTyVarsOf rhs' `combine` freeTyVarsOf body2 `combine` binder_ftvs)
 258             (leakinessOf rhs' `orLeak` leakinessOf body2),
 259      AnnCoLet (AnnCoNonRec binder rhs') body2)
 260   where
 261     rhs'        = fvExpr id_cands tyvar_cands rhs
 262     body2       = fvExpr (aFreeId binder `combine` id_cands) tyvar_cands body
 263     body_fvs    = freeVarsOf body2 `minusUniqSet` aFreeId binder
 264     binder_ftvs = munge_id_ty binder
 265         -- We need to collect free tyvars from the binder
 266
 267 fvExpr id_cands tyvar_cands (Let (Rec binds) body)
 268   = (FVInfo (binds_fvs `combine` body_fvs)
 269             (rhss_tfvs `combine` freeTyVarsOf body2 `combine` binders_ftvs)
 270             (leakiness_of_rhss `orLeak` leakinessOf body2),
 271      AnnCoLet (AnnCoRec (binders `zip` rhss')) body2)
 272   where
 273     (binders, rhss)   = unzip binds
 274     new_id_cands      = binders_set `combine` id_cands
 275     binders_set       = mkUniqSet binders
 276     rhss'             = map (fvExpr new_id_cands tyvar_cands) rhss
 277
 278     FVInfo rhss_fvs rhss_tfvs leakiness_of_rhss
 279         = foldr1 combineFVInfo [info | (info,_) <- rhss']
 280
 281     binds_fvs         = rhss_fvs `minusUniqSet` binders_set
 282     body2             = fvExpr new_id_cands tyvar_cands body
 283     body_fvs          = freeVarsOf body2 `minusUniqSet` binders_set
 284     binders_ftvs      = foldr (combine . munge_id_ty) noFreeTyVars binders
 285         -- We need to collect free tyvars from the binders
 286
 287 fvExpr id_cands tyvar_cands (SCC label expr)
 288   = (fvinfo, AnnCoSCC label expr2)
 289   where
 290     expr2@(fvinfo,_) = fvExpr id_cands tyvar_cands expr
 291 \end{code}
 292
 293 \begin{code}
 294 freeAtom :: IdCands -> CoreArg ->  IdSet
 295
 296 freeAtom cands (LitArg k) = noFreeIds
 297 freeAtom cands (VarArg v) | v `is_among` cands = aFreeId v
 298                              | otherwise          = noFreeIds
 299
 300 freeTy :: TyVarCands -> Type -> TyVarSet
 301
 302 freeTy cands ty = mkUniqSet (extractTyVarsFromTy ty) `intersectUniqSets` cands
 303
 304 freeVarsOf :: CoreExprWithFVs -> IdSet
 305 freeVarsOf (FVInfo free_vars _ _, _) = free_vars
 306
 307 freeTyVarsOf :: CoreExprWithFVs -> TyVarSet
 308 freeTyVarsOf (FVInfo _ free_tyvars _, _) = free_tyvars
 309
 310 leakinessOf :: CoreExprWithFVs -> LeakInfo
 311 leakinessOf (FVInfo _ _ leakiness, _) = leakiness
 312 \end{code}
 313
 314
 315 %************************************************************************
 316 %*                                                                      *
 317 \section[freevars-binders]{Attaching free variables to binders
 318 %*                                                                      *
 319 %************************************************************************
 320
 321
 322 Here's an variant of the free-variable pass, which pins free-variable
 323 information on {\em binders} rather than every single jolly
 324 expression!
 325 \begin{itemize}
 326 \item
 327   The free vars attached to a lambda binder are the free vars of the
 328   whole lambda abstraction.  If there are multiple binders, they are
 329   each given the same free-var set.
 330 \item
 331   The free vars attached to a let(rec) binder are the free vars of the
 332   rhs of the binding.  In the case of letrecs, this set excludes the
 333   binders themselves.
 334 \item
 335   The free vars attached to a case alternative binder are the free
 336   vars of the alternative, excluding the alternative's binders.
 337 \end{itemize}
 338
 339 There's a predicate carried in which tells what is a free-var
 340 candidate. It is passed the Id and a set of in-scope Ids.
 341
 342 (Global) constructors used on the rhs in a Con are also treated as
 343 potential free-var candidates (though they will not be recorded in the
 344 in-scope set). The predicate must decide if they are to be recorded as
 345 free-vars.
 346
 347 As it happens this is only ever used by the Specialiser!
 348
 349 \begin{code}
 350 type FVCoreBinder  = (Id, IdSet)
 351 type FVCoreExpr    = GenCoreExpr    FVCoreBinder Id
 352 type FVCoreBinding = GenCoreBinding FVCoreBinder Id
 353
 354 type InterestingIdFun
 355   =  IdSet      -- Non-top-level in-scope variables
 356   -> Id         -- The Id being looked at
 357   -> Bool       -- True <=> interesting
 358 \end{code}
 359
 360 \begin{code}
 361 addExprFVs :: InterestingIdFun  -- "Interesting id" predicate
 362            -> IdSet             -- In scope ids
 363            -> CoreExpr
 364            -> (FVCoreExpr, IdSet)
 365
 366 addExprFVs fv_cand in_scope (Var v)
 367   = (Var v, if fv_cand in_scope v
 368               then aFreeId v
 369               else noFreeIds)
 370
 371 addExprFVs fv_cand in_scope (Lit lit) = (Lit lit, noFreeIds)
 372
 373 addExprFVs fv_cand in_scope (Con con tys args)
 374   = (Con con tys args,
 375      if fv_cand in_scope con
 376      then aFreeId con
 377      else noFreeIds
 378         `combine`
 379      unionManyUniqSets (map (fvsOfAtom fv_cand in_scope) args))
 380
 381 addExprFVs fv_cand in_scope (Prim op tys args)
 382   = (Prim op tys args,
 383      unionManyUniqSets (map (fvsOfAtom fv_cand in_scope) args))
 384
 385 addExprFVs fv_cand in_scope (Lam binder body)
 386   = (Lam (binder,lam_fvs) new_body, lam_fvs)
 387   where
 388     binder_set = singletonUniqSet binder
 389     new_in_scope = in_scope `combine` binder_set
 390     (new_body, body_fvs) = addExprFVs fv_cand new_in_scope body
 391     lam_fvs = body_fvs `minusUniqSet` binder_set
 392
 393 addExprFVs fv_cand in_scope (CoTyLam tyvar body)
 394   = (CoTyLam tyvar body2, body_fvs)
 395   where
 396     (body2, body_fvs) = addExprFVs fv_cand in_scope body
 397
 398 addExprFVs fv_cand in_scope (App fun arg)
 399   = (App fun2 arg, fun_fvs `combine` fvsOfAtom fv_cand in_scope arg)
 400   where
 401     (fun2, fun_fvs) = addExprFVs fv_cand in_scope fun
 402
 403 addExprFVs fv_cand in_scope (CoTyApp fun ty)
 404   = (CoTyApp fun2 ty, fun_fvs)
 405   where
 406     (fun2, fun_fvs) = addExprFVs fv_cand in_scope fun
 407
 408 addExprFVs fv_cand in_scope (Case scrut alts)
 409   = (Case scrut' alts', scrut_fvs `combine` alts_fvs)
 410   where
 411     (scrut', scrut_fvs) = addExprFVs fv_cand in_scope scrut
 412
 413     (alts', alts_fvs)
 414       = case alts of
 415           AlgAlts alg_alts deflt -> (AlgAlts alg_alts' deflt', fvs)
 416             where
 417               (alg_alts', alt_fvs) = unzip (map do_alg_alt alg_alts)
 418               (deflt', deflt_fvs) = do_deflt deflt
 419               fvs = unionManyUniqSets (deflt_fvs : alt_fvs)
 420
 421           PrimAlts prim_alts deflt -> (PrimAlts prim_alts' deflt', fvs)
 422             where
 423               (prim_alts', alt_fvs) = unzip (map do_prim_alt prim_alts)
 424               (deflt', deflt_fvs) = do_deflt deflt
 425               fvs = unionManyUniqSets (deflt_fvs : alt_fvs)
 426
 427     do_alg_alt :: (Id, [Id], CoreExpr)
 428                -> ((Id, [FVCoreBinder], FVCoreExpr), IdSet)
 429
 430     do_alg_alt (con, args, rhs) = ((con, args `zip` (repeat fvs), rhs'), fvs)
 431       where
 432         new_in_scope = in_scope `combine` arg_set
 433         (rhs', rhs_fvs) = addExprFVs fv_cand new_in_scope rhs
 434         fvs = rhs_fvs `minusUniqSet` arg_set
 435         arg_set = mkUniqSet args
 436
 437     do_prim_alt (lit, rhs) = ((lit, rhs'), rhs_fvs)
 438       where
 439         (rhs', rhs_fvs) = addExprFVs fv_cand in_scope rhs
 440
 441     do_deflt NoDefault = (NoDefault, noFreeIds)
 442     do_deflt (BindDefault var rhs)
 443       = (BindDefault (var,fvs) rhs', fvs)
 444       where
 445         new_in_scope = in_scope `combine` var_set
 446         (rhs', rhs_fvs) = addExprFVs fv_cand new_in_scope rhs
 447         fvs = rhs_fvs `minusUniqSet` var_set
 448         var_set = aFreeId var
 449
 450 addExprFVs fv_cand in_scope (Let binds body)
 451   = (Let binds' body2, fvs_binds `combine` (fvs_body `minusUniqSet` binder_set))
 452   where
 453     (binds', fvs_binds, new_in_scope, binder_set)
 454       = addBindingFVs fv_cand in_scope binds
 455
 456     (body2, fvs_body)  = addExprFVs fv_cand new_in_scope body
 457
 458 addExprFVs fv_cand in_scope (SCC label expr)
 459   = (SCC label expr2, expr_fvs)
 460   where
 461     (expr2, expr_fvs) = addExprFVs fv_cand in_scope expr
 462 \end{code}
 463
 464 \begin{code}
 465 addBindingFVs
 466             :: InterestingIdFun -- "Interesting id" predicate
 467             -> IdSet            -- In scope ids
 468             -> CoreBinding
 469             -> (FVCoreBinding,
 470                 IdSet,          -- Free vars of binding group
 471                 IdSet,          -- Augmented in-scope Ids
 472                 IdSet)          -- Set of Ids bound by this binding
 473
 474 addBindingFVs fv_cand in_scope (NonRec binder rhs)
 475   = (NonRec binder' rhs', fvs, new_in_scope, binder_set)
 476   where
 477     ((binder', rhs'), fvs) = do_pair fv_cand in_scope binder_set (binder, rhs)
 478     new_in_scope = in_scope `combine` binder_set
 479     binder_set = aFreeId binder
 480
 481 addBindingFVs fv_cand in_scope (Rec pairs)
 482   = (Rec pairs', unionManyUniqSets fvs_s, new_in_scope, binder_set)
 483   where
 484     binders = [binder | (binder,_) <- pairs]
 485     binder_set = mkUniqSet binders
 486     new_in_scope = in_scope `combine` binder_set
 487     (pairs', fvs_s) = unzip (map (do_pair fv_cand new_in_scope binder_set) pairs)
 488 \end{code}
 489
 490 \begin{code}
 491 addTopBindsFVs
 492             :: InterestingIdFun -- "Interesting id" predicate
 493             -> [CoreBinding]
 494             -> ([FVCoreBinding],
 495                 IdSet)
 496
 497 addTopBindsFVs fv_cand [] = ([], noFreeIds)
 498 addTopBindsFVs fv_cand (b:bs)
 499   = let
 500       (b',  fvs_b, _, _) = addBindingFVs fv_cand noFreeIds b
 501       (bs', fvs_bs)      = addTopBindsFVs fv_cand bs
 502     in
 503     (b' : bs', fvs_b `combine` fvs_bs)
 504 \end{code}
 505
 506 \begin{code}
 507 fvsOfAtom   :: InterestingIdFun -- "Interesting id" predicate
 508             -> IdSet            -- In scope ids
 509             -> CoreArg
 510             -> IdSet
 511
 512 fvsOfAtom fv_cand in_scope (VarArg v)
 513   = if fv_cand in_scope v
 514     then aFreeId v
 515     else noFreeIds
 516 fvsOfAtom _ _ _ = noFreeIds -- if a literal...
 517
 518 do_pair :: InterestingIdFun -- "Interesting id" predicate
 519         -> IdSet            -- In scope ids
 520         -> IdSet
 521         -> (Id, CoreExpr)
 522         -> ((FVCoreBinder, FVCoreExpr), IdSet)
 523
 524 do_pair fv_cand in_scope binder_set (binder,rhs)
 525  = (((binder, fvs), rhs'), fvs)
 526  where
 527    (rhs', rhs_fvs) = addExprFVs fv_cand in_scope rhs
 528    fvs = rhs_fvs `minusUniqSet` binder_set
 529 \end{code}