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