ghc/compiler/stgSyn/CoreToStg.lhs

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