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         vars_alg_alt other = pprPanic "vars_alg_alt" (ppr other)
 395
 396         vars_deflt Nothing
 397            = returnLne (StgNoDefault, emptyFVInfo, emptyVarSet)
 398
 399         vars_deflt (Just rhs)
 400            = coreToStgExpr rhs  `thenLne` \ (rhs2, rhs_fvs, rhs_escs) ->
 401              returnLne (StgBindDefault rhs2, rhs_fvs, rhs_escs)
 402 \end{code}
 403
 404 Lets not only take quite a bit of work, but this is where we convert
 405 then to let-no-escapes, if we wish.
 406
 407 (Meanwhile, we don't expect to see let-no-escapes...)
 408 \begin{code}
 409 coreToStgExpr (Let bind body)
 410   = fixLne (\ ~(_, _, _, no_binder_escapes) ->
 411         coreToStgLet no_binder_escapes bind body
 412     )                           `thenLne` \ (new_let, fvs, escs, _) ->
 413
 414     returnLne (new_let, fvs, escs)
 415 \end{code}
 416
 417 If we've got a case containing a _ccall_GC_ primop, we need to
 418 ensure that the arguments are kept live for the duration of the
 419 call. This only an issue
 420
 421 \begin{code}
 422 isForeignObjArg :: Id -> Bool
 423 isForeignObjArg x = isId x && isForeignObjPrimTy (idType x)
 424
 425 isForeignObjPrimTy ty
 426    = case splitTyConApp_maybe ty of
 427         Just (tycon, _) -> tycon == foreignObjPrimTyCon
 428         Nothing         -> False
 429 \end{code}
 430
 431 \begin{code}
 432 mkStgAlgAlts ty alts deflt
 433  =  case alts of
 434                 -- Get the tycon from the data con
 435         (dc, _, _, _) : _rest
 436             -> StgAlgAlts (Just (dataConTyCon dc)) alts deflt
 437
 438                 -- Otherwise just do your best
 439         [] -> case splitTyConApp_maybe (repType ty) of
 440                 Just (tc,_) | isAlgTyCon tc
 441                         -> StgAlgAlts (Just tc) alts deflt
 442                 other
 443                         -> StgAlgAlts Nothing alts deflt
 444
 445 mkStgPrimAlts ty alts deflt
 446   = StgPrimAlts (tyConAppTyCon ty) alts deflt
 447 \end{code}
 448
 449
 450 -- ---------------------------------------------------------------------------
 451 -- Applications
 452 -- ---------------------------------------------------------------------------
 453
 454 \begin{code}
 455 coreToStgApp
 456          :: Maybe UpdateFlag            -- Just upd <=> this application is
 457                                         -- the rhs of a thunk binding
 458                                         --      x = [...] \upd [] -> the_app
 459                                         -- with specified update flag
 460         -> Id                           -- Function
 461         -> [CoreArg]                    -- Arguments
 462         -> LneM (StgExpr, FreeVarsInfo, EscVarsSet)
 463
 464 coreToStgApp maybe_thunk_body f args
 465   = getVarsLiveInCont           `thenLne` \ live_in_cont ->
 466     coreToStgArgs args          `thenLne` \ (args', args_fvs) ->
 467     lookupVarLne f              `thenLne` \ how_bound ->
 468
 469     let
 470         n_args           = length args
 471         not_letrec_bound = not (isLetrecBound how_bound)
 472         fun_fvs          = singletonFVInfo f how_bound fun_occ
 473
 474         -- Mostly, the arity info of a function is in the fn's IdInfo
 475         -- But new bindings introduced by CoreSat may not have no
 476         -- arity info; it would do us no good anyway.  For example:
 477         --      let f = \ab -> e in f
 478         -- No point in having correct arity info for f!
 479         -- Hence the hasArity stuff below.
 480         f_arity_info     = idArityInfo f
 481         f_arity          = arityLowerBound f_arity_info         -- Zero if no info
 482
 483         fun_occ
 484          | not_letrec_bound                 = noBinderInfo      -- Uninteresting variable
 485          | f_arity > 0 && f_arity <= n_args = stgSatOcc         -- Saturated or over-saturated function call
 486          | otherwise                        = stgUnsatOcc       -- Unsaturated function or thunk
 487
 488         fun_escs
 489          | not_letrec_bound  = emptyVarSet      -- Only letrec-bound escapees are interesting
 490          | hasArity f_arity_info &&
 491            f_arity == n_args = emptyVarSet      -- A function *or thunk* with an exactly
 492                                                 -- saturated call doesn't escape
 493                                                 -- (let-no-escape applies to 'thunks' too)
 494
 495          | otherwise         = unitVarSet f     -- Inexact application; it does escape
 496
 497         -- At the moment of the call:
 498
 499         --  either the function is *not* let-no-escaped, in which case
 500         --         nothing is live except live_in_cont
 501         --      or the function *is* let-no-escaped in which case the
 502         --         variables it uses are live, but still the function
 503         --         itself is not.  PS.  In this case, the function's
 504         --         live vars should already include those of the
 505         --         continuation, but it does no harm to just union the
 506         --         two regardless.
 507
 508         app = case idFlavour f of
 509                 DataConId dc -> StgConApp dc args'
 510                 PrimOpId op  -> StgPrimApp op args' (exprType (mkApps (Var f) args))
 511                 _other       -> StgApp f args'
 512
 513     in
 514     returnLne (
 515         app,
 516         fun_fvs  `unionFVInfo` args_fvs,
 517         fun_escs `unionVarSet` (getFVSet args_fvs)
 518                                 -- All the free vars of the args are disqualified
 519                                 -- from being let-no-escaped.
 520     )
 521
 522
 523
 524 -- ---------------------------------------------------------------------------
 525 -- Argument lists
 526 -- This is the guy that turns applications into A-normal form
 527 -- ---------------------------------------------------------------------------
 528
 529 coreToStgArgs :: [CoreArg] -> LneM ([StgArg], FreeVarsInfo)
 530 coreToStgArgs []
 531   = returnLne ([], emptyFVInfo)
 532
 533 coreToStgArgs (Type ty : args)  -- Type argument
 534   = coreToStgArgs args  `thenLne` \ (args', fvs) ->
 535     if opt_KeepStgTypes then
 536         returnLne (StgTypeArg ty : args', fvs `unionFVInfo` tyvarFVInfo (tyVarsOfType ty))
 537     else
 538     returnLne (args', fvs)
 539
 540 coreToStgArgs (arg : args)      -- Non-type argument
 541   = coreToStgArgs args  `thenLne` \ (stg_args, args_fvs) ->
 542     coreToStgExpr arg   `thenLne` \ (arg', arg_fvs, escs) ->
 543     let
 544         fvs = args_fvs `unionFVInfo` arg_fvs
 545         stg_arg = case arg' of
 546                        StgApp v []      -> StgVarArg v
 547                        StgConApp con [] -> StgVarArg (dataConWrapId con)
 548                        StgLit lit       -> StgLitArg lit
 549                        _                -> pprPanic "coreToStgArgs" (ppr arg)
 550     in
 551     returnLne (stg_arg : stg_args, fvs)
 552
 553
 554 -- ---------------------------------------------------------------------------
 555 -- The magic for lets:
 556 -- ---------------------------------------------------------------------------
 557
 558 coreToStgLet
 559          :: Bool        -- True <=> yes, we are let-no-escaping this let
 560          -> CoreBind    -- bindings
 561          -> CoreExpr    -- body
 562          -> LneM (StgExpr,      -- new let
 563                   FreeVarsInfo, -- variables free in the whole let
 564                   EscVarsSet,   -- variables that escape from the whole let
 565                   Bool)         -- True <=> none of the binders in the bindings
 566                                 -- is among the escaping vars
 567
 568 coreToStgLet let_no_escape bind body
 569   = fixLne (\ ~(_, _, _, rec_bind_lvs, _, rec_body_fvs, _, _) ->
 570
 571         -- Do the bindings, setting live_in_cont to empty if
 572         -- we ain't in a let-no-escape world
 573         getVarsLiveInCont               `thenLne` \ live_in_cont ->
 574         setVarsLiveInCont
 575                 (if let_no_escape then live_in_cont else emptyVarSet)
 576                 (vars_bind rec_bind_lvs rec_body_fvs bind)
 577                             `thenLne` \ (bind2, bind_fvs, bind_escs, env_ext) ->
 578
 579         -- The live variables of this binding are the ones which are live
 580         -- by virtue of being accessible via the free vars of the binding (lvs_from_fvs)
 581         -- together with the live_in_cont ones
 582         lookupLiveVarsForSet (binders `minusFVBinders` bind_fvs)
 583                                 `thenLne` \ lvs_from_fvs ->
 584         let
 585                 bind_lvs = lvs_from_fvs `unionVarSet` live_in_cont
 586         in
 587
 588         -- bind_fvs and bind_escs still include the binders of the let(rec)
 589         -- but bind_lvs does not
 590
 591         -- Do the body
 592         extendVarEnvLne env_ext (
 593                 coreToStgExpr body                      `thenLne` \ (body2, body_fvs, body_escs) ->
 594                 lookupLiveVarsForSet body_fvs   `thenLne` \ body_lvs ->
 595
 596                 returnLne (bind2, bind_fvs, bind_escs, bind_lvs,
 597                            body2, body_fvs, body_escs, body_lvs)
 598
 599     )) `thenLne` (\ (bind2, bind_fvs, bind_escs, bind_lvs,
 600                      body2, body_fvs, body_escs, body_lvs) ->
 601
 602
 603         -- Compute the new let-expression
 604     let
 605         new_let | let_no_escape = StgLetNoEscape live_in_whole_let bind_lvs bind2 body2
 606                 | otherwise     = StgLet bind2 body2
 607
 608         free_in_whole_let
 609           = binders `minusFVBinders` (bind_fvs `unionFVInfo` body_fvs)
 610
 611         live_in_whole_let
 612           = bind_lvs `unionVarSet` (body_lvs `minusVarSet` set_of_binders)
 613
 614         real_bind_escs = if let_no_escape then
 615                             bind_escs
 616                          else
 617                             getFVSet bind_fvs
 618                             -- Everything escapes which is free in the bindings
 619
 620         let_escs = (real_bind_escs `unionVarSet` body_escs) `minusVarSet` set_of_binders
 621
 622         all_escs = bind_escs `unionVarSet` body_escs    -- Still includes binders of
 623                                                         -- this let(rec)
 624
 625         no_binder_escapes = isEmptyVarSet (set_of_binders `intersectVarSet` all_escs)
 626
 627 #ifdef DEBUG
 628         -- Debugging code as requested by Andrew Kennedy
 629         checked_no_binder_escapes
 630                 | not no_binder_escapes && any is_join_var binders
 631                 = pprTrace "Interesting!  A join var that isn't let-no-escaped" (ppr binders)
 632                   False
 633                 | otherwise = no_binder_escapes
 634 #else
 635         checked_no_binder_escapes = no_binder_escapes
 636 #endif
 637
 638                 -- Mustn't depend on the passed-in let_no_escape flag, since
 639                 -- no_binder_escapes is used by the caller to derive the flag!
 640     in
 641     returnLne (
 642         new_let,
 643         free_in_whole_let,
 644         let_escs,
 645         checked_no_binder_escapes
 646     ))
 647   where
 648     set_of_binders = mkVarSet binders
 649     binders        = case bind of
 650                         NonRec binder rhs -> [binder]
 651                         Rec pairs         -> map fst pairs
 652
 653     mk_binding bind_lvs binder
 654         = (binder,  LetrecBound  False          -- Not top level
 655                         live_vars
 656            )
 657         where
 658            live_vars = if let_no_escape then
 659                             extendVarSet bind_lvs binder
 660                        else
 661                             unitVarSet binder
 662
 663     vars_bind :: StgLiveVars
 664               -> FreeVarsInfo                   -- Free var info for body of binding
 665               -> CoreBind
 666               -> LneM (StgBinding,
 667                        FreeVarsInfo, EscVarsSet,        -- free vars; escapee vars
 668                        [(Id, HowBound)])
 669                                          -- extension to environment
 670
 671     vars_bind rec_bind_lvs rec_body_fvs (NonRec binder rhs)
 672       = coreToStgRhs rec_body_fvs NotTopLevel (binder,rhs)
 673                                         `thenLne` \ (rhs2, fvs, escs) ->
 674         let
 675             env_ext_item@(binder', _) = mk_binding rec_bind_lvs binder
 676         in
 677         returnLne (StgNonRec binder' rhs2, fvs, escs, [env_ext_item])
 678
 679     vars_bind rec_bind_lvs rec_body_fvs (Rec pairs)
 680       = let
 681             binders = map fst pairs
 682             env_ext = map (mk_binding rec_bind_lvs) binders
 683         in
 684         extendVarEnvLne env_ext           (
 685         fixLne (\ ~(_, rec_rhs_fvs, _, _) ->
 686                 let
 687                         rec_scope_fvs = unionFVInfo rec_body_fvs rec_rhs_fvs
 688                 in
 689                 mapAndUnzip3Lne (coreToStgRhs rec_scope_fvs NotTopLevel) pairs
 690                                         `thenLne` \ (rhss2, fvss, escss) ->
 691                 let
 692                         fvs  = unionFVInfos      fvss
 693                         escs = unionVarSets escss
 694                 in
 695                 returnLne (StgRec (binders `zip` rhss2), fvs, escs, env_ext)
 696         ))
 697
 698 is_join_var :: Id -> Bool
 699 -- A hack (used only for compiler debuggging) to tell if
 700 -- a variable started life as a join point ($j)
 701 is_join_var j = occNameUserString (getOccName j) == "$j"
 702 \end{code}
 703
 704 %************************************************************************
 705 %*                                                                      *
 706 \subsection[LNE-monad]{A little monad for this let-no-escaping pass}
 707 %*                                                                      *
 708 %************************************************************************
 709
 710 There's a lot of stuff to pass around, so we use this @LneM@ monad to
 711 help.  All the stuff here is only passed {\em down}.
 712
 713 \begin{code}
 714 type LneM a =  IdEnv HowBound
 715             -> StgLiveVars              -- vars live in continuation
 716             -> a
 717
 718 data HowBound
 719   = ImportBound
 720   | CaseBound
 721   | LambdaBound
 722   | LetrecBound
 723         Bool            -- True <=> bound at top level
 724         StgLiveVars     -- Live vars... see notes below
 725
 726 isLetrecBound (LetrecBound _ _) = True
 727 isLetrecBound other             = False
 728 \end{code}
 729
 730 For a let(rec)-bound variable, x, we record StgLiveVars, the set of
 731 variables that are live if x is live.  For "normal" variables that is
 732 just x alone.  If x is a let-no-escaped variable then x is represented
 733 by a code pointer and a stack pointer (well, one for each stack).  So
 734 all of the variables needed in the execution of x are live if x is,
 735 and are therefore recorded in the LetrecBound constructor; x itself
 736 *is* included.
 737
 738 The set of live variables is guaranteed ot have no further let-no-escaped
 739 variables in it.
 740
 741 The std monad functions:
 742 \begin{code}
 743 initLne :: LneM a -> a
 744 initLne m = m emptyVarEnv emptyVarSet
 745
 746 {-# INLINE thenLne #-}
 747 {-# INLINE returnLne #-}
 748
 749 returnLne :: a -> LneM a
 750 returnLne e env lvs_cont = e
 751
 752 thenLne :: LneM a -> (a -> LneM b) -> LneM b
 753 thenLne m k env lvs_cont
 754   = k (m env lvs_cont) env lvs_cont
 755
 756 mapLne  :: (a -> LneM b)   -> [a] -> LneM [b]
 757 mapLne f [] = returnLne []
 758 mapLne f (x:xs)
 759   = f x         `thenLne` \ r  ->
 760     mapLne f xs `thenLne` \ rs ->
 761     returnLne (r:rs)
 762
 763 mapAndUnzipLne  :: (a -> LneM (b,c))   -> [a] -> LneM ([b],[c])
 764
 765 mapAndUnzipLne f [] = returnLne ([],[])
 766 mapAndUnzipLne f (x:xs)
 767   = f x                 `thenLne` \ (r1,  r2)  ->
 768     mapAndUnzipLne f xs `thenLne` \ (rs1, rs2) ->
 769     returnLne (r1:rs1, r2:rs2)
 770
 771 mapAndUnzip3Lne :: (a -> LneM (b,c,d)) -> [a] -> LneM ([b],[c],[d])
 772
 773 mapAndUnzip3Lne f []    = returnLne ([],[],[])
 774 mapAndUnzip3Lne f (x:xs)
 775   = f x                  `thenLne` \ (r1,  r2,  r3)  ->
 776     mapAndUnzip3Lne f xs `thenLne` \ (rs1, rs2, rs3) ->
 777     returnLne (r1:rs1, r2:rs2, r3:rs3)
 778
 779 fixLne :: (a -> LneM a) -> LneM a
 780 fixLne expr env lvs_cont
 781   = result
 782   where
 783     result = expr result env lvs_cont
 784 \end{code}
 785
 786 Functions specific to this monad:
 787
 788 \begin{code}
 789 getVarsLiveInCont :: LneM StgLiveVars
 790 getVarsLiveInCont env lvs_cont = lvs_cont
 791
 792 setVarsLiveInCont :: StgLiveVars -> LneM a -> LneM a
 793 setVarsLiveInCont new_lvs_cont expr env lvs_cont
 794   = expr env new_lvs_cont
 795
 796 extendVarEnvLne :: [(Id, HowBound)] -> LneM a -> LneM a
 797 extendVarEnvLne ids_w_howbound expr env lvs_cont
 798   = expr (extendVarEnvList env ids_w_howbound) lvs_cont
 799
 800 lookupVarLne :: Id -> LneM HowBound
 801 lookupVarLne v env lvs_cont
 802   = returnLne (
 803       case (lookupVarEnv env v) of
 804         Just xx -> xx
 805         Nothing -> ImportBound
 806     ) env lvs_cont
 807
 808 -- The result of lookupLiveVarsForSet, a set of live variables, is
 809 -- only ever tacked onto a decorated expression. It is never used as
 810 -- the basis of a control decision, which might give a black hole.
 811
 812 lookupLiveVarsForSet :: FreeVarsInfo -> LneM StgLiveVars
 813
 814 lookupLiveVarsForSet fvs env lvs_cont
 815   = returnLne (unionVarSets (map do_one (getFVs fvs)))
 816               env lvs_cont
 817   where
 818     do_one v
 819       = if isLocalId v then
 820             case (lookupVarEnv env v) of
 821               Just (LetrecBound _ lvs) -> extendVarSet lvs v
 822               Just _                   -> unitVarSet v
 823               Nothing -> pprPanic "lookupVarEnv/do_one:" (ppr v)
 824         else
 825             emptyVarSet
 826 \end{code}
 827
 828
 829 %************************************************************************
 830 %*                                                                      *
 831 \subsection[Free-var info]{Free variable information}
 832 %*                                                                      *
 833 %************************************************************************
 834
 835 \begin{code}
 836 type FreeVarsInfo = VarEnv (Var, Bool, StgBinderInfo)
 837         -- If f is mapped to noBinderInfo, that means
 838         -- that f *is* mentioned (else it wouldn't be in the
 839         -- IdEnv at all), but perhaps in an unsaturated applications.
 840         --
 841         -- All case/lambda-bound things are also mapped to
 842         -- noBinderInfo, since we aren't interested in their
 843         -- occurence info.
 844         --
 845         -- The Bool is True <=> the Id is top level letrec bound
 846         --
 847         -- For ILX we track free var info for type variables too;
 848         -- hence VarEnv not IdEnv
 849
 850 type EscVarsSet = IdSet
 851 \end{code}
 852
 853 \begin{code}
 854 emptyFVInfo :: FreeVarsInfo
 855 emptyFVInfo = emptyVarEnv
 856
 857 singletonFVInfo :: Id -> HowBound -> StgBinderInfo -> FreeVarsInfo
 858 singletonFVInfo id ImportBound               info = emptyVarEnv
 859 singletonFVInfo id (LetrecBound top_level _) info = unitVarEnv id (id, top_level, info)
 860 singletonFVInfo id other                     info = unitVarEnv id (id, False,     info)
 861
 862 tyvarFVInfo :: TyVarSet -> FreeVarsInfo
 863 tyvarFVInfo tvs = foldVarSet add emptyFVInfo tvs
 864                 where
 865                   add tv fvs = extendVarEnv fvs tv (tv, False, noBinderInfo)
 866
 867 unionFVInfo :: FreeVarsInfo -> FreeVarsInfo -> FreeVarsInfo
 868 unionFVInfo fv1 fv2 = plusVarEnv_C plusFVInfo fv1 fv2
 869
 870 unionFVInfos :: [FreeVarsInfo] -> FreeVarsInfo
 871 unionFVInfos fvs = foldr unionFVInfo emptyFVInfo fvs
 872
 873 minusFVBinders :: [Id] -> FreeVarsInfo -> FreeVarsInfo
 874 minusFVBinders vs fv = foldr minusFVBinder fv vs
 875
 876 minusFVBinder :: Id -> FreeVarsInfo -> FreeVarsInfo
 877 minusFVBinder v fv | isId v && opt_KeepStgTypes
 878                    = (fv `delVarEnv` v) `unionFVInfo`
 879                      tyvarFVInfo (tyVarsOfType (idType v))
 880                    | otherwise = fv `delVarEnv` v
 881         -- When removing a binder, remember to add its type variables
 882         -- c.f. CoreFVs.delBinderFV
 883
 884 elementOfFVInfo :: Id -> FreeVarsInfo -> Bool
 885 elementOfFVInfo id fvs = maybeToBool (lookupVarEnv fvs id)
 886
 887 lookupFVInfo :: FreeVarsInfo -> Id -> StgBinderInfo
 888 -- Find how the given Id is used.
 889 -- Externally visible things may be used any old how
 890 lookupFVInfo fvs id
 891   | isExternallyVisibleName (idName id) = noBinderInfo
 892   | otherwise = case lookupVarEnv fvs id of
 893                         Nothing         -> noBinderInfo
 894                         Just (_,_,info) -> info
 895
 896 getFVs :: FreeVarsInfo -> [Id]  -- Non-top-level things only
 897 getFVs fvs = [id | (id,False,_) <- rngVarEnv fvs]
 898
 899 getFVSet :: FreeVarsInfo -> IdSet
 900 getFVSet fvs = mkVarSet (getFVs fvs)
 901
 902 plusFVInfo (id1,top1,info1) (id2,top2,info2)
 903   = ASSERT (id1 == id2 && top1 == top2)
 904     (id1, top1, combineStgBinderInfo info1 info2)
 905 \end{code}
 906
 907 Misc.
 908 \begin{code}
 909 filterStgBinders :: [Var] -> [Var]
 910 filterStgBinders bndrs
 911   | opt_KeepStgTypes = bndrs
 912   | otherwise        = filter isId bndrs
 913 \end{code}
 914
 915
 916 \begin{code}
 917         -- Ignore all notes except SCC
 918 myCollectBinders expr
 919   = go [] expr
 920   where
 921     go bs (Lam b e)          = go (b:bs) e
 922     go bs e@(Note (SCC _) _) = (reverse bs, e)
 923     go bs (Note _ e)         = go bs e
 924     go bs e                  = (reverse bs, e)
 925
 926 myCollectArgs :: CoreExpr -> (Id, [CoreArg])
 927         -- We assume that we only have variables
 928         -- in the function position by now
 929 myCollectArgs expr
 930   = go expr []
 931   where
 932     go (Var v)          as = (v, as)
 933     go (App f a) as        = go f (a:as)
 934     go (Note (SCC _) e) as = pprPanic "CoreToStg.myCollectArgs" (ppr expr)
 935     go (Note n e)       as = go e as
 936     go _                as = pprPanic "CoreToStg.myCollectArgs" (ppr expr)
 937 \end{code}