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