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