ghc/compiler/stgSyn/CoreToStg.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1993-1998
   3 %
   4 \section[CoreToStg]{Converts Core to STG Syntax}
   5
   6 And, as we have the info in hand, we may convert some lets to
   7 let-no-escapes.
   8
   9 \begin{code}
  10 module CoreToStg ( coreToStg, coreExprToStg ) where
  11
  12 #include "HsVersions.h"
  13
  14 import CoreSyn
  15 import CoreFVs
  16 import CoreUtils
  17 import SimplUtils
  18 import StgSyn
  19
  20 import Type
  21 import TyCon            ( isAlgTyCon )
  22 import Id
  23 import IdInfo
  24 import DataCon
  25 import CostCentre       ( noCCS )
  26 import VarSet
  27 import VarEnv
  28 import DataCon          ( dataConWrapId )
  29 import IdInfo           ( OccInfo(..) )
  30 import PrimOp           ( PrimOp(..), ccallMayGC )
  31 import TysPrim          ( foreignObjPrimTyCon )
  32 import Maybes           ( maybeToBool, orElse )
  33 import Name             ( getOccName )
  34 import Module           ( Module )
  35 import OccName          ( occNameUserString )
  36 import BasicTypes       ( TopLevelFlag(..), isNotTopLevel )
  37 import CmdLineOpts      ( DynFlags )
  38 import Outputable
  39
  40 infixr 9 `thenLne`, `thenLne_`
  41 \end{code}
  42
  43 %************************************************************************
  44 %*                                                                      *
  45 \subsection[live-vs-free-doc]{Documentation}
  46 %*                                                                      *
  47 %************************************************************************
  48
  49 (There is other relevant documentation in codeGen/CgLetNoEscape.)
  50
  51 The actual Stg datatype is decorated with {\em live variable}
  52 information, as well as {\em free variable} information.  The two are
  53 {\em not} the same.  Liveness is an operational property rather than a
  54 semantic one.  A variable is live at a particular execution point if
  55 it can be referred to {\em directly} again.  In particular, a dead
  56 variable's stack slot (if it has one):
  57 \begin{enumerate}
  58 \item
  59 should be stubbed to avoid space leaks, and
  60 \item
  61 may be reused for something else.
  62 \end{enumerate}
  63
  64 There ought to be a better way to say this.  Here are some examples:
  65 \begin{verbatim}
  66         let v = [q] \[x] -> e
  67         in
  68         ...v...  (but no q's)
  69 \end{verbatim}
  70
  71 Just after the `in', v is live, but q is dead.  If the whole of that
  72 let expression was enclosed in a case expression, thus:
  73 \begin{verbatim}
  74         case (let v = [q] \[x] -> e in ...v...) of
  75                 alts[...q...]
  76 \end{verbatim}
  77 (ie @alts@ mention @q@), then @q@ is live even after the `in'; because
  78 we'll return later to the @alts@ and need it.
  79
  80 Let-no-escapes make this a bit more interesting:
  81 \begin{verbatim}
  82         let-no-escape v = [q] \ [x] -> e
  83         in
  84         ...v...
  85 \end{verbatim}
  86 Here, @q@ is still live at the `in', because @v@ is represented not by
  87 a closure but by the current stack state.  In other words, if @v@ is
  88 live then so is @q@.  Furthermore, if @e@ mentions an enclosing
  89 let-no-escaped variable, then {\em its} free variables are also live
  90 if @v@ is.
  91
  92 %************************************************************************
  93 %*                                                                      *
  94 \subsection[binds-StgVarInfo]{Setting variable info: top-level, binds, RHSs}
  95 %*                                                                      *
  96 %************************************************************************
  97
  98 \begin{code}
  99 coreToStg :: DynFlags -> Module -> [CoreBind] -> IO [StgBinding]
 100 coreToStg dflags this_mod pgm
 101   = return (fst (initLne (coreTopBindsToStg pgm)))
 102
 103 coreExprToStg :: CoreExpr -> StgExpr
 104 coreExprToStg expr
 105   = new_expr where (new_expr,_,_) = initLne (coreToStgExpr expr)
 106
 107 -- For top-level guys, we basically aren't worried about this
 108 -- live-variable stuff; we do need to keep adding to the environment
 109 -- as we step through the bindings (using @extendVarEnv@).
 110
 111 coreTopBindsToStg :: [CoreBind] -> LneM ([StgBinding], FreeVarsInfo)
 112
 113 coreTopBindsToStg [] = returnLne ([], emptyFVInfo)
 114 coreTopBindsToStg (bind:binds)
 115   =  let
 116          binders = bindersOf bind
 117          env_extension = binders `zip` repeat how_bound
 118          how_bound = LetrecBound True {- top level -}
 119                                  emptyVarSet
 120      in
 121
 122      extendVarEnvLne env_extension (
 123        coreTopBindsToStg binds                 `thenLne` \ (binds', fv_binds) ->
 124        coreTopBindToStg binders fv_binds bind  `thenLne` \ (bind',  fv_bind) ->
 125        returnLne (
 126                   (bind' : binds'),
 127                   (fv_binds `unionFVInfo` fv_bind) `minusFVBinders` binders
 128                  )
 129       )
 130
 131
 132 coreTopBindToStg
 133         :: [Id]                 -- New binders (with correct arity)
 134         -> FreeVarsInfo         -- Info about the body
 135         -> CoreBind
 136         -> LneM (StgBinding, FreeVarsInfo)
 137
 138 coreTopBindToStg [binder] body_fvs (NonRec _ rhs)
 139   = coreToStgRhs body_fvs TopLevel (binder,rhs) `thenLne` \ (rhs2, fvs, _) ->
 140     returnLne (StgNonRec binder rhs2, fvs)
 141
 142 coreTopBindToStg binders body_fvs (Rec pairs)
 143   = fixLne (\ ~(_, rec_rhs_fvs) ->
 144         let scope_fvs = unionFVInfo body_fvs rec_rhs_fvs
 145         in
 146         mapAndUnzip3Lne (coreToStgRhs scope_fvs TopLevel) pairs
 147                                                 `thenLne` \ (rhss2, fvss, _) ->
 148         let fvs = unionFVInfos fvss
 149         in
 150         returnLne (StgRec (binders `zip` rhss2), fvs)
 151     )
 152 \end{code}
 153
 154 \begin{code}
 155 coreToStgRhs
 156         :: FreeVarsInfo         -- Free var info for the scope of the binding
 157         -> TopLevelFlag
 158         -> (Id,CoreExpr)
 159         -> LneM (StgRhs, FreeVarsInfo, EscVarsSet)
 160
 161 coreToStgRhs scope_fv_info top (binder, rhs)
 162   = coreToStgExpr rhs  `thenLne` \ (new_rhs, rhs_fvs, rhs_escs) ->
 163     case new_rhs of
 164
 165            StgLam _ bndrs body
 166                -> let binder_info = lookupFVInfo scope_fv_info binder
 167                   in  returnLne (StgRhsClosure noCCS
 168                                                binder_info
 169                                                noSRT
 170                                                (getFVs rhs_fvs)
 171                                                ReEntrant
 172                                                bndrs
 173                                                body,
 174                                 rhs_fvs, rhs_escs)
 175
 176            StgConApp con args
 177             | isNotTopLevel top || not (isDllConApp con args)
 178                -> returnLne (StgRhsCon noCCS con args, rhs_fvs, rhs_escs)
 179
 180            _other_expr
 181                -> let binder_info = lookupFVInfo scope_fv_info binder
 182                   in  returnLne (StgRhsClosure noCCS
 183                                                binder_info
 184                                                noSRT
 185                                                (getFVs rhs_fvs)
 186                                                (updatable [] new_rhs)
 187                                                []
 188                                                new_rhs,
 189                                  rhs_fvs, rhs_escs
 190                                 )
 191
 192 updatable args body   | null args && isPAP body  = ReEntrant
 193                       | otherwise                = Updatable
 194 {- ToDo:
 195           upd = if isOnceDem dem
 196                     then (if isNotTop toplev
 197                             then SingleEntry    -- HA!  Paydirt for "dem"
 198                             else
 199 #ifdef DEBUG
 200                      trace "WARNING: SE CAFs unsupported, forcing UPD instead" $
 201 #endif
 202                      Updatable)
 203                 else Updatable
 204         -- For now we forbid SingleEntry CAFs; they tickle the
 205         -- ASSERT in rts/Storage.c line 215 at newCAF() re mut_link,
 206         -- and I don't understand why.  There's only one SE_CAF (well,
 207         -- only one that tickled a great gaping bug in an earlier attempt
 208         -- at ClosureInfo.getEntryConvention) in the whole of nofib,
 209         -- specifically Main.lvl6 in spectral/cryptarithm2.
 210         -- So no great loss.  KSW 2000-07.
 211 -}
 212 \end{code}
 213
 214 Detect thunks which will reduce immediately to PAPs, and make them
 215 non-updatable.  This has several advantages:
 216
 217         - the non-updatable thunk behaves exactly like the PAP,
 218
 219         - the thunk is more efficient to enter, because it is
 220           specialised to the task.
 221
 222         - we save one update frame, one stg_update_PAP, one update
 223           and lots of PAP_enters.
 224
 225         - in the case where the thunk is top-level, we save building
 226           a black hole and futhermore the thunk isn't considered to
 227           be a CAF any more, so it doesn't appear in any SRTs.
 228
 229 We do it here, because the arity information is accurate, and we need
 230 to do it before the SRT pass to save the SRT entries associated with
 231 any top-level PAPs.
 232
 233 \begin{code}
 234 isPAP (StgApp f args) = idArity f > length args
 235 isPAP _               = False
 236
 237 -- ---------------------------------------------------------------------------
 238 -- Atoms
 239 -- ---------------------------------------------------------------------------
 240
 241 coreToStgAtoms  :: [CoreArg] -> LneM ([StgArg], FreeVarsInfo)
 242 coreToStgAtoms atoms
 243   = let val_atoms = filter isValArg atoms in
 244     mapAndUnzipLne coreToStgAtom val_atoms `thenLne` \ (args', fvs_lists) ->
 245     returnLne (args', unionFVInfos fvs_lists)
 246   where
 247     coreToStgAtom e
 248         = coreToStgExpr e `thenLne` \ (expr, fvs, escs) ->
 249           case expr of
 250              StgApp v []      -> returnLne (StgVarArg v, fvs)
 251              StgConApp con [] -> returnLne (StgVarArg (dataConWrapId con), fvs)
 252              StgLit lit       -> returnLne (StgLitArg lit, fvs)
 253              _ -> pprPanic "coreToStgAtom" (ppr expr)
 254
 255 -- ---------------------------------------------------------------------------
 256 -- Expressions
 257 -- ---------------------------------------------------------------------------
 258
 259 {-
 260 @varsExpr@ carries in a monad-ised environment, which binds each
 261 let(rec) variable (ie non top level, not imported, not lambda bound,
 262 not case-alternative bound) to:
 263         - its STG arity, and
 264         - its set of live vars.
 265 For normal variables the set of live vars is just the variable
 266 itself.  For let-no-escaped variables, the set of live vars is the set
 267 live at the moment the variable is entered.  The set is guaranteed to
 268 have no further let-no-escaped vars in it.
 269 -}
 270
 271 coreToStgExpr
 272         :: CoreExpr
 273         -> LneM (StgExpr,       -- Decorated STG expr
 274                  FreeVarsInfo,  -- Its free vars (NB free, not live)
 275                  EscVarsSet)    -- Its escapees, a subset of its free vars;
 276                                 -- also a subset of the domain of the envt
 277                                 -- because we are only interested in the escapees
 278                                 -- for vars which might be turned into
 279                                 -- let-no-escaped ones.
 280 \end{code}
 281
 282 The second and third components can be derived in a simple bottom up pass, not
 283 dependent on any decisions about which variables will be let-no-escaped or
 284 not.  The first component, that is, the decorated expression, may then depend
 285 on these components, but it in turn is not scrutinised as the basis for any
 286 decisions.  Hence no black holes.
 287
 288 \begin{code}
 289 coreToStgExpr (Lit l)           = returnLne (StgLit l, emptyFVInfo, emptyVarSet)
 290
 291 coreToStgExpr (Var v)
 292   = coreToStgApp Nothing v []
 293
 294 coreToStgExpr expr@(App _ _)
 295   = let (f, args) = myCollectArgs expr
 296     in
 297     coreToStgApp Nothing (shouldBeVar f) args
 298
 299 coreToStgExpr expr@(Lam _ _)
 300   = let (args, body) = myCollectBinders expr
 301         args' = filter isId args
 302     in
 303     extendVarEnvLne [ (a, LambdaBound) | a <- args' ] $
 304     coreToStgExpr body  `thenLne` \ (body, body_fvs, body_escs) ->
 305     let
 306         set_of_args     = mkVarSet args'
 307         fvs             = body_fvs  `minusFVBinders` args'
 308         escs            = body_escs `minusVarSet`    set_of_args
 309     in
 310     if null args'
 311         then returnLne (body, fvs, escs)
 312         else returnLne (StgLam (exprType expr) args' body, fvs, escs)
 313
 314 coreToStgExpr (Note (SCC cc) expr)
 315   = coreToStgExpr expr          `thenLne` ( \ (expr2, fvs, escs) ->
 316     returnLne (StgSCC cc expr2, fvs, escs) )
 317
 318 coreToStgExpr (Note other_note expr)
 319   = coreToStgExpr expr
 320
 321
 322 -- Cases require a little more real work.
 323
 324 coreToStgExpr (Case scrut bndr alts)
 325   = getVarsLiveInCont                                   `thenLne` \ live_in_cont ->
 326     extendVarEnvLne [(bndr, CaseBound)] $
 327     vars_alts (findDefault alts)                        `thenLne` \ (alts2, alts_fvs, alts_escs) ->
 328     lookupLiveVarsForSet alts_fvs                       `thenLne` \ alts_lvs ->
 329     let
 330         -- determine whether the default binder is dead or not
 331         bndr'= if (bndr `elementOfFVInfo` alts_fvs)
 332                   then bndr `setIdOccInfo` NoOccInfo
 333                   else bndr `setIdOccInfo` IAmDead
 334
 335          -- for a _ccall_GC_, some of the *arguments* need to live across the
 336          -- call (see findLiveArgs comments.), so we annotate them as being live
 337          -- in the alts to achieve the desired effect.
 338         mb_live_across_case =
 339           case scrut of
 340             -- ToDo: Notes?
 341             e@(App _ _) | (Var v, args) <- myCollectArgs e,
 342                           PrimOpId (CCallOp ccall) <- idFlavour v,
 343                           ccallMayGC ccall
 344                           -> Just (filterVarSet isForeignObjArg (exprFreeVars e))
 345             _   -> Nothing
 346
 347         -- Don't consider the default binder as being 'live in alts',
 348         -- since this is from the point of view of the case expr, where
 349         -- the default binder is not free.
 350         live_in_alts = orElse (FMAP unionVarSet mb_live_across_case) id $
 351                        live_in_cont `unionVarSet`
 352                        (alts_lvs `minusVarSet` unitVarSet bndr)
 353     in
 354         -- we tell the scrutinee that everything live in the alts
 355         -- is live in it, too.
 356     setVarsLiveInCont live_in_alts (
 357         coreToStgExpr scrut
 358     )                      `thenLne` \ (scrut2, scrut_fvs, scrut_escs) ->
 359
 360     lookupLiveVarsForSet scrut_fvs `thenLne` \ scrut_lvs ->
 361     let
 362         live_in_whole_case = live_in_alts `unionVarSet` scrut_lvs
 363     in
 364     returnLne (
 365       StgCase scrut2 live_in_whole_case live_in_alts bndr' noSRT alts2,
 366       (scrut_fvs `unionFVInfo` alts_fvs) `minusFVBinders` [bndr],
 367       (alts_escs `minusVarSet` unitVarSet bndr) `unionVarSet` getFVSet scrut_fvs
 368                 -- You might think we should have scrut_escs, not (getFVSet scrut_fvs),
 369                 -- but actually we can't call, and then return from, a let-no-escape thing.
 370       )
 371   where
 372     scrut_ty   = idType bndr
 373     prim_case  = isUnLiftedType scrut_ty && not (isUnboxedTupleType scrut_ty)
 374
 375     vars_alts (alts,deflt)
 376         | prim_case
 377         = mapAndUnzip3Lne vars_prim_alt alts
 378                         `thenLne` \ (alts2,  alts_fvs_list,  alts_escs_list) ->
 379           let
 380               alts_fvs  = unionFVInfos alts_fvs_list
 381               alts_escs = unionVarSets alts_escs_list
 382           in
 383           vars_deflt deflt `thenLne` \ (deflt2, deflt_fvs, deflt_escs) ->
 384           returnLne (
 385               mkStgPrimAlts scrut_ty alts2 deflt2,
 386               alts_fvs  `unionFVInfo`   deflt_fvs,
 387               alts_escs `unionVarSet` deflt_escs
 388           )
 389
 390         | otherwise
 391         = mapAndUnzip3Lne vars_alg_alt alts
 392                         `thenLne` \ (alts2,  alts_fvs_list,  alts_escs_list) ->
 393           let
 394               alts_fvs  = unionFVInfos alts_fvs_list
 395               alts_escs = unionVarSets alts_escs_list
 396           in
 397           vars_deflt deflt `thenLne` \ (deflt2, deflt_fvs, deflt_escs) ->
 398           returnLne (
 399               mkStgAlgAlts scrut_ty alts2 deflt2,
 400               alts_fvs  `unionFVInfo`   deflt_fvs,
 401               alts_escs `unionVarSet` deflt_escs
 402           )
 403
 404       where
 405         vars_prim_alt (LitAlt lit, _, rhs)
 406           = coreToStgExpr rhs   `thenLne` \ (rhs2, rhs_fvs, rhs_escs) ->
 407             returnLne ((lit, rhs2), rhs_fvs, rhs_escs)
 408
 409         vars_alg_alt (DataAlt con, binders, rhs)
 410           = extendVarEnvLne [(b, CaseBound) | b <- binders]     $
 411             coreToStgExpr rhs   `thenLne` \ (rhs2, rhs_fvs, rhs_escs) ->
 412             let
 413                 good_use_mask = [ b `elementOfFVInfo` rhs_fvs | b <- binders ]
 414                 -- records whether each param is used in the RHS
 415             in
 416             returnLne (
 417                 (con, binders, good_use_mask, rhs2),
 418                 rhs_fvs  `minusFVBinders` binders,
 419                 rhs_escs `minusVarSet`   mkVarSet binders
 420                         -- ToDo: remove the minusVarSet;
 421                         -- since escs won't include any of these binders
 422             )
 423
 424         vars_deflt Nothing
 425            = returnLne (StgNoDefault, emptyFVInfo, emptyVarSet)
 426
 427         vars_deflt (Just rhs)
 428            = coreToStgExpr rhs  `thenLne` \ (rhs2, rhs_fvs, rhs_escs) ->
 429              returnLne (StgBindDefault rhs2, rhs_fvs, rhs_escs)
 430
 431         mkStgAlgAlts ty alts deflt
 432          =  case alts of
 433                         -- Get the tycon from the data con
 434                 (dc, _, _, _) : _rest
 435                     -> StgAlgAlts (Just (dataConTyCon dc)) alts deflt
 436
 437                         -- Otherwise just do your best
 438                 [] -> case splitTyConApp_maybe (repType ty) of
 439                         Just (tc,_) | isAlgTyCon tc
 440                                 -> StgAlgAlts (Just tc) alts deflt
 441                         other
 442                                 -> StgAlgAlts Nothing alts deflt
 443
 444         mkStgPrimAlts ty alts deflt
 445           = StgPrimAlts (tyConAppTyCon ty) alts deflt
 446 \end{code}
 447
 448 Lets not only take quite a bit of work, but this is where we convert
 449 then to let-no-escapes, if we wish.
 450
 451 (Meanwhile, we don't expect to see let-no-escapes...)
 452 \begin{code}
 453 coreToStgExpr (Let bind body)
 454   = fixLne (\ ~(_, _, _, no_binder_escapes) ->
 455         coreToStgLet no_binder_escapes bind body
 456     )                           `thenLne` \ (new_let, fvs, escs, _) ->
 457
 458     returnLne (new_let, fvs, escs)
 459 \end{code}
 460
 461 If we've got a case containing a _ccall_GC_ primop, we need to
 462 ensure that the arguments are kept live for the duration of the
 463 call. This only an issue
 464
 465 \begin{code}
 466 isForeignObjArg :: Id -> Bool
 467 isForeignObjArg x = isId x && isForeignObjPrimTy (idType x)
 468
 469 isForeignObjPrimTy ty
 470    = case splitTyConApp_maybe ty of
 471         Just (tycon, _) -> tycon == foreignObjPrimTyCon
 472         Nothing         -> False
 473 \end{code}
 474
 475
 476 Applications:
 477 \begin{code}
 478 coreToStgApp
 479          :: Maybe UpdateFlag            -- Just upd <=> this application is
 480                                         -- the rhs of a thunk binding
 481                                         --      x = [...] \upd [] -> the_app
 482                                         -- with specified update flag
 483         -> Id                           -- Function
 484         -> [CoreArg]                    -- Arguments
 485         -> LneM (StgExpr, FreeVarsInfo, EscVarsSet)
 486
 487 coreToStgApp maybe_thunk_body f args
 488   = getVarsLiveInCont           `thenLne` \ live_in_cont ->
 489     coreToStgAtoms args         `thenLne` \ (args', args_fvs) ->
 490     lookupVarLne f              `thenLne` \ how_bound ->
 491
 492     let
 493         n_args           = length args
 494         not_letrec_bound = not (isLetrecBound how_bound)
 495         f_arity          = idArity f
 496         fun_fvs          = singletonFVInfo f how_bound fun_occ
 497
 498         fun_occ
 499           | not_letrec_bound = NoStgBinderInfo          -- Uninteresting variable
 500
 501                 -- Otherwise it is letrec bound; must have its arity
 502           | n_args == 0 = stgFakeFunAppOcc      -- Function Application
 503                                                 -- with no arguments.
 504                                                 -- used by the lambda lifter.
 505           | f_arity > n_args = stgUnsatOcc      -- Unsaturated
 506
 507           | f_arity == n_args &&
 508             maybeToBool maybe_thunk_body        -- Exactly saturated,
 509                                                 -- and rhs of thunk
 510           = case maybe_thunk_body of
 511                 Just Updatable   -> stgStdHeapOcc
 512                 Just SingleEntry -> stgNoUpdHeapOcc
 513                 other            -> panic "coreToStgApp"
 514
 515           | otherwise =  stgNormalOcc
 516                                 -- Record only that it occurs free
 517
 518         myself = unitVarSet f
 519
 520         fun_escs | not_letrec_bound  = emptyVarSet
 521                         -- Only letrec-bound escapees are interesting
 522                  | f_arity == n_args = emptyVarSet
 523                         -- Function doesn't escape
 524                  | otherwise         = myself
 525                         -- Inexact application; it does escape
 526
 527         -- At the moment of the call:
 528
 529         --  either the function is *not* let-no-escaped, in which case
 530         --         nothing is live except live_in_cont
 531         --      or the function *is* let-no-escaped in which case the
 532         --         variables it uses are live, but still the function
 533         --         itself is not.  PS.  In this case, the function's
 534         --         live vars should already include those of the
 535         --         continuation, but it does no harm to just union the
 536         --         two regardless.
 537
 538         -- XXX not needed?
 539         -- live_at_call
 540         --   = live_in_cont `unionVarSet` case how_bound of
 541         --                            LetrecBound _ lvs -> lvs `minusVarSet` myself
 542         --                         other             -> emptyVarSet
 543
 544         app = case idFlavour f of
 545                 DataConId dc -> StgConApp dc args'
 546                 PrimOpId op  -> StgPrimApp op args' (exprType (mkApps (Var f) args))
 547                 _other       -> StgApp f args'
 548
 549     in
 550     returnLne (
 551         app,
 552         fun_fvs  `unionFVInfo` args_fvs,
 553         fun_escs `unionVarSet` (getFVSet args_fvs)
 554                                 -- All the free vars of the args are disqualified
 555                                 -- from being let-no-escaped.
 556     )
 557
 558
 559 -- ---------------------------------------------------------------------------
 560 -- The magic for lets:
 561 -- ---------------------------------------------------------------------------
 562
 563 coreToStgLet
 564          :: Bool        -- True <=> yes, we are let-no-escaping this let
 565          -> CoreBind    -- bindings
 566          -> CoreExpr    -- body
 567          -> LneM (StgExpr,      -- new let
 568                   FreeVarsInfo, -- variables free in the whole let
 569                   EscVarsSet,   -- variables that escape from the whole let
 570                   Bool)         -- True <=> none of the binders in the bindings
 571                                 -- is among the escaping vars
 572
 573 coreToStgLet let_no_escape bind body
 574   = fixLne (\ ~(_, _, _, rec_bind_lvs, _, rec_body_fvs, _, _) ->
 575
 576         -- Do the bindings, setting live_in_cont to empty if
 577         -- we ain't in a let-no-escape world
 578         getVarsLiveInCont               `thenLne` \ live_in_cont ->
 579         setVarsLiveInCont
 580                 (if let_no_escape then live_in_cont else emptyVarSet)
 581                 (vars_bind rec_bind_lvs rec_body_fvs bind)
 582                             `thenLne` \ (bind2, bind_fvs, bind_escs, env_ext) ->
 583
 584         -- The live variables of this binding are the ones which are live
 585         -- by virtue of being accessible via the free vars of the binding (lvs_from_fvs)
 586         -- together with the live_in_cont ones
 587         lookupLiveVarsForSet (bind_fvs `minusFVBinders` binders)
 588                                 `thenLne` \ lvs_from_fvs ->
 589         let
 590                 bind_lvs = lvs_from_fvs `unionVarSet` live_in_cont
 591         in
 592
 593         -- bind_fvs and bind_escs still include the binders of the let(rec)
 594         -- but bind_lvs does not
 595
 596         -- Do the body
 597         extendVarEnvLne env_ext (
 598                 coreToStgExpr body                      `thenLne` \ (body2, body_fvs, body_escs) ->
 599                 lookupLiveVarsForSet body_fvs   `thenLne` \ body_lvs ->
 600
 601                 returnLne (bind2, bind_fvs, bind_escs, bind_lvs,
 602                            body2, body_fvs, body_escs, body_lvs)
 603
 604     )) `thenLne` (\ (bind2, bind_fvs, bind_escs, bind_lvs,
 605                      body2, body_fvs, body_escs, body_lvs) ->
 606
 607
 608         -- Compute the new let-expression
 609     let
 610         new_let | let_no_escape = StgLetNoEscape live_in_whole_let bind_lvs bind2 body2
 611                 | otherwise     = StgLet bind2 body2
 612
 613         free_in_whole_let
 614           = (bind_fvs `unionFVInfo` body_fvs) `minusFVBinders` binders
 615
 616         live_in_whole_let
 617           = bind_lvs `unionVarSet` (body_lvs `minusVarSet` set_of_binders)
 618
 619         real_bind_escs = if let_no_escape then
 620                             bind_escs
 621                          else
 622                             getFVSet bind_fvs
 623                             -- Everything escapes which is free in the bindings
 624
 625         let_escs = (real_bind_escs `unionVarSet` body_escs) `minusVarSet` set_of_binders
 626
 627         all_escs = bind_escs `unionVarSet` body_escs    -- Still includes binders of
 628                                                 -- this let(rec)
 629
 630         no_binder_escapes = isEmptyVarSet (set_of_binders `intersectVarSet` all_escs)
 631
 632 #ifdef DEBUG
 633         -- Debugging code as requested by Andrew Kennedy
 634         checked_no_binder_escapes
 635                 | not no_binder_escapes && any is_join_var binders
 636                 = pprTrace "Interesting!  A join var that isn't let-no-escaped" (ppr binders)
 637                   False
 638                 | otherwise = no_binder_escapes
 639 #else
 640         checked_no_binder_escapes = no_binder_escapes
 641 #endif
 642
 643                 -- Mustn't depend on the passed-in let_no_escape flag, since
 644                 -- no_binder_escapes is used by the caller to derive the flag!
 645     in
 646     returnLne (
 647         new_let,
 648         free_in_whole_let,
 649         let_escs,
 650         checked_no_binder_escapes
 651     ))
 652   where
 653     set_of_binders = mkVarSet binders
 654     binders        = case bind of
 655                         NonRec binder rhs -> [binder]
 656                         Rec pairs         -> map fst pairs
 657
 658     mk_binding bind_lvs binder
 659         = (binder,  LetrecBound  False          -- Not top level
 660                         live_vars
 661            )
 662         where
 663            live_vars = if let_no_escape then
 664                             extendVarSet bind_lvs binder
 665                        else
 666                             unitVarSet binder
 667
 668     vars_bind :: StgLiveVars
 669               -> FreeVarsInfo                   -- Free var info for body of binding
 670               -> CoreBind
 671               -> LneM (StgBinding,
 672                        FreeVarsInfo, EscVarsSet,        -- free vars; escapee vars
 673                        [(Id, HowBound)])
 674                                          -- extension to environment
 675
 676     vars_bind rec_bind_lvs rec_body_fvs (NonRec binder rhs)
 677       = coreToStgRhs rec_body_fvs NotTopLevel (binder,rhs)
 678                                         `thenLne` \ (rhs2, fvs, escs) ->
 679         let
 680             env_ext_item@(binder', _) = mk_binding rec_bind_lvs binder
 681         in
 682         returnLne (StgNonRec binder' rhs2, fvs, escs, [env_ext_item])
 683
 684     vars_bind rec_bind_lvs rec_body_fvs (Rec pairs)
 685       = let
 686             binders = map fst pairs
 687             env_ext = map (mk_binding rec_bind_lvs) binders
 688         in
 689         extendVarEnvLne env_ext           (
 690         fixLne (\ ~(_, rec_rhs_fvs, _, _) ->
 691                 let
 692                         rec_scope_fvs = unionFVInfo rec_body_fvs rec_rhs_fvs
 693                 in
 694                 mapAndUnzip3Lne (coreToStgRhs rec_scope_fvs NotTopLevel) pairs
 695                                         `thenLne` \ (rhss2, fvss, escss) ->
 696                 let
 697                         fvs  = unionFVInfos      fvss
 698                         escs = unionVarSets escss
 699                 in
 700                 returnLne (StgRec (binders `zip` rhss2), fvs, escs, env_ext)
 701         ))
 702
 703 is_join_var :: Id -> Bool
 704 -- A hack (used only for compiler debuggging) to tell if
 705 -- a variable started life as a join point ($j)
 706 is_join_var j = occNameUserString (getOccName j) == "$j"
 707 \end{code}
 708
 709 %************************************************************************
 710 %*                                                                      *
 711 \subsection[LNE-monad]{A little monad for this let-no-escaping pass}
 712 %*                                                                      *
 713 %************************************************************************
 714
 715 There's a lot of stuff to pass around, so we use this @LneM@ monad to
 716 help.  All the stuff here is only passed {\em down}.
 717
 718 \begin{code}
 719 type LneM a = IdEnv HowBound
 720             -> StgLiveVars              -- vars live in continuation
 721             -> a
 722
 723 data HowBound
 724   = ImportBound
 725   | CaseBound
 726   | LambdaBound
 727   | LetrecBound
 728         Bool            -- True <=> bound at top level
 729         StgLiveVars     -- Live vars... see notes below
 730
 731 isLetrecBound (LetrecBound _ _) = True
 732 isLetrecBound other             = False
 733 \end{code}
 734
 735 For a let(rec)-bound variable, x,  we record what varibles are live if
 736 x is live.  For "normal" variables that is just x alone.  If x is
 737 a let-no-escaped variable then x is represented by a code pointer and
 738 a stack pointer (well, one for each stack).  So all of the variables
 739 needed in the execution of x are live if x is, and are therefore recorded
 740 in the LetrecBound constructor; x itself *is* included.
 741
 742 The std monad functions:
 743 \begin{code}
 744 initLne :: LneM a -> a
 745 initLne m = m emptyVarEnv emptyVarSet
 746
 747 {-# INLINE thenLne #-}
 748 {-# INLINE thenLne_ #-}
 749 {-# INLINE returnLne #-}
 750
 751 returnLne :: a -> LneM a
 752 returnLne e env lvs_cont = e
 753
 754 thenLne :: LneM a -> (a -> LneM b) -> LneM b
 755 thenLne m k env lvs_cont
 756   = case (m env lvs_cont) of
 757       m_result -> k m_result env lvs_cont
 758
 759 thenLne_ :: LneM a -> LneM b -> LneM b
 760 thenLne_ m k env lvs_cont
 761   = case (m env lvs_cont) of
 762       _ -> k env lvs_cont
 763
 764 mapLne  :: (a -> LneM b)   -> [a] -> LneM [b]
 765 mapLne f [] = returnLne []
 766 mapLne f (x:xs)
 767   = f x         `thenLne` \ r  ->
 768     mapLne f xs `thenLne` \ rs ->
 769     returnLne (r:rs)
 770
 771 mapAndUnzipLne  :: (a -> LneM (b,c))   -> [a] -> LneM ([b],[c])
 772
 773 mapAndUnzipLne f [] = returnLne ([],[])
 774 mapAndUnzipLne f (x:xs)
 775   = f x                 `thenLne` \ (r1,  r2)  ->
 776     mapAndUnzipLne f xs `thenLne` \ (rs1, rs2) ->
 777     returnLne (r1:rs1, r2:rs2)
 778
 779 mapAndUnzip3Lne :: (a -> LneM (b,c,d)) -> [a] -> LneM ([b],[c],[d])
 780
 781 mapAndUnzip3Lne f []    = returnLne ([],[],[])
 782 mapAndUnzip3Lne f (x:xs)
 783   = f x                  `thenLne` \ (r1,  r2,  r3)  ->
 784     mapAndUnzip3Lne f xs `thenLne` \ (rs1, rs2, rs3) ->
 785     returnLne (r1:rs1, r2:rs2, r3:rs3)
 786
 787 fixLne :: (a -> LneM a) -> LneM a
 788 fixLne expr env lvs_cont = result
 789   where
 790     result = expr result env lvs_cont
 791 --  ^^^^^^ ------ ^^^^^^
 792 \end{code}
 793
 794 Functions specific to this monad:
 795 \begin{code}
 796 getVarsLiveInCont :: LneM StgLiveVars
 797 getVarsLiveInCont env lvs_cont = lvs_cont
 798
 799 setVarsLiveInCont :: StgLiveVars -> LneM a -> LneM a
 800 setVarsLiveInCont new_lvs_cont expr env lvs_cont
 801   = expr env new_lvs_cont
 802
 803 extendVarEnvLne :: [(Id, HowBound)] -> LneM a -> LneM a
 804 extendVarEnvLne ids_w_howbound expr env lvs_cont
 805   = expr (extendVarEnvList env ids_w_howbound) lvs_cont
 806
 807 lookupVarLne :: Id -> LneM HowBound
 808 lookupVarLne v env lvs_cont
 809   = returnLne (
 810       case (lookupVarEnv env v) of
 811         Just xx -> xx
 812         Nothing -> ImportBound
 813     ) env lvs_cont
 814
 815 -- The result of lookupLiveVarsForSet, a set of live variables, is
 816 -- only ever tacked onto a decorated expression. It is never used as
 817 -- the basis of a control decision, which might give a black hole.
 818
 819 lookupLiveVarsForSet :: FreeVarsInfo -> LneM StgLiveVars
 820
 821 lookupLiveVarsForSet fvs env lvs_cont
 822   = returnLne (unionVarSets (map do_one (getFVs fvs)))
 823               env lvs_cont
 824   where
 825     do_one v
 826       = if isLocalId v then
 827             case (lookupVarEnv env v) of
 828               Just (LetrecBound _ lvs) -> extendVarSet lvs v
 829               Just _                   -> unitVarSet v
 830               Nothing -> pprPanic "lookupVarEnv/do_one:" (ppr v)
 831         else
 832             emptyVarSet
 833 \end{code}
 834
 835
 836 %************************************************************************
 837 %*                                                                      *
 838 \subsection[Free-var info]{Free variable information}
 839 %*                                                                      *
 840 %************************************************************************
 841
 842 \begin{code}
 843 type FreeVarsInfo = IdEnv (Id, Bool, StgBinderInfo)
 844                         -- If f is mapped to NoStgBinderInfo, that means
 845                         -- that f *is* mentioned (else it wouldn't be in the
 846                         -- IdEnv at all), but only in a saturated applications.
 847                         --
 848                         -- All case/lambda-bound things are also mapped to
 849                         -- NoStgBinderInfo, since we aren't interested in their
 850                         -- occurence info.
 851                         --
 852                         -- The Bool is True <=> the Id is top level letrec bound
 853
 854 type EscVarsSet   = IdSet
 855 \end{code}
 856
 857 \begin{code}
 858 emptyFVInfo :: FreeVarsInfo
 859 emptyFVInfo = emptyVarEnv
 860
 861 singletonFVInfo :: Id -> HowBound -> StgBinderInfo -> FreeVarsInfo
 862 singletonFVInfo id ImportBound               info = emptyVarEnv
 863 singletonFVInfo id (LetrecBound top_level _) info = unitVarEnv id (id, top_level, info)
 864 singletonFVInfo id other                     info = unitVarEnv id (id, False,     info)
 865
 866 unionFVInfo :: FreeVarsInfo -> FreeVarsInfo -> FreeVarsInfo
 867 unionFVInfo fv1 fv2 = plusVarEnv_C plusFVInfo fv1 fv2
 868
 869 unionFVInfos :: [FreeVarsInfo] -> FreeVarsInfo
 870 unionFVInfos fvs = foldr unionFVInfo emptyFVInfo fvs
 871
 872 minusFVBinders :: FreeVarsInfo -> [Id] -> FreeVarsInfo
 873 minusFVBinders fv ids = fv `delVarEnvList` ids
 874
 875 elementOfFVInfo :: Id -> FreeVarsInfo -> Bool
 876 elementOfFVInfo id fvs = maybeToBool (lookupVarEnv fvs id)
 877
 878 lookupFVInfo :: FreeVarsInfo -> Id -> StgBinderInfo
 879 lookupFVInfo fvs id = case lookupVarEnv fvs id of
 880                         Nothing         -> NoStgBinderInfo
 881                         Just (_,_,info) -> info
 882
 883 getFVs :: FreeVarsInfo -> [Id]  -- Non-top-level things only
 884 getFVs fvs = [id | (id,False,_) <- rngVarEnv fvs]
 885
 886 getFVSet :: FreeVarsInfo -> IdSet
 887 getFVSet fvs = mkVarSet (getFVs fvs)
 888
 889 plusFVInfo (id1,top1,info1) (id2,top2,info2)
 890   = ASSERT (id1 == id2 && top1 == top2)
 891     (id1, top1, combineStgBinderInfo info1 info2)
 892 \end{code}
 893
 894 Misc.
 895
 896 \begin{code}
 897 shouldBeVar (Note _ e) = shouldBeVar e
 898 shouldBeVar (Var v)    = v
 899 shouldBeVar e = pprPanic "shouldBeVar" (ppr e)
 900
 901 -- ignore all notes except SCC
 902 myCollectBinders expr
 903   = go [] expr
 904   where
 905     go bs (Lam b e)          = go (b:bs) e
 906     go bs e@(Note (SCC _) _) = (reverse bs, e)
 907     go bs (Note _ e)         = go bs e
 908     go bs e                  = (reverse bs, e)
 909
 910 myCollectArgs :: Expr b -> (Expr b, [Arg b])
 911 myCollectArgs expr
 912   = go expr []
 913   where
 914     go (App f a) as        = go f (a:as)
 915     go (Note (SCC _) e) as = panic "CoreToStg.myCollectArgs"
 916     go (Note n e) as       = go e as
 917     go e         as        = (e, as)
 918 \end{code}