ghc/compiler/simplStg/StgVarInfo.lhs

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