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               ( setIdArityInfo, idArity, setIdOccInfo, Id )
  17 import VarSet
  18 import VarEnv
  19 import Var
  20 import IdInfo           ( ArityInfo(..), OccInfo(..),
  21                           setInlinePragInfo )
  22 import PrimOp           ( PrimOp(..), ccallMayGC )
  23 import TysWiredIn       ( isForeignObjTy )
  24 import Maybes           ( maybeToBool, orElse )
  25 import Name             ( isLocallyDefined, 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 ty 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 ty 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 ty 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 ty 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    | isForeignObjTy (idType x) = extendVarSet lvs x
 419    | otherwise                 = lvs
 420 findLiveArgs lvs arg           = lvs
 421 \end{code}
 422
 423
 424 Applications:
 425 \begin{code}
 426 varsApp :: Maybe UpdateFlag             -- Just upd <=> this application is
 427                                         -- the rhs of a thunk binding
 428                                         --      x = [...] \upd [] -> the_app
 429                                         -- with specified update flag
 430         -> Id                           -- Function
 431         -> [StgArg]             -- Arguments
 432         -> LneM (StgExpr, FreeVarsInfo, EscVarsSet)
 433
 434 varsApp maybe_thunk_body f args
 435   = getVarsLiveInCont           `thenLne` \ live_in_cont ->
 436
 437     varsAtoms args              `thenLne` \ (args', args_fvs) ->
 438
 439     lookupVarLne f              `thenLne` \ (f', how_bound) ->
 440
 441     let
 442         n_args           = length args
 443         not_letrec_bound = not (isLetrecBound how_bound)
 444         f_arity          = idArity f'   -- Will have an exact arity by now
 445         fun_fvs          = singletonFVInfo f' how_bound fun_occ
 446
 447         fun_occ
 448           | not_letrec_bound = NoStgBinderInfo          -- Uninteresting variable
 449
 450                 -- Otherwise it is letrec bound; must have its arity
 451           | n_args == 0 = stgFakeFunAppOcc      -- Function Application
 452                                                 -- with no arguments.
 453                                                 -- used by the lambda lifter.
 454           | f_arity > n_args = stgUnsatOcc      -- Unsaturated
 455
 456
 457           | f_arity == n_args &&
 458             maybeToBool maybe_thunk_body        -- Exactly saturated,
 459                                                 -- and rhs of thunk
 460           = case maybe_thunk_body of
 461                 Just Updatable   -> stgStdHeapOcc
 462                 Just SingleEntry -> stgNoUpdHeapOcc
 463                 other            -> panic "varsApp"
 464
 465           | otherwise =  stgNormalOcc
 466                                 -- Record only that it occurs free
 467
 468         myself = unitVarSet f'
 469
 470         fun_escs | not_letrec_bound  = emptyVarSet      -- Only letrec-bound escapees are interesting
 471                  | f_arity == n_args = emptyVarSet      -- Function doesn't escape
 472                  | otherwise         = myself           -- Inexact application; it does escape
 473
 474         -- At the moment of the call:
 475
 476         --  either the function is *not* let-no-escaped, in which case
 477         --         nothing is live except live_in_cont
 478         --      or the function *is* let-no-escaped in which case the
 479         --         variables it uses are live, but still the function
 480         --         itself is not.  PS.  In this case, the function's
 481         --         live vars should already include those of the
 482         --         continuation, but it does no harm to just union the
 483         --         two regardless.
 484
 485         -- XXX not needed?
 486         -- live_at_call
 487         --   = live_in_cont `unionVarSet` case how_bound of
 488         --                            LetrecBound _ lvs -> lvs `minusVarSet` myself
 489         --                         other             -> emptyVarSet
 490     in
 491     returnLne (
 492         StgApp f' args',
 493         fun_fvs  `unionFVInfo` args_fvs,
 494         fun_escs `unionVarSet` (getFVSet args_fvs)
 495                                 -- All the free vars of the args are disqualified
 496                                 -- from being let-no-escaped.
 497     )
 498 \end{code}
 499
 500 The magic for lets:
 501 \begin{code}
 502 vars_let :: Bool                -- True <=> yes, we are let-no-escaping this let
 503          -> StgBinding  -- bindings
 504          -> StgExpr     -- body
 505          -> LneM (StgExpr,      -- new let
 506                   FreeVarsInfo, -- variables free in the whole let
 507                   EscVarsSet,   -- variables that escape from the whole let
 508                   Bool)         -- True <=> none of the binders in the bindings
 509                                 -- is among the escaping vars
 510
 511 vars_let let_no_escape bind body
 512   = fixLne (\ ~(_, _, _, rec_bind_lvs, _, rec_body_fvs, _, _) ->
 513
 514         -- Do the bindings, setting live_in_cont to empty if
 515         -- we ain't in a let-no-escape world
 516         getVarsLiveInCont               `thenLne` \ live_in_cont ->
 517         setVarsLiveInCont
 518                 (if let_no_escape then live_in_cont else emptyVarSet)
 519                 (vars_bind rec_bind_lvs rec_body_fvs bind)
 520                                         `thenLne` \ (bind2, bind_fvs, bind_escs, env_ext) ->
 521
 522         -- The live variables of this binding are the ones which are live
 523         -- by virtue of being accessible via the free vars of the binding (lvs_from_fvs)
 524         -- together with the live_in_cont ones
 525         lookupLiveVarsForSet (bind_fvs `minusFVBinders` binders)        `thenLne` \ lvs_from_fvs ->
 526         let
 527                 bind_lvs = lvs_from_fvs `unionVarSet` live_in_cont
 528         in
 529
 530         -- bind_fvs and bind_escs still include the binders of the let(rec)
 531         -- but bind_lvs does not
 532
 533         -- Do the body
 534         extendVarEnvLne env_ext (
 535                 varsExpr body                   `thenLne` \ (body2, body_fvs, body_escs) ->
 536                 lookupLiveVarsForSet body_fvs   `thenLne` \ body_lvs ->
 537
 538                 returnLne (bind2, bind_fvs, bind_escs, bind_lvs,
 539                            body2, body_fvs, body_escs, body_lvs)
 540
 541     )) `thenLne` (\ (bind2, bind_fvs, bind_escs, bind_lvs,
 542                      body2, body_fvs, body_escs, body_lvs) ->
 543
 544
 545         -- Compute the new let-expression
 546     let
 547         new_let | let_no_escape = StgLetNoEscape live_in_whole_let bind_lvs bind2 body2
 548                 | otherwise     = StgLet bind2 body2
 549
 550         free_in_whole_let
 551           = (bind_fvs `unionFVInfo` body_fvs) `minusFVBinders` binders
 552
 553         live_in_whole_let
 554           = bind_lvs `unionVarSet` (body_lvs `minusVarSet` set_of_binders)
 555
 556         real_bind_escs = if let_no_escape then
 557                             bind_escs
 558                          else
 559                             getFVSet bind_fvs
 560                             -- Everything escapes which is free in the bindings
 561
 562         let_escs = (real_bind_escs `unionVarSet` body_escs) `minusVarSet` set_of_binders
 563
 564         all_escs = bind_escs `unionVarSet` body_escs    -- Still includes binders of
 565                                                 -- this let(rec)
 566
 567         no_binder_escapes = isEmptyVarSet (set_of_binders `intersectVarSet` all_escs)
 568
 569 #ifdef DEBUG
 570         -- Debugging code as requested by Andrew Kennedy
 571         checked_no_binder_escapes
 572                 | not no_binder_escapes && any is_join_var binders
 573                 = pprTrace "Interesting!  A join var that isn't let-no-escaped" (ppr binders)
 574                   False
 575                 | otherwise = no_binder_escapes
 576 #else
 577         checked_no_binder_escapes = no_binder_escapes
 578 #endif
 579
 580                 -- Mustn't depend on the passed-in let_no_escape flag, since
 581                 -- no_binder_escapes is used by the caller to derive the flag!
 582     in
 583     returnLne (
 584         new_let,
 585         free_in_whole_let,
 586         let_escs,
 587         checked_no_binder_escapes
 588     ))
 589   where
 590     set_of_binders = mkVarSet binders
 591     binders        = case bind of
 592                         StgNonRec binder rhs -> [binder]
 593                         StgRec pairs         -> map fst pairs
 594
 595     mk_binding bind_lvs (binder,rhs)
 596         = (binder `setIdArityInfo` ArityExactly (stgArity rhs),
 597            LetrecBound  False           -- Not top level
 598                         live_vars
 599           )
 600         where
 601            live_vars = if let_no_escape then
 602                             extendVarSet bind_lvs binder
 603                        else
 604                             unitVarSet binder
 605
 606     vars_bind :: StgLiveVars
 607               -> FreeVarsInfo                   -- Free var info for body of binding
 608               -> StgBinding
 609               -> LneM (StgBinding,
 610                        FreeVarsInfo, EscVarsSet,        -- free vars; escapee vars
 611                        [(Id, HowBound)])
 612                                          -- extension to environment
 613
 614     vars_bind rec_bind_lvs rec_body_fvs (StgNonRec binder rhs)
 615       = varsRhs rec_body_fvs (binder,rhs)       `thenLne` \ (rhs2, fvs, escs) ->
 616         let
 617             env_ext_item@(binder', _) = mk_binding rec_bind_lvs (binder,rhs)
 618         in
 619         returnLne (StgNonRec binder' rhs2, fvs, escs, [env_ext_item])
 620
 621     vars_bind rec_bind_lvs rec_body_fvs (StgRec pairs)
 622       = let
 623             env_ext  = map (mk_binding rec_bind_lvs) pairs
 624             binders' = map fst env_ext
 625         in
 626         extendVarEnvLne env_ext           (
 627         fixLne (\ ~(_, rec_rhs_fvs, _, _) ->
 628                 let
 629                         rec_scope_fvs = unionFVInfo rec_body_fvs rec_rhs_fvs
 630                 in
 631                 mapAndUnzip3Lne (varsRhs rec_scope_fvs) pairs `thenLne` \ (rhss2, fvss, escss) ->
 632                 let
 633                         fvs  = unionFVInfos      fvss
 634                         escs = unionVarSets escss
 635                 in
 636                 returnLne (StgRec (binders' `zip` rhss2), fvs, escs, env_ext)
 637         ))
 638
 639 is_join_var :: Id -> Bool
 640 -- A hack (used only for compiler debuggging) to tell if
 641 -- a variable started life as a join point ($j)
 642 is_join_var j = occNameUserString (getOccName j) == "$j"
 643 \end{code}
 644
 645 %************************************************************************
 646 %*                                                                      *
 647 \subsection[LNE-monad]{A little monad for this let-no-escaping pass}
 648 %*                                                                      *
 649 %************************************************************************
 650
 651 There's a lot of stuff to pass around, so we use this @LneM@ monad to
 652 help.  All the stuff here is only passed {\em down}.
 653
 654 \begin{code}
 655 type LneM a =  Bool                     -- True <=> do let-no-escapes
 656             -> IdEnv (Id, HowBound)     -- Use the Id at all occurrences; it has correct
 657                                         --      arity information inside it.
 658             -> StgLiveVars              -- vars live in continuation
 659             -> a
 660
 661 data HowBound
 662   = ImportBound
 663   | CaseBound
 664   | LambdaBound
 665   | LetrecBound
 666         Bool            -- True <=> bound at top level
 667         StgLiveVars     -- Live vars... see notes below
 668
 669 isLetrecBound (LetrecBound _ _) = True
 670 isLetrecBound other             = False
 671 \end{code}
 672
 673 For a let(rec)-bound variable, x,  we record what varibles are live if
 674 x is live.  For "normal" variables that is just x alone.  If x is
 675 a let-no-escaped variable then x is represented by a code pointer and
 676 a stack pointer (well, one for each stack).  So all of the variables
 677 needed in the execution of x are live if x is, and are therefore recorded
 678 in the LetrecBound constructor; x itself *is* included.
 679
 680 The std monad functions:
 681 \begin{code}
 682 initLne :: Bool -> LneM a -> a
 683 initLne want_LNEs m = m want_LNEs emptyVarEnv emptyVarSet
 684
 685 {-# INLINE thenLne #-}
 686 {-# INLINE thenLne_ #-}
 687 {-# INLINE returnLne #-}
 688
 689 returnLne :: a -> LneM a
 690 returnLne e sw env lvs_cont = e
 691
 692 thenLne :: LneM a -> (a -> LneM b) -> LneM b
 693 thenLne m k sw env lvs_cont
 694   = case (m sw env lvs_cont) of
 695       m_result -> k m_result sw env lvs_cont
 696
 697 thenLne_ :: LneM a -> LneM b -> LneM b
 698 thenLne_ m k sw env lvs_cont
 699   = case (m sw env lvs_cont) of
 700       _ -> k sw env lvs_cont
 701
 702 mapLne  :: (a -> LneM b)   -> [a] -> LneM [b]
 703 mapLne f [] = returnLne []
 704 mapLne f (x:xs)
 705   = f x         `thenLne` \ r  ->
 706     mapLne f xs `thenLne` \ rs ->
 707     returnLne (r:rs)
 708
 709 mapAndUnzipLne  :: (a -> LneM (b,c))   -> [a] -> LneM ([b],[c])
 710
 711 mapAndUnzipLne f [] = returnLne ([],[])
 712 mapAndUnzipLne f (x:xs)
 713   = f x                 `thenLne` \ (r1,  r2)  ->
 714     mapAndUnzipLne f xs `thenLne` \ (rs1, rs2) ->
 715     returnLne (r1:rs1, r2:rs2)
 716
 717 mapAndUnzip3Lne :: (a -> LneM (b,c,d)) -> [a] -> LneM ([b],[c],[d])
 718
 719 mapAndUnzip3Lne f []    = returnLne ([],[],[])
 720 mapAndUnzip3Lne f (x:xs)
 721   = f x                  `thenLne` \ (r1,  r2,  r3)  ->
 722     mapAndUnzip3Lne f xs `thenLne` \ (rs1, rs2, rs3) ->
 723     returnLne (r1:rs1, r2:rs2, r3:rs3)
 724
 725 fixLne :: (a -> LneM a) -> LneM a
 726 fixLne expr sw env lvs_cont = result
 727   where
 728     result = expr result sw env lvs_cont
 729 --  ^^^^^^ ------ ^^^^^^
 730 \end{code}
 731
 732 Functions specific to this monad:
 733 \begin{code}
 734 isSwitchSetLne :: LneM Bool
 735 isSwitchSetLne want_LNEs env lvs_cont
 736   = want_LNEs
 737
 738 getVarsLiveInCont :: LneM StgLiveVars
 739 getVarsLiveInCont sw env lvs_cont = lvs_cont
 740
 741 setVarsLiveInCont :: StgLiveVars -> LneM a -> LneM a
 742 setVarsLiveInCont new_lvs_cont expr sw env lvs_cont
 743   = expr sw env new_lvs_cont
 744
 745 extendVarEnvLne :: [(Id, HowBound)] -> LneM a -> LneM a
 746 extendVarEnvLne ids_w_howbound expr sw env lvs_cont
 747   = expr sw (extendVarEnvList env [(id, pair) | pair@(id,_) <- ids_w_howbound]) lvs_cont
 748
 749
 750 lookupVarLne :: Id -> LneM (Id, HowBound)
 751 lookupVarLne v sw env lvs_cont
 752   = returnLne (
 753       case (lookupVarEnv env v) of
 754         Just xx -> xx
 755         Nothing -> --false:ASSERT(not (isLocallyDefined v))
 756                    (v, ImportBound)
 757     ) sw env lvs_cont
 758
 759 -- The result of lookupLiveVarsForSet, a set of live variables, is
 760 -- only ever tacked onto a decorated expression. It is never used as
 761 -- the basis of a control decision, which might give a black hole.
 762
 763 lookupLiveVarsForSet :: FreeVarsInfo -> LneM StgLiveVars
 764
 765 lookupLiveVarsForSet fvs sw env lvs_cont
 766   = returnLne (unionVarSets (map do_one (getFVs fvs)))
 767               sw env lvs_cont
 768   where
 769     do_one v
 770       = if isLocallyDefined v then
 771             case (lookupVarEnv env v) of
 772               Just (_, LetrecBound _ lvs) -> extendVarSet lvs v
 773               Just _                        -> unitVarSet v
 774               Nothing -> pprPanic "lookupVarEnv/do_one:" (ppr v)
 775         else
 776             emptyVarSet
 777 \end{code}
 778
 779
 780 %************************************************************************
 781 %*                                                                      *
 782 \subsection[Free-var info]{Free variable information}
 783 %*                                                                      *
 784 %************************************************************************
 785
 786 \begin{code}
 787 type FreeVarsInfo = IdEnv (Id, Bool, StgBinderInfo)
 788                         -- If f is mapped to NoStgBinderInfo, that means
 789                         -- that f *is* mentioned (else it wouldn't be in the
 790                         -- IdEnv at all), but only in a saturated applications.
 791                         --
 792                         -- All case/lambda-bound things are also mapped to
 793                         -- NoStgBinderInfo, since we aren't interested in their
 794                         -- occurence info.
 795                         --
 796                         -- The Bool is True <=> the Id is top level letrec bound
 797
 798 type EscVarsSet   = IdSet
 799 \end{code}
 800
 801 \begin{code}
 802 emptyFVInfo :: FreeVarsInfo
 803 emptyFVInfo = emptyVarEnv
 804
 805 singletonFVInfo :: Id -> HowBound -> StgBinderInfo -> FreeVarsInfo
 806 singletonFVInfo id ImportBound               info = emptyVarEnv
 807 singletonFVInfo id (LetrecBound top_level _) info = unitVarEnv id (id, top_level, info)
 808 singletonFVInfo id other                     info = unitVarEnv id (id, False,     info)
 809
 810 unionFVInfo :: FreeVarsInfo -> FreeVarsInfo -> FreeVarsInfo
 811 unionFVInfo fv1 fv2 = plusVarEnv_C plusFVInfo fv1 fv2
 812
 813 unionFVInfos :: [FreeVarsInfo] -> FreeVarsInfo
 814 unionFVInfos fvs = foldr unionFVInfo emptyFVInfo fvs
 815
 816 minusFVBinders :: FreeVarsInfo -> [Id] -> FreeVarsInfo
 817 minusFVBinders fv ids = fv `delVarEnvList` ids
 818
 819 elementOfFVInfo :: Id -> FreeVarsInfo -> Bool
 820 elementOfFVInfo id fvs = maybeToBool (lookupVarEnv fvs id)
 821
 822 lookupFVInfo :: FreeVarsInfo -> Id -> StgBinderInfo
 823 lookupFVInfo fvs id = case lookupVarEnv fvs id of
 824                         Nothing         -> NoStgBinderInfo
 825                         Just (_,_,info) -> info
 826
 827 getFVs :: FreeVarsInfo -> [Id]  -- Non-top-level things only
 828 getFVs fvs = [id | (id,False,_) <- rngVarEnv fvs]
 829
 830 getFVSet :: FreeVarsInfo -> IdSet
 831 getFVSet fvs = mkVarSet (getFVs fvs)
 832
 833 plusFVInfo (id1,top1,info1) (id2,top2,info2)
 834   = ASSERT (id1 == id2 && top1 == top2)
 835     (id1, top1, combineStgBinderInfo info1 info2)
 836 \end{code}
 837
 838 \begin{code}
 839 rhsArity :: StgRhs -> Arity
 840 rhsArity (StgRhsCon _ _ _)              = 0
 841 rhsArity (StgRhsClosure _ _ _ _ _ args _) = length args
 842
 843 zapArity :: Id -> Id
 844 zapArity id = id `setIdArityInfo` UnknownArity
 845 \end{code}
 846
 847
 848