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