ghc/compiler/stgSyn/CoreToStg.lhs

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