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