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'        = fvExpr id_cands tyvar_cands 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 (fvExpr new_id_cands tyvar_cands) rhss
 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 \end{code}
 304
 305 \begin{code}
 306 freeArgs :: IdCands -> TyVarCands
 307          -> [CoreArg]
 308          -> (IdSet, TyVarSet)
 309
 310 freeArgs icands tcands [] = noFreeAnything
 311 freeArgs icands tcands (arg:args)
 312   -- this code is written this funny way only for "efficiency" purposes
 313   = let
 314         free_first_arg@(arg_fvs, tfvs) = free_arg arg
 315     in
 316     if (null args) then
 317         free_first_arg
 318     else
 319         case (freeArgs icands tcands args) of { (irest, trest) ->
 320         (arg_fvs `combine` irest, tfvs `combine` trest) }
 321   where
 322     free_arg (LitArg   _) = noFreeAnything
 323     free_arg (TyArg   ty) = (noFreeIds, freeTy tcands ty)
 324     free_arg (VarArg   v)
 325       | v `is_among` icands = (aFreeId v, noFreeTyVars)
 326       | otherwise           = noFreeAnything
 327
 328 ---------
 329 freeTy :: TyVarCands -> Type -> TyVarSet
 330
 331 freeTy cands ty = tyVarsOfType ty `intersectTyVarSets` cands
 332
 333 freeVarsOf :: CoreExprWithFVs -> IdSet
 334 freeVarsOf (FVInfo free_vars _ _, _) = free_vars
 335
 336 freeTyVarsOf :: CoreExprWithFVs -> TyVarSet
 337 freeTyVarsOf (FVInfo _ free_tyvars _, _) = free_tyvars
 338
 339 leakinessOf :: CoreExprWithFVs -> LeakInfo
 340 leakinessOf (FVInfo _ _ leakiness, _) = leakiness
 341 \end{code}
 342
 343
 344 %************************************************************************
 345 %*                                                                      *
 346 \section{Finding the free variables of an expression}
 347 %*                                                                      *
 348 %************************************************************************
 349
 350 This function simply finds the free variables of an expression.
 351
 352 \begin{code}
 353 type InterestingIdFun
 354   =  Id         -- The Id being looked at
 355   -> Bool       -- True <=> interesting
 356
 357 exprFreeVars :: InterestingIdFun -> CoreExpr -> IdSet
 358 exprFreeVars fv_cand e = expr_fvs fv_cand emptyIdSet e
 359 \end{code}
 360
 361
 362 \begin{code}
 363 expr_fvs :: InterestingIdFun    -- "Interesting id" predicate
 364          -> IdSet               -- In scope ids
 365          -> CoreExpr
 366          -> IdSet
 367
 368 expr_fvs fv_cand in_scope (Var v)        = id_fvs fv_cand in_scope v
 369 expr_fvs fv_cand in_scope (Lit lit)      = noFreeIds
 370 expr_fvs fv_cand in_scope (Con con args) = args_fvs fv_cand in_scope args
 371 expr_fvs fv_cand in_scope (Prim op args) = args_fvs fv_cand in_scope args
 372 expr_fvs fv_cand in_scope (Note _ expr)  = expr_fvs fv_cand in_scope expr
 373 expr_fvs fv_cand in_scope (App fun arg)  = expr_fvs fv_cand in_scope fun `combine`
 374                                            arg_fvs fv_cand in_scope arg
 375
 376
 377 expr_fvs fv_cand in_scope (Lam (ValBinder b) body)
 378   = (expr_fvs fv_cand (in_scope `add` b) body)
 379 expr_fvs fv_cand in_scope (Lam (TyBinder b) body)
 380   = expr_fvs fv_cand in_scope body
 381
 382 expr_fvs fv_cand in_scope (Case scrut alts)
 383   = expr_fvs fv_cand in_scope scrut `combine` alts_fvs
 384   where
 385     alts_fvs
 386       = case alts of
 387           AlgAlts alg_alts deflt -> unionManyIdSets (deflt_fvs : alt_fvs)
 388             where
 389               alt_fvs   = map do_alg_alt alg_alts
 390               deflt_fvs = do_deflt deflt
 391
 392           PrimAlts prim_alts deflt -> unionManyIdSets (deflt_fvs : alt_fvs)
 393             where
 394               alt_fvs   = map do_prim_alt prim_alts
 395               deflt_fvs = do_deflt deflt
 396
 397     do_alg_alt :: (Id, [Id], CoreExpr) -> IdSet
 398     do_alg_alt (con, args, rhs) = expr_fvs fv_cand new_in_scope rhs
 399       where
 400         new_in_scope = in_scope `combine` mkIdSet args
 401
 402     do_prim_alt (lit, rhs) = expr_fvs fv_cand in_scope rhs
 403
 404     do_deflt NoDefault           = noFreeIds
 405     do_deflt (BindDefault b rhs) = expr_fvs fv_cand (in_scope `add` b) rhs
 406
 407 expr_fvs fv_cand in_scope (Let (NonRec b r) body)
 408   = expr_fvs fv_cand in_scope r `combine`
 409     expr_fvs fv_cand (in_scope `add` b) body
 410
 411 expr_fvs fv_cand in_scope (Let (Rec pairs) body)
 412   = foldr (combine . expr_fvs fv_cand in_scope' . snd) noFreeIds pairs `combine`
 413     expr_fvs fv_cand in_scope' body
 414   where
 415     in_scope' = in_scope `combine` mkIdSet (map fst pairs)
 416
 417
 418
 419
 420 --------------------------------------
 421 arg_fvs fv_cand in_scope (VarArg v) = id_fvs fv_cand in_scope v
 422 arg_fvs fv_cand in_scope other_arg  = noFreeIds
 423
 424 --------------------------------------
 425 args_fvs fv_cand in_scope args = foldr (combine . arg_fvs fv_cand in_scope) noFreeIds args
 426
 427
 428 --------------------------------------
 429 id_fvs fv_cand in_scope v
 430   | v `elementOfIdSet` in_scope = noFreeIds
 431   | fv_cand v                   = aFreeId v
 432   | otherwise                   = noFreeIds
 433 \end{code}