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