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