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