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 CoreUtils        ( rhsIsStatic, manifestArity, exprType )
  16 import StgSyn
  17
  18 import Type
  19 import TyCon            ( isAlgTyCon )
  20 import Id
  21 import Var              ( Var, globalIdDetails, varType )
  22 import TyCon            ( isUnboxedTupleTyCon, isPrimTyCon, isFunTyCon )
  23 #ifdef ILX
  24 import MkId             ( unsafeCoerceId )
  25 #endif
  26 import IdInfo
  27 import DataCon
  28 import CostCentre       ( noCCS )
  29 import VarSet
  30 import VarEnv
  31 import Maybes           ( maybeToBool )
  32 import Name             ( getOccName, isExternalName, nameOccName )
  33 import OccName          ( occNameUserString, occNameFS )
  34 import BasicTypes       ( Arity )
  35 import CmdLineOpts      ( DynFlags, opt_RuntimeTypes )
  36 import Outputable
  37
  38 infixr 9 `thenLne`
  39 \end{code}
  40
  41 %************************************************************************
  42 %*                                                                      *
  43 \subsection[live-vs-free-doc]{Documentation}
  44 %*                                                                      *
  45 %************************************************************************
  46
  47 (There is other relevant documentation in codeGen/CgLetNoEscape.)
  48
  49 The actual Stg datatype is decorated with {\em live variable}
  50 information, as well as {\em free variable} information.  The two are
  51 {\em not} the same.  Liveness is an operational property rather than a
  52 semantic one.  A variable is live at a particular execution point if
  53 it can be referred to {\em directly} again.  In particular, a dead
  54 variable's stack slot (if it has one):
  55 \begin{enumerate}
  56 \item
  57 should be stubbed to avoid space leaks, and
  58 \item
  59 may be reused for something else.
  60 \end{enumerate}
  61
  62 There ought to be a better way to say this.  Here are some examples:
  63 \begin{verbatim}
  64         let v = [q] \[x] -> e
  65         in
  66         ...v...  (but no q's)
  67 \end{verbatim}
  68
  69 Just after the `in', v is live, but q is dead.  If the whole of that
  70 let expression was enclosed in a case expression, thus:
  71 \begin{verbatim}
  72         case (let v = [q] \[x] -> e in ...v...) of
  73                 alts[...q...]
  74 \end{verbatim}
  75 (ie @alts@ mention @q@), then @q@ is live even after the `in'; because
  76 we'll return later to the @alts@ and need it.
  77
  78 Let-no-escapes make this a bit more interesting:
  79 \begin{verbatim}
  80         let-no-escape v = [q] \ [x] -> e
  81         in
  82         ...v...
  83 \end{verbatim}
  84 Here, @q@ is still live at the `in', because @v@ is represented not by
  85 a closure but by the current stack state.  In other words, if @v@ is
  86 live then so is @q@.  Furthermore, if @e@ mentions an enclosing
  87 let-no-escaped variable, then {\em its} free variables are also live
  88 if @v@ is.
  89
  90 %************************************************************************
  91 %*                                                                      *
  92 \subsection[caf-info]{Collecting live CAF info}
  93 %*                                                                      *
  94 %************************************************************************
  95
  96 In this pass we also collect information on which CAFs are live for
  97 constructing SRTs (see SRT.lhs).
  98
  99 A top-level Id has CafInfo, which is
 100
 101         - MayHaveCafRefs, if it may refer indirectly to
 102           one or more CAFs, or
 103         - NoCafRefs if it definitely doesn't
 104
 105 The CafInfo has already been calculated during the CoreTidy pass.
 106
 107 During CoreToStg, we then pin onto each binding and case expression, a
 108 list of Ids which represents the "live" CAFs at that point.  The meaning
 109 of "live" here is the same as for live variables, see above (which is
 110 why it's convenient to collect CAF information here rather than elsewhere).
 111
 112 The later SRT pass takes these lists of Ids and uses them to construct
 113 the actual nested SRTs, and replaces the lists of Ids with (offset,length)
 114 pairs.
 115
 116
 117 Interaction of let-no-escape with SRTs   [Sept 01]
 118 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 119 Consider
 120
 121         let-no-escape x = ...caf1...caf2...
 122         in
 123         ...x...x...x...
 124
 125 where caf1,caf2 are CAFs.  Since x doesn't have a closure, we
 126 build SRTs just as if x's defn was inlined at each call site, and
 127 that means that x's CAF refs get duplicated in the overall SRT.
 128
 129 This is unlike ordinary lets, in which the CAF refs are not duplicated.
 130
 131 We could fix this loss of (static) sharing by making a sort of pseudo-closure
 132 for x, solely to put in the SRTs lower down.
 133
 134
 135 %************************************************************************
 136 %*                                                                      *
 137 \subsection[binds-StgVarInfo]{Setting variable info: top-level, binds, RHSs}
 138 %*                                                                      *
 139 %************************************************************************
 140
 141 \begin{code}
 142 coreToStg :: DynFlags -> [CoreBind] -> IO [StgBinding]
 143 coreToStg dflags pgm
 144   = return pgm'
 145   where (_, _, pgm') = coreTopBindsToStg emptyVarEnv pgm
 146
 147 coreExprToStg :: CoreExpr -> StgExpr
 148 coreExprToStg expr
 149   = new_expr where (new_expr,_,_) = initLne emptyVarEnv (coreToStgExpr expr)
 150
 151
 152 coreTopBindsToStg
 153     :: IdEnv HowBound           -- environment for the bindings
 154     -> [CoreBind]
 155     -> (IdEnv HowBound, FreeVarsInfo, [StgBinding])
 156
 157 coreTopBindsToStg env [] = (env, emptyFVInfo, [])
 158 coreTopBindsToStg env (b:bs)
 159   = (env2, fvs2, b':bs')
 160   where
 161         -- env accumulates down the list of binds, fvs accumulates upwards
 162         (env1, fvs2, b' ) = coreTopBindToStg env fvs1 b
 163         (env2, fvs1, bs') = coreTopBindsToStg env1 bs
 164
 165
 166 coreTopBindToStg
 167         :: IdEnv HowBound
 168         -> FreeVarsInfo         -- Info about the body
 169         -> CoreBind
 170         -> (IdEnv HowBound, FreeVarsInfo, StgBinding)
 171
 172 coreTopBindToStg env body_fvs (NonRec id rhs)
 173   = let
 174         env'      = extendVarEnv env id how_bound
 175         how_bound = LetBound TopLet (manifestArity rhs)
 176
 177         (stg_rhs, fvs') =
 178             initLne env (
 179               coreToTopStgRhs body_fvs (id,rhs) `thenLne` \ (stg_rhs, fvs') ->
 180               returnLne (stg_rhs, fvs')
 181            )
 182
 183         bind = StgNonRec id stg_rhs
 184     in
 185     ASSERT2(manifestArity rhs == stgRhsArity stg_rhs, ppr id)
 186     ASSERT2(consistentCafInfo id bind, ppr id)
 187 --    WARN(not (consistent caf_info bind), ppr id <+> ppr cafs <+> ppCafInfo caf_info)
 188     (env', fvs' `unionFVInfo` body_fvs, bind)
 189
 190 coreTopBindToStg env body_fvs (Rec pairs)
 191   = let
 192         (binders, rhss) = unzip pairs
 193
 194         extra_env' = [ (b, LetBound TopLet (manifestArity rhs))
 195                      | (b, rhs) <- pairs ]
 196         env' = extendVarEnvList env extra_env'
 197
 198         (stg_rhss, fvs')
 199           = initLne env' (
 200                mapAndUnzipLne (coreToTopStgRhs body_fvs) pairs
 201                                                 `thenLne` \ (stg_rhss, fvss') ->
 202                let fvs' = unionFVInfos fvss' in
 203                returnLne (stg_rhss, fvs')
 204            )
 205
 206         bind = StgRec (zip binders stg_rhss)
 207     in
 208     ASSERT2(and [manifestArity rhs == stgRhsArity stg_rhs | (rhs,stg_rhs) <- rhss `zip` stg_rhss], ppr binders)
 209     ASSERT2(consistentCafInfo (head binders) bind, ppr binders)
 210     (env', fvs' `unionFVInfo` body_fvs, bind)
 211
 212 #ifdef DEBUG
 213 -- Assertion helper: this checks that the CafInfo on the Id matches
 214 -- what CoreToStg has figured out about the binding's SRT.  The
 215 -- CafInfo will be exact in all cases except when CorePrep has
 216 -- floated out a binding, in which case it will be approximate.
 217 consistentCafInfo id bind
 218   | occNameFS (nameOccName (idName id)) == FSLIT("sat")
 219   = safe
 220   | otherwise
 221   = WARN (not exact, ppr id) safe
 222   where
 223         safe  = id_marked_caffy || not binding_is_caffy
 224         exact = id_marked_caffy == binding_is_caffy
 225         id_marked_caffy  = mayHaveCafRefs (idCafInfo id)
 226         binding_is_caffy = stgBindHasCafRefs bind
 227 #endif
 228 \end{code}
 229
 230 \begin{code}
 231 coreToTopStgRhs
 232         :: FreeVarsInfo         -- Free var info for the scope of the binding
 233         -> (Id,CoreExpr)
 234         -> LneM (StgRhs, FreeVarsInfo)
 235
 236 coreToTopStgRhs scope_fv_info (bndr, rhs)
 237   = coreToStgExpr rhs           `thenLne` \ (new_rhs, rhs_fvs, _) ->
 238     freeVarsToLiveVars rhs_fvs  `thenLne` \ lv_info ->
 239     returnLne (mkTopStgRhs is_static rhs_fvs (mkSRT lv_info) bndr_info new_rhs, rhs_fvs)
 240   where
 241     bndr_info = lookupFVInfo scope_fv_info bndr
 242     is_static = rhsIsStatic rhs
 243
 244 mkTopStgRhs :: Bool -> FreeVarsInfo -> SRT -> StgBinderInfo -> StgExpr
 245         -> StgRhs
 246
 247 mkTopStgRhs is_static rhs_fvs srt binder_info (StgLam _ bndrs body)
 248   = ASSERT( is_static )
 249     StgRhsClosure noCCS binder_info
 250                   (getFVs rhs_fvs)
 251                   ReEntrant
 252                   srt
 253                   bndrs body
 254
 255 mkTopStgRhs is_static rhs_fvs srt binder_info (StgConApp con args)
 256   | is_static    -- StgConApps can be updatable (see isCrossDllConApp)
 257   = StgRhsCon noCCS con args
 258
 259 mkTopStgRhs is_static rhs_fvs srt binder_info rhs
 260   = ASSERT( not is_static )
 261     StgRhsClosure noCCS binder_info
 262                   (getFVs rhs_fvs)
 263                   Updatable
 264                   srt
 265                   [] rhs
 266 \end{code}
 267
 268
 269 -- ---------------------------------------------------------------------------
 270 -- Expressions
 271 -- ---------------------------------------------------------------------------
 272
 273 \begin{code}
 274 coreToStgExpr
 275         :: CoreExpr
 276         -> LneM (StgExpr,       -- Decorated STG expr
 277                  FreeVarsInfo,  -- Its free vars (NB free, not live)
 278                  EscVarsSet)    -- Its escapees, a subset of its free vars;
 279                                 -- also a subset of the domain of the envt
 280                                 -- because we are only interested in the escapees
 281                                 -- for vars which might be turned into
 282                                 -- let-no-escaped ones.
 283 \end{code}
 284
 285 The second and third components can be derived in a simple bottom up pass, not
 286 dependent on any decisions about which variables will be let-no-escaped or
 287 not.  The first component, that is, the decorated expression, may then depend
 288 on these components, but it in turn is not scrutinised as the basis for any
 289 decisions.  Hence no black holes.
 290
 291 \begin{code}
 292 coreToStgExpr (Lit l) = returnLne (StgLit l, emptyFVInfo, emptyVarSet)
 293 coreToStgExpr (Var v) = coreToStgApp Nothing v []
 294
 295 coreToStgExpr expr@(App _ _)
 296   = coreToStgApp Nothing f args
 297   where
 298     (f, args) = myCollectArgs expr
 299
 300 coreToStgExpr expr@(Lam _ _)
 301   = let
 302         (args, body) = myCollectBinders expr
 303         args'        = filterStgBinders args
 304     in
 305     extendVarEnvLne [ (a, LambdaBound) | a <- args' ] $
 306     coreToStgExpr body  `thenLne` \ (body, body_fvs, body_escs) ->
 307     let
 308         fvs             = args' `minusFVBinders` body_fvs
 309         escs            = body_escs `delVarSetList` args'
 310         result_expr | null args' = body
 311                     | otherwise  = StgLam (exprType expr) args' body
 312     in
 313     returnLne (result_expr, 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 #ifdef ILX
 320 -- For ILX, convert (__coerce__ to_ty from_ty e)
 321 --          into    (coerce to_ty from_ty e)
 322 -- where coerce is real function
 323 coreToStgExpr (Note (Coerce to_ty from_ty) expr)
 324   = coreToStgExpr (mkApps (Var unsafeCoerceId)
 325                           [Type from_ty, Type to_ty, expr])
 326 #endif
 327
 328 coreToStgExpr (Note other_note expr)
 329   = coreToStgExpr expr
 330
 331 -- Cases require a little more real work.
 332
 333 coreToStgExpr (Case scrut bndr alts)
 334   = extendVarEnvLne [(bndr, LambdaBound)]       (
 335          mapAndUnzip3Lne vars_alt alts  `thenLne` \ (alts2, fvs_s, escs_s) ->
 336          returnLne ( alts2,
 337                      unionFVInfos fvs_s,
 338                      unionVarSets escs_s )
 339     )                                   `thenLne` \ (alts2, alts_fvs, alts_escs) ->
 340     let
 341         -- Determine whether the default binder is dead or not
 342         -- This helps the code generator to avoid generating an assignment
 343         -- for the case binder (is extremely rare cases) ToDo: remove.
 344         bndr' | bndr `elementOfFVInfo` alts_fvs = bndr
 345               | otherwise                       = bndr `setIdOccInfo` IAmDead
 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         alts_fvs_wo_bndr  = bndr `minusFVBinder` alts_fvs
 351         alts_escs_wo_bndr = alts_escs `delVarSet` bndr
 352     in
 353
 354     freeVarsToLiveVars alts_fvs_wo_bndr         `thenLne` \ alts_lv_info ->
 355
 356         -- We tell the scrutinee that everything
 357         -- live in the alts is live in it, too.
 358     setVarsLiveInCont alts_lv_info (
 359         coreToStgExpr scrut       `thenLne` \ (scrut2, scrut_fvs, scrut_escs) ->
 360         freeVarsToLiveVars scrut_fvs `thenLne` \ scrut_lv_info ->
 361         returnLne (scrut2, scrut_fvs, scrut_escs, scrut_lv_info)
 362       )
 363                 `thenLne` \ (scrut2, scrut_fvs, scrut_escs, scrut_lv_info) ->
 364
 365     returnLne (
 366       StgCase scrut2 (getLiveVars scrut_lv_info)
 367                      (getLiveVars alts_lv_info)
 368                      bndr'
 369                      (mkSRT alts_lv_info)
 370                      (mkStgAltType (idType bndr))
 371                      alts2,
 372       scrut_fvs `unionFVInfo` alts_fvs_wo_bndr,
 373       alts_escs_wo_bndr `unionVarSet` getFVSet scrut_fvs
 374                 -- You might think we should have scrut_escs, not
 375                 -- (getFVSet scrut_fvs), but actually we can't call, and
 376                 -- then return from, a let-no-escape thing.
 377       )
 378   where
 379     vars_alt (con, binders, rhs)
 380       = let     -- Remove type variables
 381             binders' = filterStgBinders binders
 382         in
 383         extendVarEnvLne [(b, LambdaBound) | b <- binders']      $
 384         coreToStgExpr rhs       `thenLne` \ (rhs2, rhs_fvs, rhs_escs) ->
 385         let
 386                 -- Records whether each param is used in the RHS
 387             good_use_mask = [ b `elementOfFVInfo` rhs_fvs | b <- binders' ]
 388         in
 389         returnLne ( (con, binders', good_use_mask, rhs2),
 390                     binders' `minusFVBinders` rhs_fvs,
 391                     rhs_escs `delVarSetList` binders' )
 392                 -- ToDo: remove the delVarSet;
 393                 -- since escs won't include any of these binders
 394 \end{code}
 395
 396 Lets not only take quite a bit of work, but this is where we convert
 397 then to let-no-escapes, if we wish.
 398
 399 (Meanwhile, we don't expect to see let-no-escapes...)
 400 \begin{code}
 401 coreToStgExpr (Let bind body)
 402   = fixLne (\ ~(_, _, _, no_binder_escapes) ->
 403         coreToStgLet no_binder_escapes bind body
 404     )                           `thenLne` \ (new_let, fvs, escs, _) ->
 405
 406     returnLne (new_let, fvs, escs)
 407 \end{code}
 408
 409 \begin{code}
 410 mkStgAltType scrut_ty
 411   = case splitTyConApp_maybe (repType scrut_ty) of
 412         Just (tc,_) | isUnboxedTupleTyCon tc -> UbxTupAlt tc
 413                     | isPrimTyCon tc         -> PrimAlt tc
 414                     | isAlgTyCon tc          -> AlgAlt tc
 415                     | isFunTyCon tc          -> PolyAlt
 416                     | otherwise              -> pprPanic "mkStgAlts" (ppr tc)
 417         Nothing                              -> PolyAlt
 418 \end{code}
 419
 420
 421 -- ---------------------------------------------------------------------------
 422 -- Applications
 423 -- ---------------------------------------------------------------------------
 424
 425 \begin{code}
 426 coreToStgApp
 427          :: Maybe UpdateFlag            -- Just upd <=> this application is
 428                                         -- the rhs of a thunk binding
 429                                         --      x = [...] \upd [] -> the_app
 430                                         -- with specified update flag
 431         -> Id                           -- Function
 432         -> [CoreArg]                    -- Arguments
 433         -> LneM (StgExpr, FreeVarsInfo, EscVarsSet)
 434
 435 coreToStgApp maybe_thunk_body f args
 436   = coreToStgArgs args          `thenLne` \ (args', args_fvs) ->
 437     lookupVarLne f              `thenLne` \ how_bound ->
 438
 439     let
 440         n_val_args       = valArgCount args
 441         not_letrec_bound = not (isLetBound how_bound)
 442         fun_fvs
 443           = let fvs = singletonFVInfo f how_bound fun_occ in
 444             -- e.g. (f :: a -> int) (x :: a)
 445             -- Here the free variables are "f", "x" AND the type variable "a"
 446             -- coreToStgArgs will deal with the arguments recursively
 447             if opt_RuntimeTypes then
 448               fvs `unionFVInfo` tyvarFVInfo (tyVarsOfType (varType f))
 449             else fvs
 450
 451         -- Mostly, the arity info of a function is in the fn's IdInfo
 452         -- But new bindings introduced by CoreSat may not have no
 453         -- arity info; it would do us no good anyway.  For example:
 454         --      let f = \ab -> e in f
 455         -- No point in having correct arity info for f!
 456         -- Hence the hasArity stuff below.
 457         -- NB: f_arity is only consulted for LetBound things
 458         f_arity   = stgArity f how_bound
 459         saturated = f_arity <= n_val_args
 460
 461         fun_occ
 462          | not_letrec_bound         = noBinderInfo      -- Uninteresting variable
 463          | f_arity > 0 && saturated = stgSatOcc -- Saturated or over-saturated function call
 464          | otherwise                = stgUnsatOcc       -- Unsaturated function or thunk
 465
 466         fun_escs
 467          | not_letrec_bound      = emptyVarSet  -- Only letrec-bound escapees are interesting
 468          | f_arity == n_val_args = emptyVarSet  -- A function *or thunk* with an exactly
 469                                                 -- saturated call doesn't escape
 470                                                 -- (let-no-escape applies to 'thunks' too)
 471
 472          | otherwise         = unitVarSet f     -- Inexact application; it does escape
 473
 474         -- At the moment of the call:
 475
 476         --  either the function is *not* let-no-escaped, in which case
 477         --         nothing is live except live_in_cont
 478         --      or the function *is* let-no-escaped in which case the
 479         --         variables it uses are live, but still the function
 480         --         itself is not.  PS.  In this case, the function's
 481         --         live vars should already include those of the
 482         --         continuation, but it does no harm to just union the
 483         --         two regardless.
 484
 485         res_ty = exprType (mkApps (Var f) args)
 486         app = case globalIdDetails f of
 487                 DataConWorkId dc | saturated -> StgConApp dc args'
 488                 PrimOpId op                  -> ASSERT( saturated )
 489                                                 StgOpApp (StgPrimOp op) args' res_ty
 490                 FCallId call     -> ASSERT( saturated )
 491                                     StgOpApp (StgFCallOp call (idUnique f)) args' res_ty
 492                 _other           -> StgApp f args'
 493
 494     in
 495     returnLne (
 496         app,
 497         fun_fvs  `unionFVInfo` args_fvs,
 498         fun_escs `unionVarSet` (getFVSet args_fvs)
 499                                 -- All the free vars of the args are disqualified
 500                                 -- from being let-no-escaped.
 501     )
 502
 503
 504
 505 -- ---------------------------------------------------------------------------
 506 -- Argument lists
 507 -- This is the guy that turns applications into A-normal form
 508 -- ---------------------------------------------------------------------------
 509
 510 coreToStgArgs :: [CoreArg] -> LneM ([StgArg], FreeVarsInfo)
 511 coreToStgArgs []
 512   = returnLne ([], emptyFVInfo)
 513
 514 coreToStgArgs (Type ty : args)  -- Type argument
 515   = coreToStgArgs args  `thenLne` \ (args', fvs) ->
 516     if opt_RuntimeTypes then
 517         returnLne (StgTypeArg ty : args', fvs `unionFVInfo` tyvarFVInfo (tyVarsOfType ty))
 518     else
 519     returnLne (args', fvs)
 520
 521 coreToStgArgs (arg : args)      -- Non-type argument
 522   = coreToStgArgs args  `thenLne` \ (stg_args, args_fvs) ->
 523     coreToStgExpr arg   `thenLne` \ (arg', arg_fvs, escs) ->
 524     let
 525         fvs = args_fvs `unionFVInfo` arg_fvs
 526         stg_arg = case arg' of
 527                        StgApp v []      -> StgVarArg v
 528                        StgConApp con [] -> StgVarArg (dataConWorkId con)
 529                        StgLit lit       -> StgLitArg lit
 530                        _                -> pprPanic "coreToStgArgs" (ppr arg)
 531     in
 532     returnLne (stg_arg : stg_args, fvs)
 533
 534
 535 -- ---------------------------------------------------------------------------
 536 -- The magic for lets:
 537 -- ---------------------------------------------------------------------------
 538
 539 coreToStgLet
 540          :: Bool        -- True <=> yes, we are let-no-escaping this let
 541          -> CoreBind    -- bindings
 542          -> CoreExpr    -- body
 543          -> LneM (StgExpr,      -- new let
 544                   FreeVarsInfo, -- variables free in the whole let
 545                   EscVarsSet,   -- variables that escape from the whole let
 546                   Bool)         -- True <=> none of the binders in the bindings
 547                                 -- is among the escaping vars
 548
 549 coreToStgLet let_no_escape bind body
 550   = fixLne (\ ~(_, _, _, _, _, rec_body_fvs, _, _) ->
 551
 552         -- Do the bindings, setting live_in_cont to empty if
 553         -- we ain't in a let-no-escape world
 554         getVarsLiveInCont               `thenLne` \ live_in_cont ->
 555         setVarsLiveInCont (if let_no_escape
 556                                 then live_in_cont
 557                                 else emptyLiveInfo)
 558                           (vars_bind rec_body_fvs bind)
 559             `thenLne` \ ( bind2, bind_fvs, bind_escs, bind_lv_info, env_ext) ->
 560
 561         -- Do the body
 562         extendVarEnvLne env_ext (
 563           coreToStgExpr body          `thenLne` \(body2, body_fvs, body_escs) ->
 564           freeVarsToLiveVars body_fvs `thenLne` \ body_lv_info ->
 565
 566           returnLne (bind2, bind_fvs, bind_escs, getLiveVars bind_lv_info,
 567                      body2, body_fvs, body_escs, getLiveVars body_lv_info)
 568         )
 569
 570     ) `thenLne` (\ (bind2, bind_fvs, bind_escs, bind_lvs,
 571                     body2, body_fvs, body_escs, body_lvs) ->
 572
 573
 574         -- Compute the new let-expression
 575     let
 576         new_let | let_no_escape = StgLetNoEscape live_in_whole_let bind_lvs bind2 body2
 577                 | otherwise     = StgLet bind2 body2
 578
 579         free_in_whole_let
 580           = binders `minusFVBinders` (bind_fvs `unionFVInfo` body_fvs)
 581
 582         live_in_whole_let
 583           = bind_lvs `unionVarSet` (body_lvs `delVarSetList` binders)
 584
 585         real_bind_escs = if let_no_escape then
 586                             bind_escs
 587                          else
 588                             getFVSet bind_fvs
 589                             -- Everything escapes which is free in the bindings
 590
 591         let_escs = (real_bind_escs `unionVarSet` body_escs) `delVarSetList` binders
 592
 593         all_escs = bind_escs `unionVarSet` body_escs    -- Still includes binders of
 594                                                         -- this let(rec)
 595
 596         no_binder_escapes = isEmptyVarSet (set_of_binders `intersectVarSet` all_escs)
 597
 598 #ifdef DEBUG
 599         -- Debugging code as requested by Andrew Kennedy
 600         checked_no_binder_escapes
 601                 | not no_binder_escapes && any is_join_var binders
 602                 = pprTrace "Interesting!  A join var that isn't let-no-escaped" (ppr binders)
 603                   False
 604                 | otherwise = no_binder_escapes
 605 #else
 606         checked_no_binder_escapes = no_binder_escapes
 607 #endif
 608
 609                 -- Mustn't depend on the passed-in let_no_escape flag, since
 610                 -- no_binder_escapes is used by the caller to derive the flag!
 611     in
 612     returnLne (
 613         new_let,
 614         free_in_whole_let,
 615         let_escs,
 616         checked_no_binder_escapes
 617     ))
 618   where
 619     set_of_binders = mkVarSet binders
 620     binders        = bindersOf bind
 621
 622     mk_binding bind_lv_info binder rhs
 623         = (binder, LetBound (NestedLet live_vars) (manifestArity rhs))
 624         where
 625            live_vars | let_no_escape = addLiveVar bind_lv_info binder
 626                      | otherwise     = unitLiveVar binder
 627                 -- c.f. the invariant on NestedLet
 628
 629     vars_bind :: FreeVarsInfo           -- Free var info for body of binding
 630               -> CoreBind
 631               -> LneM (StgBinding,
 632                        FreeVarsInfo,
 633                        EscVarsSet,        -- free vars; escapee vars
 634                        LiveInfo,          -- Vars and CAFs live in binding
 635                        [(Id, HowBound)])  -- extension to environment
 636
 637
 638     vars_bind body_fvs (NonRec binder rhs)
 639       = coreToStgRhs body_fvs [] (binder,rhs)
 640                                 `thenLne` \ (rhs2, bind_fvs, bind_lv_info, escs) ->
 641         let
 642             env_ext_item = mk_binding bind_lv_info binder rhs
 643         in
 644         returnLne (StgNonRec binder rhs2,
 645                    bind_fvs, escs, bind_lv_info, [env_ext_item])
 646
 647
 648     vars_bind body_fvs (Rec pairs)
 649       = fixLne (\ ~(_, rec_rhs_fvs, _, bind_lv_info, _) ->
 650            let
 651                 rec_scope_fvs = unionFVInfo body_fvs rec_rhs_fvs
 652                 binders = map fst pairs
 653                 env_ext = [ mk_binding bind_lv_info b rhs
 654                           | (b,rhs) <- pairs ]
 655            in
 656            extendVarEnvLne env_ext (
 657               mapAndUnzip4Lne (coreToStgRhs rec_scope_fvs binders) pairs
 658                                         `thenLne` \ (rhss2, fvss, lv_infos, escss) ->
 659               let
 660                         bind_fvs = unionFVInfos fvss
 661                         bind_lv_info = foldr unionLiveInfo emptyLiveInfo lv_infos
 662                         escs     = unionVarSets escss
 663               in
 664               returnLne (StgRec (binders `zip` rhss2),
 665                          bind_fvs, escs, bind_lv_info, env_ext)
 666            )
 667         )
 668
 669 is_join_var :: Id -> Bool
 670 -- A hack (used only for compiler debuggging) to tell if
 671 -- a variable started life as a join point ($j)
 672 is_join_var j = occNameUserString (getOccName j) == "$j"
 673 \end{code}
 674
 675 \begin{code}
 676 coreToStgRhs :: FreeVarsInfo            -- Free var info for the scope of the binding
 677              -> [Id]
 678              -> (Id,CoreExpr)
 679              -> LneM (StgRhs, FreeVarsInfo, LiveInfo, EscVarsSet)
 680
 681 coreToStgRhs scope_fv_info binders (bndr, rhs)
 682   = coreToStgExpr rhs           `thenLne` \ (new_rhs, rhs_fvs, rhs_escs) ->
 683     getEnvLne                   `thenLne` \ env ->
 684     freeVarsToLiveVars (binders `minusFVBinders` rhs_fvs) `thenLne` \ lv_info ->
 685     returnLne (mkStgRhs rhs_fvs (mkSRT lv_info) bndr_info new_rhs,
 686                rhs_fvs, lv_info, rhs_escs)
 687   where
 688     bndr_info = lookupFVInfo scope_fv_info bndr
 689
 690 mkStgRhs :: FreeVarsInfo -> SRT -> StgBinderInfo -> StgExpr -> StgRhs
 691
 692 mkStgRhs rhs_fvs srt binder_info (StgConApp con args)
 693   = StgRhsCon noCCS con args
 694
 695 mkStgRhs rhs_fvs srt binder_info (StgLam _ bndrs body)
 696   = StgRhsClosure noCCS binder_info
 697                   (getFVs rhs_fvs)
 698                   ReEntrant
 699                   srt bndrs body
 700
 701 mkStgRhs rhs_fvs srt binder_info rhs
 702   = StgRhsClosure noCCS binder_info
 703                   (getFVs rhs_fvs)
 704                   upd_flag srt [] rhs
 705   where
 706    upd_flag = Updatable
 707   {-
 708     SDM: disabled.  Eval/Apply can't handle functions with arity zero very
 709     well; and making these into simple non-updatable thunks breaks other
 710     assumptions (namely that they will be entered only once).
 711
 712     upd_flag | isPAP env rhs  = ReEntrant
 713              | otherwise      = Updatable
 714   -}
 715
 716 {- ToDo:
 717           upd = if isOnceDem dem
 718                     then (if isNotTop toplev
 719                             then SingleEntry    -- HA!  Paydirt for "dem"
 720                             else
 721 #ifdef DEBUG
 722                      trace "WARNING: SE CAFs unsupported, forcing UPD instead" $
 723 #endif
 724                      Updatable)
 725                 else Updatable
 726         -- For now we forbid SingleEntry CAFs; they tickle the
 727         -- ASSERT in rts/Storage.c line 215 at newCAF() re mut_link,
 728         -- and I don't understand why.  There's only one SE_CAF (well,
 729         -- only one that tickled a great gaping bug in an earlier attempt
 730         -- at ClosureInfo.getEntryConvention) in the whole of nofib,
 731         -- specifically Main.lvl6 in spectral/cryptarithm2.
 732         -- So no great loss.  KSW 2000-07.
 733 -}
 734 \end{code}
 735
 736 Detect thunks which will reduce immediately to PAPs, and make them
 737 non-updatable.  This has several advantages:
 738
 739         - the non-updatable thunk behaves exactly like the PAP,
 740
 741         - the thunk is more efficient to enter, because it is
 742           specialised to the task.
 743
 744         - we save one update frame, one stg_update_PAP, one update
 745           and lots of PAP_enters.
 746
 747         - in the case where the thunk is top-level, we save building
 748           a black hole and futhermore the thunk isn't considered to
 749           be a CAF any more, so it doesn't appear in any SRTs.
 750
 751 We do it here, because the arity information is accurate, and we need
 752 to do it before the SRT pass to save the SRT entries associated with
 753 any top-level PAPs.
 754
 755 isPAP env (StgApp f args) = listLengthCmp args arity == LT -- idArity f > length args
 756                           where
 757                             arity = stgArity f (lookupBinding env f)
 758 isPAP env _               = False
 759
 760
 761 %************************************************************************
 762 %*                                                                      *
 763 \subsection[LNE-monad]{A little monad for this let-no-escaping pass}
 764 %*                                                                      *
 765 %************************************************************************
 766
 767 There's a lot of stuff to pass around, so we use this @LneM@ monad to
 768 help.  All the stuff here is only passed *down*.
 769
 770 \begin{code}
 771 type LneM a =  IdEnv HowBound
 772             -> LiveInfo         -- Vars and CAFs live in continuation
 773             -> a
 774
 775 type LiveInfo = (StgLiveVars,   -- Dynamic live variables;
 776                                 -- i.e. ones with a nested (non-top-level) binding
 777                  CafSet)        -- Static live variables;
 778                                 -- i.e. top-level variables that are CAFs or refer to them
 779
 780 type EscVarsSet = IdSet
 781 type CafSet     = IdSet
 782
 783 data HowBound
 784   = ImportBound         -- Used only as a response to lookupBinding; never
 785                         -- exists in the range of the (IdEnv HowBound)
 786
 787   | LetBound            -- A let(rec) in this module
 788         LetInfo         -- Whether top level or nested
 789         Arity           -- Its arity (local Ids don't have arity info at this point)
 790
 791   | LambdaBound         -- Used for both lambda and case
 792
 793 data LetInfo
 794   = TopLet              -- top level things
 795   | NestedLet LiveInfo  -- For nested things, what is live if this
 796                         -- thing is live?  Invariant: the binder
 797                         -- itself is always a member of
 798                         -- the dynamic set of its own LiveInfo
 799
 800 isLetBound (LetBound _ _) = True
 801 isLetBound other          = False
 802
 803 topLevelBound ImportBound         = True
 804 topLevelBound (LetBound TopLet _) = True
 805 topLevelBound other               = False
 806 \end{code}
 807
 808 For a let(rec)-bound variable, x, we record LiveInfo, the set of
 809 variables that are live if x is live.  This LiveInfo comprises
 810         (a) dynamic live variables (ones with a non-top-level binding)
 811         (b) static live variabes (CAFs or things that refer to CAFs)
 812
 813 For "normal" variables (a) is just x alone.  If x is a let-no-escaped
 814 variable then x is represented by a code pointer and a stack pointer
 815 (well, one for each stack).  So all of the variables needed in the
 816 execution of x are live if x is, and are therefore recorded in the
 817 LetBound constructor; x itself *is* included.
 818
 819 The set of dynamic live variables is guaranteed ot have no further let-no-escaped
 820 variables in it.
 821
 822 \begin{code}
 823 emptyLiveInfo :: LiveInfo
 824 emptyLiveInfo = (emptyVarSet,emptyVarSet)
 825
 826 unitLiveVar :: Id -> LiveInfo
 827 unitLiveVar lv = (unitVarSet lv, emptyVarSet)
 828
 829 unitLiveCaf :: Id -> LiveInfo
 830 unitLiveCaf caf = (emptyVarSet, unitVarSet caf)
 831
 832 addLiveVar :: LiveInfo -> Id -> LiveInfo
 833 addLiveVar (lvs, cafs) id = (lvs `extendVarSet` id, cafs)
 834
 835 unionLiveInfo :: LiveInfo -> LiveInfo -> LiveInfo
 836 unionLiveInfo (lv1,caf1) (lv2,caf2) = (lv1 `unionVarSet` lv2, caf1 `unionVarSet` caf2)
 837
 838 mkSRT :: LiveInfo -> SRT
 839 mkSRT (_, cafs) = SRTEntries cafs
 840
 841 getLiveVars :: LiveInfo -> StgLiveVars
 842 getLiveVars (lvs, _) = lvs
 843 \end{code}
 844
 845
 846 The std monad functions:
 847 \begin{code}
 848 initLne :: IdEnv HowBound -> LneM a -> a
 849 initLne env m = m env emptyLiveInfo
 850
 851
 852
 853 {-# INLINE thenLne #-}
 854 {-# INLINE returnLne #-}
 855
 856 returnLne :: a -> LneM a
 857 returnLne e env lvs_cont = e
 858
 859 thenLne :: LneM a -> (a -> LneM b) -> LneM b
 860 thenLne m k env lvs_cont
 861   = k (m env lvs_cont) env lvs_cont
 862
 863 mapLne  :: (a -> LneM b)   -> [a] -> LneM [b]
 864 mapLne f [] = returnLne []
 865 mapLne f (x:xs)
 866   = f x         `thenLne` \ r  ->
 867     mapLne f xs `thenLne` \ rs ->
 868     returnLne (r:rs)
 869
 870 mapAndUnzipLne  :: (a -> LneM (b,c))   -> [a] -> LneM ([b],[c])
 871
 872 mapAndUnzipLne f [] = returnLne ([],[])
 873 mapAndUnzipLne f (x:xs)
 874   = f x                 `thenLne` \ (r1,  r2)  ->
 875     mapAndUnzipLne f xs `thenLne` \ (rs1, rs2) ->
 876     returnLne (r1:rs1, r2:rs2)
 877
 878 mapAndUnzip3Lne :: (a -> LneM (b,c,d)) -> [a] -> LneM ([b],[c],[d])
 879
 880 mapAndUnzip3Lne f []    = returnLne ([],[],[])
 881 mapAndUnzip3Lne f (x:xs)
 882   = f x                  `thenLne` \ (r1,  r2,  r3)  ->
 883     mapAndUnzip3Lne f xs `thenLne` \ (rs1, rs2, rs3) ->
 884     returnLne (r1:rs1, r2:rs2, r3:rs3)
 885
 886 mapAndUnzip4Lne :: (a -> LneM (b,c,d,e)) -> [a] -> LneM ([b],[c],[d],[e])
 887
 888 mapAndUnzip4Lne f []    = returnLne ([],[],[],[])
 889 mapAndUnzip4Lne f (x:xs)
 890   = f x                  `thenLne` \ (r1,  r2,  r3, r4)  ->
 891     mapAndUnzip4Lne f xs `thenLne` \ (rs1, rs2, rs3, rs4) ->
 892     returnLne (r1:rs1, r2:rs2, r3:rs3, r4:rs4)
 893
 894 fixLne :: (a -> LneM a) -> LneM a
 895 fixLne expr env lvs_cont
 896   = result
 897   where
 898     result = expr result env lvs_cont
 899 \end{code}
 900
 901 Functions specific to this monad:
 902
 903 \begin{code}
 904 getVarsLiveInCont :: LneM LiveInfo
 905 getVarsLiveInCont env lvs_cont = lvs_cont
 906
 907 setVarsLiveInCont :: LiveInfo -> LneM a -> LneM a
 908 setVarsLiveInCont new_lvs_cont expr env lvs_cont
 909   = expr env new_lvs_cont
 910
 911 extendVarEnvLne :: [(Id, HowBound)] -> LneM a -> LneM a
 912 extendVarEnvLne ids_w_howbound expr env lvs_cont
 913   = expr (extendVarEnvList env ids_w_howbound) lvs_cont
 914
 915 lookupVarLne :: Id -> LneM HowBound
 916 lookupVarLne v env lvs_cont = returnLne (lookupBinding env v) env lvs_cont
 917
 918 getEnvLne :: LneM (IdEnv HowBound)
 919 getEnvLne env lvs_cont = returnLne env env lvs_cont
 920
 921 lookupBinding :: IdEnv HowBound -> Id -> HowBound
 922 lookupBinding env v = case lookupVarEnv env v of
 923                         Just xx -> xx
 924                         Nothing -> ASSERT2( isGlobalId v, ppr v ) ImportBound
 925
 926
 927 -- The result of lookupLiveVarsForSet, a set of live variables, is
 928 -- only ever tacked onto a decorated expression. It is never used as
 929 -- the basis of a control decision, which might give a black hole.
 930
 931 freeVarsToLiveVars :: FreeVarsInfo -> LneM LiveInfo
 932 freeVarsToLiveVars fvs env live_in_cont
 933   = returnLne live_info env live_in_cont
 934   where
 935     live_info    = foldr unionLiveInfo live_in_cont lvs_from_fvs
 936     lvs_from_fvs = map do_one (allFreeIds fvs)
 937
 938     do_one (v, how_bound)
 939       = case how_bound of
 940           ImportBound                     -> unitLiveCaf v      -- Only CAF imports are
 941                                                                 -- recorded in fvs
 942           LetBound TopLet _
 943                 | mayHaveCafRefs (idCafInfo v) -> unitLiveCaf v
 944                 | otherwise                    -> emptyLiveInfo
 945
 946           LetBound (NestedLet lvs) _      -> lvs        -- lvs already contains v
 947                                                         -- (see the invariant on NestedLet)
 948
 949           _lambda_or_case_binding         -> unitLiveVar v      -- Bound by lambda or case
 950 \end{code}
 951
 952 %************************************************************************
 953 %*                                                                      *
 954 \subsection[Free-var info]{Free variable information}
 955 %*                                                                      *
 956 %************************************************************************
 957
 958 \begin{code}
 959 type FreeVarsInfo = VarEnv (Var, HowBound, StgBinderInfo)
 960         -- The Var is so we can gather up the free variables
 961         -- as a set.
 962         --
 963         -- The HowBound info just saves repeated lookups;
 964         -- we look up just once when we encounter the occurrence.
 965         -- INVARIANT: Any ImportBound Ids are HaveCafRef Ids
 966         --            Imported Ids without CAF refs are simply
 967         --            not put in the FreeVarsInfo for an expression.
 968         --            See singletonFVInfo and freeVarsToLiveVars
 969         --
 970         -- StgBinderInfo records how it occurs; notably, we
 971         -- are interested in whether it only occurs in saturated
 972         -- applications, because then we don't need to build a
 973         -- curried version.
 974         -- If f is mapped to noBinderInfo, that means
 975         -- that f *is* mentioned (else it wouldn't be in the
 976         -- IdEnv at all), but perhaps in an unsaturated applications.
 977         --
 978         -- All case/lambda-bound things are also mapped to
 979         -- noBinderInfo, since we aren't interested in their
 980         -- occurence info.
 981         --
 982         -- For ILX we track free var info for type variables too;
 983         -- hence VarEnv not IdEnv
 984 \end{code}
 985
 986 \begin{code}
 987 emptyFVInfo :: FreeVarsInfo
 988 emptyFVInfo = emptyVarEnv
 989
 990 singletonFVInfo :: Id -> HowBound -> StgBinderInfo -> FreeVarsInfo
 991 -- Don't record non-CAF imports at all, to keep free-var sets small
 992 singletonFVInfo id ImportBound info
 993    | mayHaveCafRefs (idCafInfo id) = unitVarEnv id (id, ImportBound, info)
 994    | otherwise                     = emptyVarEnv
 995 singletonFVInfo id how_bound info  = unitVarEnv id (id, how_bound, info)
 996
 997 tyvarFVInfo :: TyVarSet -> FreeVarsInfo
 998 tyvarFVInfo tvs = foldVarSet add emptyFVInfo tvs
 999         where
1000           add tv fvs = extendVarEnv fvs tv (tv, LambdaBound, noBinderInfo)
1001                 -- Type variables must be lambda-bound
1002
1003 unionFVInfo :: FreeVarsInfo -> FreeVarsInfo -> FreeVarsInfo
1004 unionFVInfo fv1 fv2 = plusVarEnv_C plusFVInfo fv1 fv2
1005
1006 unionFVInfos :: [FreeVarsInfo] -> FreeVarsInfo
1007 unionFVInfos fvs = foldr unionFVInfo emptyFVInfo fvs
1008
1009 minusFVBinders :: [Id] -> FreeVarsInfo -> FreeVarsInfo
1010 minusFVBinders vs fv = foldr minusFVBinder fv vs
1011
1012 minusFVBinder :: Id -> FreeVarsInfo -> FreeVarsInfo
1013 minusFVBinder v fv | isId v && opt_RuntimeTypes
1014                    = (fv `delVarEnv` v) `unionFVInfo`
1015                      tyvarFVInfo (tyVarsOfType (idType v))
1016                    | otherwise = fv `delVarEnv` v
1017         -- When removing a binder, remember to add its type variables
1018         -- c.f. CoreFVs.delBinderFV
1019
1020 elementOfFVInfo :: Id -> FreeVarsInfo -> Bool
1021 elementOfFVInfo id fvs = maybeToBool (lookupVarEnv fvs id)
1022
1023 lookupFVInfo :: FreeVarsInfo -> Id -> StgBinderInfo
1024 -- Find how the given Id is used.
1025 -- Externally visible things may be used any old how
1026 lookupFVInfo fvs id
1027   | isExternalName (idName id) = noBinderInfo
1028   | otherwise = case lookupVarEnv fvs id of
1029                         Nothing         -> noBinderInfo
1030                         Just (_,_,info) -> info
1031
1032 allFreeIds :: FreeVarsInfo -> [(Id,HowBound)]   -- Both top level and non-top-level Ids
1033 allFreeIds fvs = [(id,how_bound) | (id,how_bound,_) <- rngVarEnv fvs, isId id]
1034
1035 -- Non-top-level things only, both type variables and ids
1036 -- (type variables only if opt_RuntimeTypes)
1037 getFVs :: FreeVarsInfo -> [Var]
1038 getFVs fvs = [id | (id, how_bound, _) <- rngVarEnv fvs,
1039                     not (topLevelBound how_bound) ]
1040
1041 getFVSet :: FreeVarsInfo -> VarSet
1042 getFVSet fvs = mkVarSet (getFVs fvs)
1043
1044 plusFVInfo (id1,hb1,info1) (id2,hb2,info2)
1045   = ASSERT (id1 == id2 && hb1 `check_eq_how_bound` hb2)
1046     (id1, hb1, combineStgBinderInfo info1 info2)
1047
1048 #ifdef DEBUG
1049 -- The HowBound info for a variable in the FVInfo should be consistent
1050 check_eq_how_bound ImportBound        ImportBound        = True
1051 check_eq_how_bound LambdaBound        LambdaBound        = True
1052 check_eq_how_bound (LetBound li1 ar1) (LetBound li2 ar2) = ar1 == ar2 && check_eq_li li1 li2
1053 check_eq_how_bound hb1                hb2                = False
1054
1055 check_eq_li (NestedLet _) (NestedLet _) = True
1056 check_eq_li TopLet        TopLet        = True
1057 check_eq_li li1           li2           = False
1058 #endif
1059 \end{code}
1060
1061 Misc.
1062 \begin{code}
1063 filterStgBinders :: [Var] -> [Var]
1064 filterStgBinders bndrs
1065   | opt_RuntimeTypes = bndrs
1066   | otherwise        = filter isId bndrs
1067 \end{code}
1068
1069
1070 \begin{code}
1071         -- Ignore all notes except SCC
1072 myCollectBinders expr
1073   = go [] expr
1074   where
1075     go bs (Lam b e)          = go (b:bs) e
1076     go bs e@(Note (SCC _) _) = (reverse bs, e)
1077     go bs (Note _ e)         = go bs e
1078     go bs e                  = (reverse bs, e)
1079
1080 myCollectArgs :: CoreExpr -> (Id, [CoreArg])
1081         -- We assume that we only have variables
1082         -- in the function position by now
1083 myCollectArgs expr
1084   = go expr []
1085   where
1086     go (Var v)          as = (v, as)
1087     go (App f a) as        = go f (a:as)
1088     go (Note (SCC _) e) as = pprPanic "CoreToStg.myCollectArgs" (ppr expr)
1089     go (Note n e)       as = go e as
1090     go _                as = pprPanic "CoreToStg.myCollectArgs" (ppr expr)
1091 \end{code}
1092
1093 \begin{code}
1094 stgArity :: Id -> HowBound -> Arity
1095 stgArity f (LetBound _ arity) = arity
1096 stgArity f ImportBound        = idArity f
1097 stgArity f LambdaBound        = 0
1098 \end{code}