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