ghc/compiler/simplStg/StgVarInfo.lhs

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