ghc/compiler/simplStg/StgVarInfo.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1993-1998
   3 %
   4 \section[StgVarInfo]{Sets free/live variable info in STG syntax}
   5
   6 And, as we have the info in hand, we may convert some lets to
   7 let-no-escapes.
   8
   9 \begin{code}
  10 module StgVarInfo ( setStgVarInfo ) where
  11
  12 #include "HsVersions.h"
  13
  14 import StgSyn
  15
  16 import Id               ( isLocalId, setIdArityInfo, idArity, setIdOccInfo, Id )
  17 import VarSet
  18 import VarEnv
  19 import Var
  20 import IdInfo           ( ArityInfo(..), OccInfo(..) )
  21 import PrimOp           ( PrimOp(..), ccallMayGC )
  22 import TysPrim          ( foreignObjPrimTyCon )
  23 import Type             ( splitTyConApp_maybe )
  24 import Maybes           ( maybeToBool, orElse )
  25 import Name             ( getOccName )
  26 import OccName          ( occNameUserString )
  27 import BasicTypes       ( Arity )
  28 import Outputable
  29
  30 infixr 9 `thenLne`, `thenLne_`
  31 \end{code}
  32
  33 %************************************************************************
  34 %*                                                                      *
  35 \subsection[live-vs-free-doc]{Documentation}
  36 %*                                                                      *
  37 %************************************************************************
  38
  39 (There is other relevant documentation in codeGen/CgLetNoEscape.)
  40
  41 March 97: setStgVarInfo guarantees to leave every variable's arity correctly
  42 set.  The lambda lifter makes some let-bound variables (which have arities)
  43 and turns them into lambda-bound ones (which should not, else we get Vap trouble),
  44 so this guarantee is necessary, as well as desirable.
  45
  46 The arity information is used in the code generator, when deciding if
  47 a right-hand side is a saturated application so we can generate a VAP
  48 closure.
  49
  50 The actual Stg datatype is decorated with {\em live variable}
  51 information, as well as {\em free variable} information.  The two are
  52 {\em not} the same.  Liveness is an operational property rather than a
  53 semantic one.  A variable is live at a particular execution point if
  54 it can be referred to {\em directly} again.  In particular, a dead
  55 variable's stack slot (if it has one):
  56 \begin{enumerate}
  57 \item
  58 should be stubbed to avoid space leaks, and
  59 \item
  60 may be reused for something else.
  61 \end{enumerate}
  62
  63 There ought to be a better way to say this.  Here are some examples:
  64 \begin{verbatim}
  65         let v = [q] \[x] -> e
  66         in
  67         ...v...  (but no q's)
  68 \end{verbatim}
  69
  70 Just after the `in', v is live, but q is dead.  If the whole of that
  71 let expression was enclosed in a case expression, thus:
  72 \begin{verbatim}
  73         case (let v = [q] \[x] -> e in ...v...) of
  74                 alts[...q...]
  75 \end{verbatim}
  76 (ie @alts@ mention @q@), then @q@ is live even after the `in'; because
  77 we'll return later to the @alts@ and need it.
  78
  79 Let-no-escapes make this a bit more interesting:
  80 \begin{verbatim}
  81         let-no-escape v = [q] \ [x] -> e
  82         in
  83         ...v...
  84 \end{verbatim}
  85 Here, @q@ is still live at the `in', because @v@ is represented not by
  86 a closure but by the current stack state.  In other words, if @v@ is
  87 live then so is @q@.  Furthermore, if @e@ mentions an enclosing
  88 let-no-escaped variable, then {\em its} free variables are also live
  89 if @v@ is.
  90
  91 %************************************************************************
  92 %*                                                                      *
  93 \subsection[binds-StgVarInfo]{Setting variable info: top-level, binds, RHSs}
  94 %*                                                                      *
  95 %************************************************************************
  96
  97 Top-level:
  98 \begin{code}
  99 setStgVarInfo   :: Bool                 -- True <=> do let-no-escapes
 100                 -> [StgBinding] -- input
 101                 -> [StgBinding] -- result
 102
 103 setStgVarInfo want_LNEs pgm
 104   = pgm'
 105   where
 106     (pgm', _) = initLne want_LNEs (varsTopBinds pgm)
 107
 108 \end{code}
 109
 110 For top-level guys, we basically aren't worried about this
 111 live-variable stuff; we do need to keep adding to the environment
 112 as we step through the bindings (using @extendVarEnv@).
 113
 114 \begin{code}
 115 varsTopBinds :: [StgBinding] -> LneM ([StgBinding], FreeVarsInfo)
 116
 117 varsTopBinds [] = returnLne ([], emptyFVInfo)
 118 varsTopBinds (bind:binds)
 119   = extendVarEnvLne env_extension (
 120         varsTopBinds binds                      `thenLne` \ (binds', fv_binds) ->
 121         varsTopBind binders' fv_binds bind      `thenLne` \ (bind',  fv_bind) ->
 122         returnLne ((bind' : binds'),
 123                    (fv_binds `unionFVInfo` fv_bind) `minusFVBinders` binders'
 124                   )
 125
 126     )
 127   where
 128     pairs         = case bind of
 129                         StgNonRec binder rhs -> [(binder,rhs)]
 130                         StgRec pairs         -> pairs
 131
 132     binders' = [ binder `setIdArityInfo` ArityExactly (rhsArity rhs)
 133                | (binder, rhs) <- pairs
 134                ]
 135
 136     env_extension = binders' `zip` repeat how_bound
 137
 138     how_bound = LetrecBound
 139                         True {- top level -}
 140                         emptyVarSet
 141
 142
 143 varsTopBind :: [Id]                     -- New binders (with correct arity)
 144             -> FreeVarsInfo             -- Info about the body
 145             -> StgBinding
 146             -> LneM (StgBinding, FreeVarsInfo)
 147
 148 varsTopBind [binder'] body_fvs (StgNonRec binder rhs)
 149   = varsRhs body_fvs (binder,rhs)               `thenLne` \ (rhs2, fvs, _) ->
 150     returnLne (StgNonRec binder' rhs2, fvs)
 151
 152 varsTopBind binders' body_fvs (StgRec pairs)
 153   = fixLne (\ ~(_, rec_rhs_fvs) ->
 154         let
 155                 scope_fvs = unionFVInfo body_fvs rec_rhs_fvs
 156         in
 157         mapAndUnzip3Lne (varsRhs scope_fvs) pairs `thenLne` \ (rhss2, fvss, _) ->
 158         let
 159                 fvs = unionFVInfos fvss
 160         in
 161         returnLne (StgRec (binders' `zip` rhss2), fvs)
 162     )
 163
 164 \end{code}
 165
 166 \begin{code}
 167 varsRhs :: FreeVarsInfo         -- Free var info for the scope of the binding
 168         -> (Id,StgRhs)
 169         -> LneM (StgRhs, FreeVarsInfo, EscVarsSet)
 170
 171 varsRhs scope_fv_info (binder, StgRhsCon cc con args)
 172   = varsAtoms args      `thenLne` \ (args', fvs) ->
 173     returnLne (StgRhsCon cc con args', fvs, getFVSet fvs)
 174
 175 varsRhs scope_fv_info (binder, StgRhsClosure cc _ srt _ upd args body)
 176   = extendVarEnvLne [ (zapArity a, LambdaBound) | a <- args ] (
 177     do_body args body   `thenLne` \ (body2, body_fvs, body_escs) ->
 178     let
 179         set_of_args     = mkVarSet args
 180         rhs_fvs         = body_fvs  `minusFVBinders` args
 181         rhs_escs        = body_escs `minusVarSet`   set_of_args
 182         binder_info     = lookupFVInfo scope_fv_info binder
 183         upd'  | null args && isPAP body2 = ReEntrant
 184               | otherwise                = upd
 185     in
 186     returnLne (StgRhsClosure cc binder_info srt (getFVs rhs_fvs) upd'
 187                 args body2, rhs_fvs, rhs_escs)
 188     )
 189   where
 190         -- Pick out special case of application in body of thunk
 191     do_body [] (StgApp f args) = varsApp (Just upd) f args
 192     do_body _ other_body         = varsExpr other_body
 193 \end{code}
 194
 195 Detect thunks which will reduce immediately to PAPs, and make them
 196 non-updatable.  This has several advantages:
 197
 198         - the non-updatable thunk behaves exactly like the PAP,
 199
 200         - the thunk is more efficient to enter, because it is
 201           specialised to the task.
 202
 203         - we save one update frame, one stg_update_PAP, one update
 204           and lots of PAP_enters.
 205
 206         - in the case where the thunk is top-level, we save building
 207           a black hole and futhermore the thunk isn't considered to
 208           be a CAF any more, so it doesn't appear in any SRTs.
 209
 210 We do it here, because the arity information is accurate, and we need
 211 to do it before the SRT pass to save the SRT entries associated with
 212 any top-level PAPs.
 213
 214 \begin{code}
 215 isPAP (StgApp f args) = idArity f > length args
 216 isPAP _               = False
 217 \end{code}
 218
 219 \begin{code}
 220 varsAtoms :: [StgArg]
 221           -> LneM ([StgArg], FreeVarsInfo)
 222         -- It's not *really* necessary to return fresh arguments,
 223         -- because the only difference is that the argument variable
 224         -- arities are correct.  But it seems safer to do so.
 225
 226 varsAtoms atoms
 227   = mapAndUnzipLne var_atom atoms       `thenLne` \ (args', fvs_lists) ->
 228     returnLne (args', unionFVInfos fvs_lists)
 229   where
 230     var_atom a@(StgVarArg v)
 231       = lookupVarLne v  `thenLne` \ (v', how_bound) ->
 232         returnLne (StgVarArg v', singletonFVInfo v' how_bound stgArgOcc)
 233     var_atom a = returnLne (a, emptyFVInfo)
 234 \end{code}
 235
 236 %************************************************************************
 237 %*                                                                      *
 238 \subsection[expr-StgVarInfo]{Setting variable info on expressions}
 239 %*                                                                      *
 240 %************************************************************************
 241
 242 @varsExpr@ carries in a monad-ised environment, which binds each
 243 let(rec) variable (ie non top level, not imported, not lambda bound,
 244 not case-alternative bound) to:
 245         - its STG arity, and
 246         - its set of live vars.
 247 For normal variables the set of live vars is just the variable
 248 itself.  For let-no-escaped variables, the set of live vars is the set
 249 live at the moment the variable is entered.  The set is guaranteed to
 250 have no further let-no-escaped vars in it.
 251
 252 \begin{code}
 253 varsExpr :: StgExpr
 254          -> LneM (StgExpr,      -- Decorated expr
 255                   FreeVarsInfo, -- Its free vars (NB free, not live)
 256                   EscVarsSet)   -- Its escapees, a subset of its free vars;
 257                                 -- also a subset of the domain of the envt
 258                                 -- because we are only interested in the escapees
 259                                 -- for vars which might be turned into
 260                                 -- let-no-escaped ones.
 261 \end{code}
 262
 263 The second and third components can be derived in a simple bottom up pass, not
 264 dependent on any decisions about which variables will be let-no-escaped or
 265 not.  The first component, that is, the decorated expression, may then depend
 266 on these components, but it in turn is not scrutinised as the basis for any
 267 decisions.  Hence no black holes.
 268
 269 \begin{code}
 270 varsExpr (StgLit l)      = returnLne (StgLit l, emptyFVInfo, emptyVarSet)
 271
 272 varsExpr (StgApp f args) = varsApp Nothing f args
 273
 274 varsExpr (StgConApp con args)
 275   = varsAtoms args              `thenLne` \ (args', args_fvs) ->
 276     returnLne (StgConApp con args', args_fvs, getFVSet args_fvs)
 277
 278 varsExpr (StgPrimApp op args res_ty)
 279   = varsAtoms args              `thenLne` \ (args', args_fvs) ->
 280     returnLne (StgPrimApp op args' res_ty, args_fvs, getFVSet args_fvs)
 281
 282 varsExpr (StgSCC cc expr)
 283   = varsExpr expr               `thenLne` ( \ (expr2, fvs, escs) ->
 284     returnLne (StgSCC cc expr2, fvs, escs) )
 285 \end{code}
 286
 287 Cases require a little more real work.
 288 \begin{code}
 289 varsExpr (StgCase scrut _ _ bndr srt alts)
 290   = getVarsLiveInCont             `thenLne` \ live_in_cont ->
 291     extendVarEnvLne [(zapArity bndr, CaseBound)] (
 292     vars_alts alts                `thenLne` \ (alts2, alts_fvs, alts_escs) ->
 293     lookupLiveVarsForSet alts_fvs `thenLne` \ alts_lvs ->
 294     let
 295         -- determine whether the default binder is dead or not
 296         bndr'= if (bndr `elementOfFVInfo` alts_fvs)
 297                   then bndr `setIdOccInfo` NoOccInfo
 298                   else bndr `setIdOccInfo` IAmDead
 299
 300          -- for a _ccall_GC_, some of the *arguments* need to live across the
 301          -- call (see findLiveArgs comments.), so we annotate them as being live
 302          -- in the alts to achieve the desired effect.
 303         mb_live_across_case =
 304           case scrut of
 305             StgPrimApp (CCallOp ccall)  args _
 306                 |  ccallMayGC ccall
 307                 -> Just (foldl findLiveArgs emptyVarSet args)
 308             _   -> Nothing
 309
 310         -- don't consider the default binder as being 'live in alts',
 311         -- since this is from the point of view of the case expr, where
 312         -- the default binder is not free.
 313         live_in_alts = orElse (FMAP unionVarSet mb_live_across_case) id $
 314                        live_in_cont `unionVarSet`
 315                        (alts_lvs `minusVarSet` unitVarSet bndr)
 316     in
 317         -- we tell the scrutinee that everything live in the alts
 318         -- is live in it, too.
 319     setVarsLiveInCont live_in_alts (
 320         varsExpr scrut
 321     )                              `thenLne` \ (scrut2, scrut_fvs, scrut_escs) ->
 322     lookupLiveVarsForSet scrut_fvs `thenLne` \ scrut_lvs ->
 323     let
 324         live_in_whole_case = live_in_alts `unionVarSet` scrut_lvs
 325     in
 326     returnLne (
 327       StgCase scrut2 live_in_whole_case live_in_alts bndr' srt alts2,
 328       (scrut_fvs `unionFVInfo` alts_fvs)
 329           `minusFVBinders` [bndr],
 330       (alts_escs `minusVarSet` unitVarSet bndr) `unionVarSet` getFVSet scrut_fvs
 331                 -- You might think we should have scrut_escs, not (getFVSet scrut_fvs),
 332                 -- but actually we can't call, and then return from, a let-no-escape thing.
 333       )
 334     )
 335   where
 336     vars_alts (StgAlgAlts tycon alts deflt)
 337       = mapAndUnzip3Lne vars_alg_alt alts
 338                         `thenLne` \ (alts2,  alts_fvs_list,  alts_escs_list) ->
 339         let
 340             alts_fvs  = unionFVInfos alts_fvs_list
 341             alts_escs = unionVarSets alts_escs_list
 342         in
 343         vars_deflt deflt `thenLne` \ (deflt2, deflt_fvs, deflt_escs) ->
 344         returnLne (
 345             StgAlgAlts tycon alts2 deflt2,
 346             alts_fvs  `unionFVInfo`   deflt_fvs,
 347             alts_escs `unionVarSet` deflt_escs
 348         )
 349       where
 350         vars_alg_alt (con, binders, worthless_use_mask, rhs)
 351           = extendVarEnvLne [(zapArity b, CaseBound) | b <- binders] (
 352             varsExpr rhs        `thenLne` \ (rhs2, rhs_fvs, rhs_escs) ->
 353             let
 354                 good_use_mask = [ b `elementOfFVInfo` rhs_fvs | b <- binders ]
 355                 -- records whether each param is used in the RHS
 356             in
 357             returnLne (
 358                 (con, binders, good_use_mask, rhs2),
 359                 rhs_fvs  `minusFVBinders` binders,
 360                 rhs_escs `minusVarSet`   mkVarSet binders       -- ToDo: remove the minusVarSet;
 361                                                         -- since escs won't include
 362                                                         -- any of these binders
 363             ))
 364
 365     vars_alts (StgPrimAlts tycon alts deflt)
 366       = mapAndUnzip3Lne vars_prim_alt alts
 367                         `thenLne` \ (alts2,  alts_fvs_list,  alts_escs_list) ->
 368         let
 369             alts_fvs  = unionFVInfos alts_fvs_list
 370             alts_escs = unionVarSets alts_escs_list
 371         in
 372         vars_deflt deflt `thenLne` \ (deflt2, deflt_fvs, deflt_escs) ->
 373         returnLne (
 374             StgPrimAlts tycon alts2 deflt2,
 375             alts_fvs  `unionFVInfo`   deflt_fvs,
 376             alts_escs `unionVarSet` deflt_escs
 377         )
 378       where
 379         vars_prim_alt (lit, rhs)
 380           = varsExpr rhs        `thenLne` \ (rhs2, rhs_fvs, rhs_escs) ->
 381             returnLne ((lit, rhs2), rhs_fvs, rhs_escs)
 382
 383     vars_deflt StgNoDefault
 384       = returnLne (StgNoDefault, emptyFVInfo, emptyVarSet)
 385
 386     vars_deflt (StgBindDefault rhs)
 387       = varsExpr rhs    `thenLne` \ (rhs2, rhs_fvs, rhs_escs) ->
 388         returnLne ( StgBindDefault rhs2, rhs_fvs, rhs_escs )
 389 \end{code}
 390
 391 Lets not only take quite a bit of work, but this is where we convert
 392 then to let-no-escapes, if we wish.
 393
 394 (Meanwhile, we don't expect to see let-no-escapes...)
 395 \begin{code}
 396 varsExpr (StgLetNoEscape _ _ _ _) = panic "varsExpr: unexpected StgLetNoEscape"
 397
 398 varsExpr (StgLet bind body)
 399   = isSwitchSetLne {-StgDoLetNoEscapes-} `thenLne` \ want_LNEs ->
 400
 401     (fixLne (\ ~(_, _, _, no_binder_escapes) ->
 402         let
 403             non_escaping_let = want_LNEs && no_binder_escapes
 404         in
 405         vars_let non_escaping_let bind body
 406     ))                                  `thenLne` \ (new_let, fvs, escs, _) ->
 407
 408     returnLne (new_let, fvs, escs)
 409 \end{code}
 410
 411 If we've got a case containing a _ccall_GC_ primop, we need to
 412 ensure that the arguments are kept live for the duration of the
 413 call. This only an issue
 414
 415 \begin{code}
 416 findLiveArgs :: StgLiveVars -> StgArg -> StgLiveVars
 417 findLiveArgs lvs (StgVarArg x)
 418    | isForeignObjPrimTy (idType x) = extendVarSet lvs x
 419    | otherwise                     = lvs
 420 findLiveArgs lvs arg               = lvs
 421
 422 isForeignObjPrimTy ty
 423    = case splitTyConApp_maybe ty of
 424         Just (tycon, _) -> tycon == foreignObjPrimTyCon
 425         Nothing         -> False
 426 \end{code}
 427
 428
 429 Applications:
 430 \begin{code}
 431 varsApp :: Maybe UpdateFlag             -- Just upd <=> this application is
 432                                         -- the rhs of a thunk binding
 433                                         --      x = [...] \upd [] -> the_app
 434                                         -- with specified update flag
 435         -> Id                           -- Function
 436         -> [StgArg]             -- Arguments
 437         -> LneM (StgExpr, FreeVarsInfo, EscVarsSet)
 438
 439 varsApp maybe_thunk_body f args
 440   = getVarsLiveInCont           `thenLne` \ live_in_cont ->
 441
 442     varsAtoms args              `thenLne` \ (args', args_fvs) ->
 443
 444     lookupVarLne f              `thenLne` \ (f', how_bound) ->
 445
 446     let
 447         n_args           = length args
 448         not_letrec_bound = not (isLetrecBound how_bound)
 449         f_arity          = idArity f'   -- Will have an exact arity by now
 450         fun_fvs          = singletonFVInfo f' how_bound fun_occ
 451
 452         fun_occ
 453           | not_letrec_bound = NoStgBinderInfo          -- Uninteresting variable
 454
 455                 -- Otherwise it is letrec bound; must have its arity
 456           | n_args == 0 = stgFakeFunAppOcc      -- Function Application
 457                                                 -- with no arguments.
 458                                                 -- used by the lambda lifter.
 459           | f_arity > n_args = stgUnsatOcc      -- Unsaturated
 460
 461
 462           | f_arity == n_args &&
 463             maybeToBool maybe_thunk_body        -- Exactly saturated,
 464                                                 -- and rhs of thunk
 465           = case maybe_thunk_body of
 466                 Just Updatable   -> stgStdHeapOcc
 467                 Just SingleEntry -> stgNoUpdHeapOcc
 468                 other            -> panic "varsApp"
 469
 470           | otherwise =  stgNormalOcc
 471                                 -- Record only that it occurs free
 472
 473         myself = unitVarSet f'
 474
 475         fun_escs | not_letrec_bound  = emptyVarSet      -- Only letrec-bound escapees are interesting
 476                  | f_arity == n_args = emptyVarSet      -- Function doesn't escape
 477                  | otherwise         = myself           -- Inexact application; it does escape
 478
 479         -- At the moment of the call:
 480
 481         --  either the function is *not* let-no-escaped, in which case
 482         --         nothing is live except live_in_cont
 483         --      or the function *is* let-no-escaped in which case the
 484         --         variables it uses are live, but still the function
 485         --         itself is not.  PS.  In this case, the function's
 486         --         live vars should already include those of the
 487         --         continuation, but it does no harm to just union the
 488         --         two regardless.
 489
 490         -- XXX not needed?
 491         -- live_at_call
 492         --   = live_in_cont `unionVarSet` case how_bound of
 493         --                            LetrecBound _ lvs -> lvs `minusVarSet` myself
 494         --                         other             -> emptyVarSet
 495     in
 496     returnLne (
 497         StgApp f' args',
 498         fun_fvs  `unionFVInfo` args_fvs,
 499         fun_escs `unionVarSet` (getFVSet args_fvs)
 500                                 -- All the free vars of the args are disqualified
 501                                 -- from being let-no-escaped.
 502     )
 503 \end{code}
 504
 505 The magic for lets:
 506 \begin{code}
 507 vars_let :: Bool                -- True <=> yes, we are let-no-escaping this let
 508          -> StgBinding  -- bindings
 509          -> StgExpr     -- body
 510          -> LneM (StgExpr,      -- new let
 511                   FreeVarsInfo, -- variables free in the whole let
 512                   EscVarsSet,   -- variables that escape from the whole let
 513                   Bool)         -- True <=> none of the binders in the bindings
 514                                 -- is among the escaping vars
 515
 516 vars_let let_no_escape bind body
 517   = fixLne (\ ~(_, _, _, rec_bind_lvs, _, rec_body_fvs, _, _) ->
 518
 519         -- Do the bindings, setting live_in_cont to empty if
 520         -- we ain't in a let-no-escape world
 521         getVarsLiveInCont               `thenLne` \ live_in_cont ->
 522         setVarsLiveInCont
 523                 (if let_no_escape then live_in_cont else emptyVarSet)
 524                 (vars_bind rec_bind_lvs rec_body_fvs bind)
 525                                         `thenLne` \ (bind2, bind_fvs, bind_escs, env_ext) ->
 526
 527         -- The live variables of this binding are the ones which are live
 528         -- by virtue of being accessible via the free vars of the binding (lvs_from_fvs)
 529         -- together with the live_in_cont ones
 530         lookupLiveVarsForSet (bind_fvs `minusFVBinders` binders)        `thenLne` \ lvs_from_fvs ->
 531         let
 532                 bind_lvs = lvs_from_fvs `unionVarSet` live_in_cont
 533         in
 534
 535         -- bind_fvs and bind_escs still include the binders of the let(rec)
 536         -- but bind_lvs does not
 537
 538         -- Do the body
 539         extendVarEnvLne env_ext (
 540                 varsExpr body                   `thenLne` \ (body2, body_fvs, body_escs) ->
 541                 lookupLiveVarsForSet body_fvs   `thenLne` \ body_lvs ->
 542
 543                 returnLne (bind2, bind_fvs, bind_escs, bind_lvs,
 544                            body2, body_fvs, body_escs, body_lvs)
 545
 546     )) `thenLne` (\ (bind2, bind_fvs, bind_escs, bind_lvs,
 547                      body2, body_fvs, body_escs, body_lvs) ->
 548
 549
 550         -- Compute the new let-expression
 551     let
 552         new_let | let_no_escape = StgLetNoEscape live_in_whole_let bind_lvs bind2 body2
 553                 | otherwise     = StgLet bind2 body2
 554
 555         free_in_whole_let
 556           = (bind_fvs `unionFVInfo` body_fvs) `minusFVBinders` binders
 557
 558         live_in_whole_let
 559           = bind_lvs `unionVarSet` (body_lvs `minusVarSet` set_of_binders)
 560
 561         real_bind_escs = if let_no_escape then
 562                             bind_escs
 563                          else
 564                             getFVSet bind_fvs
 565                             -- Everything escapes which is free in the bindings
 566
 567         let_escs = (real_bind_escs `unionVarSet` body_escs) `minusVarSet` set_of_binders
 568
 569         all_escs = bind_escs `unionVarSet` body_escs    -- Still includes binders of
 570                                                 -- this let(rec)
 571
 572         no_binder_escapes = isEmptyVarSet (set_of_binders `intersectVarSet` all_escs)
 573
 574 #ifdef DEBUG
 575         -- Debugging code as requested by Andrew Kennedy
 576         checked_no_binder_escapes
 577                 | not no_binder_escapes && any is_join_var binders
 578                 = pprTrace "Interesting!  A join var that isn't let-no-escaped" (ppr binders)
 579                   False
 580                 | otherwise = no_binder_escapes
 581 #else
 582         checked_no_binder_escapes = no_binder_escapes
 583 #endif
 584
 585                 -- Mustn't depend on the passed-in let_no_escape flag, since
 586                 -- no_binder_escapes is used by the caller to derive the flag!
 587     in
 588     returnLne (
 589         new_let,
 590         free_in_whole_let,
 591         let_escs,
 592         checked_no_binder_escapes
 593     ))
 594   where
 595     set_of_binders = mkVarSet binders
 596     binders        = case bind of
 597                         StgNonRec binder rhs -> [binder]
 598                         StgRec pairs         -> map fst pairs
 599
 600     mk_binding bind_lvs (binder,rhs)
 601         = (binder `setIdArityInfo` ArityExactly (stgArity rhs),
 602            LetrecBound  False           -- Not top level
 603                         live_vars
 604           )
 605         where
 606            live_vars = if let_no_escape then
 607                             extendVarSet bind_lvs binder
 608                        else
 609                             unitVarSet binder
 610
 611     vars_bind :: StgLiveVars
 612               -> FreeVarsInfo                   -- Free var info for body of binding
 613               -> StgBinding
 614               -> LneM (StgBinding,
 615                        FreeVarsInfo, EscVarsSet,        -- free vars; escapee vars
 616                        [(Id, HowBound)])
 617                                          -- extension to environment
 618
 619     vars_bind rec_bind_lvs rec_body_fvs (StgNonRec binder rhs)
 620       = varsRhs rec_body_fvs (binder,rhs)       `thenLne` \ (rhs2, fvs, escs) ->
 621         let
 622             env_ext_item@(binder', _) = mk_binding rec_bind_lvs (binder,rhs)
 623         in
 624         returnLne (StgNonRec binder' rhs2, fvs, escs, [env_ext_item])
 625
 626     vars_bind rec_bind_lvs rec_body_fvs (StgRec pairs)
 627       = let
 628             env_ext  = map (mk_binding rec_bind_lvs) pairs
 629             binders' = map fst env_ext
 630         in
 631         extendVarEnvLne env_ext           (
 632         fixLne (\ ~(_, rec_rhs_fvs, _, _) ->
 633                 let
 634                         rec_scope_fvs = unionFVInfo rec_body_fvs rec_rhs_fvs
 635                 in
 636                 mapAndUnzip3Lne (varsRhs rec_scope_fvs) pairs `thenLne` \ (rhss2, fvss, escss) ->
 637                 let
 638                         fvs  = unionFVInfos      fvss
 639                         escs = unionVarSets escss
 640                 in
 641                 returnLne (StgRec (binders' `zip` rhss2), fvs, escs, env_ext)
 642         ))
 643
 644 is_join_var :: Id -> Bool
 645 -- A hack (used only for compiler debuggging) to tell if
 646 -- a variable started life as a join point ($j)
 647 is_join_var j = occNameUserString (getOccName j) == "$j"
 648 \end{code}
 649
 650 %************************************************************************
 651 %*                                                                      *
 652 \subsection[LNE-monad]{A little monad for this let-no-escaping pass}
 653 %*                                                                      *
 654 %************************************************************************
 655
 656 There's a lot of stuff to pass around, so we use this @LneM@ monad to
 657 help.  All the stuff here is only passed {\em down}.
 658
 659 \begin{code}
 660 type LneM a =  Bool                     -- True <=> do let-no-escapes
 661             -> IdEnv (Id, HowBound)     -- Use the Id at all occurrences; it has correct
 662                                         --      arity information inside it.
 663             -> StgLiveVars              -- vars live in continuation
 664             -> a
 665
 666 data HowBound
 667   = ImportBound
 668   | CaseBound
 669   | LambdaBound
 670   | LetrecBound
 671         Bool            -- True <=> bound at top level
 672         StgLiveVars     -- Live vars... see notes below
 673
 674 isLetrecBound (LetrecBound _ _) = True
 675 isLetrecBound other             = False
 676 \end{code}
 677
 678 For a let(rec)-bound variable, x,  we record what varibles are live if
 679 x is live.  For "normal" variables that is just x alone.  If x is
 680 a let-no-escaped variable then x is represented by a code pointer and
 681 a stack pointer (well, one for each stack).  So all of the variables
 682 needed in the execution of x are live if x is, and are therefore recorded
 683 in the LetrecBound constructor; x itself *is* included.
 684
 685 The std monad functions:
 686 \begin{code}
 687 initLne :: Bool -> LneM a -> a
 688 initLne want_LNEs m = m want_LNEs emptyVarEnv emptyVarSet
 689
 690 {-# INLINE thenLne #-}
 691 {-# INLINE thenLne_ #-}
 692 {-# INLINE returnLne #-}
 693
 694 returnLne :: a -> LneM a
 695 returnLne e sw env lvs_cont = e
 696
 697 thenLne :: LneM a -> (a -> LneM b) -> LneM b
 698 thenLne m k sw env lvs_cont
 699   = case (m sw env lvs_cont) of
 700       m_result -> k m_result sw env lvs_cont
 701
 702 thenLne_ :: LneM a -> LneM b -> LneM b
 703 thenLne_ m k sw env lvs_cont
 704   = case (m sw env lvs_cont) of
 705       _ -> k sw env lvs_cont
 706
 707 mapLne  :: (a -> LneM b)   -> [a] -> LneM [b]
 708 mapLne f [] = returnLne []
 709 mapLne f (x:xs)
 710   = f x         `thenLne` \ r  ->
 711     mapLne f xs `thenLne` \ rs ->
 712     returnLne (r:rs)
 713
 714 mapAndUnzipLne  :: (a -> LneM (b,c))   -> [a] -> LneM ([b],[c])
 715
 716 mapAndUnzipLne f [] = returnLne ([],[])
 717 mapAndUnzipLne f (x:xs)
 718   = f x                 `thenLne` \ (r1,  r2)  ->
 719     mapAndUnzipLne f xs `thenLne` \ (rs1, rs2) ->
 720     returnLne (r1:rs1, r2:rs2)
 721
 722 mapAndUnzip3Lne :: (a -> LneM (b,c,d)) -> [a] -> LneM ([b],[c],[d])
 723
 724 mapAndUnzip3Lne f []    = returnLne ([],[],[])
 725 mapAndUnzip3Lne f (x:xs)
 726   = f x                  `thenLne` \ (r1,  r2,  r3)  ->
 727     mapAndUnzip3Lne f xs `thenLne` \ (rs1, rs2, rs3) ->
 728     returnLne (r1:rs1, r2:rs2, r3:rs3)
 729
 730 fixLne :: (a -> LneM a) -> LneM a
 731 fixLne expr sw env lvs_cont = result
 732   where
 733     result = expr result sw env lvs_cont
 734 --  ^^^^^^ ------ ^^^^^^
 735 \end{code}
 736
 737 Functions specific to this monad:
 738 \begin{code}
 739 isSwitchSetLne :: LneM Bool
 740 isSwitchSetLne want_LNEs env lvs_cont
 741   = want_LNEs
 742
 743 getVarsLiveInCont :: LneM StgLiveVars
 744 getVarsLiveInCont sw env lvs_cont = lvs_cont
 745
 746 setVarsLiveInCont :: StgLiveVars -> LneM a -> LneM a
 747 setVarsLiveInCont new_lvs_cont expr sw env lvs_cont
 748   = expr sw env new_lvs_cont
 749
 750 extendVarEnvLne :: [(Id, HowBound)] -> LneM a -> LneM a
 751 extendVarEnvLne ids_w_howbound expr sw env lvs_cont
 752   = expr sw (extendVarEnvList env [(id, pair) | pair@(id,_) <- ids_w_howbound]) lvs_cont
 753
 754
 755 lookupVarLne :: Id -> LneM (Id, HowBound)
 756 lookupVarLne v sw env lvs_cont
 757   = returnLne (
 758       case (lookupVarEnv env v) of
 759         Just xx -> xx
 760         Nothing -> --false:ASSERT(not (isLocallyDefined v))
 761                    (v, ImportBound)
 762     ) sw env lvs_cont
 763
 764 -- The result of lookupLiveVarsForSet, a set of live variables, is
 765 -- only ever tacked onto a decorated expression. It is never used as
 766 -- the basis of a control decision, which might give a black hole.
 767
 768 lookupLiveVarsForSet :: FreeVarsInfo -> LneM StgLiveVars
 769
 770 lookupLiveVarsForSet fvs sw env lvs_cont
 771   = returnLne (unionVarSets (map do_one (getFVs fvs)))
 772               sw env lvs_cont
 773   where
 774     do_one v
 775       = if isLocalId v then
 776             case (lookupVarEnv env v) of
 777               Just (_, LetrecBound _ lvs) -> extendVarSet lvs v
 778               Just _                      -> unitVarSet v
 779               Nothing -> pprPanic "lookupVarEnv/do_one:" (ppr v)
 780         else
 781             emptyVarSet
 782 \end{code}
 783
 784
 785 %************************************************************************
 786 %*                                                                      *
 787 \subsection[Free-var info]{Free variable information}
 788 %*                                                                      *
 789 %************************************************************************
 790
 791 \begin{code}
 792 type FreeVarsInfo = IdEnv (Id, Bool, StgBinderInfo)
 793                         -- If f is mapped to NoStgBinderInfo, that means
 794                         -- that f *is* mentioned (else it wouldn't be in the
 795                         -- IdEnv at all), but only in a saturated applications.
 796                         --
 797                         -- All case/lambda-bound things are also mapped to
 798                         -- NoStgBinderInfo, since we aren't interested in their
 799                         -- occurence info.
 800                         --
 801                         -- The Bool is True <=> the Id is top level letrec bound
 802
 803 type EscVarsSet   = IdSet
 804 \end{code}
 805
 806 \begin{code}
 807 emptyFVInfo :: FreeVarsInfo
 808 emptyFVInfo = emptyVarEnv
 809
 810 singletonFVInfo :: Id -> HowBound -> StgBinderInfo -> FreeVarsInfo
 811 singletonFVInfo id ImportBound               info = emptyVarEnv
 812 singletonFVInfo id (LetrecBound top_level _) info = unitVarEnv id (id, top_level, info)
 813 singletonFVInfo id other                     info = unitVarEnv id (id, False,     info)
 814
 815 unionFVInfo :: FreeVarsInfo -> FreeVarsInfo -> FreeVarsInfo
 816 unionFVInfo fv1 fv2 = plusVarEnv_C plusFVInfo fv1 fv2
 817
 818 unionFVInfos :: [FreeVarsInfo] -> FreeVarsInfo
 819 unionFVInfos fvs = foldr unionFVInfo emptyFVInfo fvs
 820
 821 minusFVBinders :: FreeVarsInfo -> [Id] -> FreeVarsInfo
 822 minusFVBinders fv ids = fv `delVarEnvList` ids
 823
 824 elementOfFVInfo :: Id -> FreeVarsInfo -> Bool
 825 elementOfFVInfo id fvs = maybeToBool (lookupVarEnv fvs id)
 826
 827 lookupFVInfo :: FreeVarsInfo -> Id -> StgBinderInfo
 828 lookupFVInfo fvs id = case lookupVarEnv fvs id of
 829                         Nothing         -> NoStgBinderInfo
 830                         Just (_,_,info) -> info
 831
 832 getFVs :: FreeVarsInfo -> [Id]  -- Non-top-level things only
 833 getFVs fvs = [id | (id,False,_) <- rngVarEnv fvs]
 834
 835 getFVSet :: FreeVarsInfo -> IdSet
 836 getFVSet fvs = mkVarSet (getFVs fvs)
 837
 838 plusFVInfo (id1,top1,info1) (id2,top2,info2)
 839   = ASSERT (id1 == id2 && top1 == top2)
 840     (id1, top1, combineStgBinderInfo info1 info2)
 841 \end{code}
 842
 843 \begin{code}
 844 rhsArity :: StgRhs -> Arity
 845 rhsArity (StgRhsCon _ _ _)              = 0
 846 rhsArity (StgRhsClosure _ _ _ _ _ args _) = length args
 847
 848 zapArity :: Id -> Id
 849 zapArity id = id `setIdArityInfo` UnknownArity
 850 \end{code}
 851
 852
 853