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, idType )
  22 import TyCon            ( isUnboxedTupleTyCon, isPrimTyCon, isFunTyCon, isHiBootTyCon )
  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   = ASSERT2( not is_static, ppr rhs )
 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                     | isHiBootTyCon tc       -> PolyAlt -- Algebraic, but no constructors visible
 415                     | isAlgTyCon tc          -> AlgAlt tc
 416                     | isFunTyCon tc          -> PolyAlt
 417                     | otherwise              -> pprPanic "mkStgAlts" (ppr tc)
 418         Nothing                              -> PolyAlt
 419 \end{code}
 420
 421
 422 -- ---------------------------------------------------------------------------
 423 -- Applications
 424 -- ---------------------------------------------------------------------------
 425
 426 \begin{code}
 427 coreToStgApp
 428          :: Maybe UpdateFlag            -- Just upd <=> this application is
 429                                         -- the rhs of a thunk binding
 430                                         --      x = [...] \upd [] -> the_app
 431                                         -- with specified update flag
 432         -> Id                           -- Function
 433         -> [CoreArg]                    -- Arguments
 434         -> LneM (StgExpr, FreeVarsInfo, EscVarsSet)
 435
 436 coreToStgApp maybe_thunk_body f args
 437   = coreToStgArgs args          `thenLne` \ (args', args_fvs) ->
 438     lookupVarLne f              `thenLne` \ how_bound ->
 439
 440     let
 441         n_val_args       = valArgCount args
 442         not_letrec_bound = not (isLetBound how_bound)
 443         fun_fvs
 444           = let fvs = singletonFVInfo f how_bound fun_occ in
 445             -- e.g. (f :: a -> int) (x :: a)
 446             -- Here the free variables are "f", "x" AND the type variable "a"
 447             -- coreToStgArgs will deal with the arguments recursively
 448             if opt_RuntimeTypes then
 449               fvs `unionFVInfo` tyvarFVInfo (tyVarsOfType (idType f))
 450             else fvs
 451
 452         -- Mostly, the arity info of a function is in the fn's IdInfo
 453         -- But new bindings introduced by CoreSat may not have no
 454         -- arity info; it would do us no good anyway.  For example:
 455         --      let f = \ab -> e in f
 456         -- No point in having correct arity info for f!
 457         -- Hence the hasArity stuff below.
 458         -- NB: f_arity is only consulted for LetBound things
 459         f_arity   = stgArity f how_bound
 460         saturated = f_arity <= n_val_args
 461
 462         fun_occ
 463          | not_letrec_bound         = noBinderInfo      -- Uninteresting variable
 464          | f_arity > 0 && saturated = stgSatOcc -- Saturated or over-saturated function call
 465          | otherwise                = stgUnsatOcc       -- Unsaturated function or thunk
 466
 467         fun_escs
 468          | not_letrec_bound      = emptyVarSet  -- Only letrec-bound escapees are interesting
 469          | f_arity == n_val_args = emptyVarSet  -- A function *or thunk* with an exactly
 470                                                 -- saturated call doesn't escape
 471                                                 -- (let-no-escape applies to 'thunks' too)
 472
 473          | otherwise         = unitVarSet f     -- Inexact application; it does escape
 474
 475         -- At the moment of the call:
 476
 477         --  either the function is *not* let-no-escaped, in which case
 478         --         nothing is live except live_in_cont
 479         --      or the function *is* let-no-escaped in which case the
 480         --         variables it uses are live, but still the function
 481         --         itself is not.  PS.  In this case, the function's
 482         --         live vars should already include those of the
 483         --         continuation, but it does no harm to just union the
 484         --         two regardless.
 485
 486         res_ty = exprType (mkApps (Var f) args)
 487         app = case globalIdDetails f of
 488                 DataConWorkId dc | saturated -> StgConApp dc args'
 489                 PrimOpId op                  -> ASSERT( saturated )
 490                                                 StgOpApp (StgPrimOp op) args' res_ty
 491                 FCallId call     -> ASSERT( saturated )
 492                                     StgOpApp (StgFCallOp call (idUnique f)) args' res_ty
 493                 _other           -> StgApp f args'
 494
 495     in
 496     returnLne (
 497         app,
 498         fun_fvs  `unionFVInfo` args_fvs,
 499         fun_escs `unionVarSet` (getFVSet args_fvs)
 500                                 -- All the free vars of the args are disqualified
 501                                 -- from being let-no-escaped.
 502     )
 503
 504
 505
 506 -- ---------------------------------------------------------------------------
 507 -- Argument lists
 508 -- This is the guy that turns applications into A-normal form
 509 -- ---------------------------------------------------------------------------
 510
 511 coreToStgArgs :: [CoreArg] -> LneM ([StgArg], FreeVarsInfo)
 512 coreToStgArgs []
 513   = returnLne ([], emptyFVInfo)
 514
 515 coreToStgArgs (Type ty : args)  -- Type argument
 516   = coreToStgArgs args  `thenLne` \ (args', fvs) ->
 517     if opt_RuntimeTypes then
 518         returnLne (StgTypeArg ty : args', fvs `unionFVInfo` tyvarFVInfo (tyVarsOfType ty))
 519     else
 520     returnLne (args', fvs)
 521
 522 coreToStgArgs (arg : args)      -- Non-type argument
 523   = coreToStgArgs args  `thenLne` \ (stg_args, args_fvs) ->
 524     coreToStgExpr arg   `thenLne` \ (arg', arg_fvs, escs) ->
 525     let
 526         fvs = args_fvs `unionFVInfo` arg_fvs
 527         stg_arg = case arg' of
 528                        StgApp v []      -> StgVarArg v
 529                        StgConApp con [] -> StgVarArg (dataConWorkId con)
 530                        StgLit lit       -> StgLitArg lit
 531                        _                -> pprPanic "coreToStgArgs" (ppr arg)
 532     in
 533     returnLne (stg_arg : stg_args, fvs)
 534
 535
 536 -- ---------------------------------------------------------------------------
 537 -- The magic for lets:
 538 -- ---------------------------------------------------------------------------
 539
 540 coreToStgLet
 541          :: Bool        -- True <=> yes, we are let-no-escaping this let
 542          -> CoreBind    -- bindings
 543          -> CoreExpr    -- body
 544          -> LneM (StgExpr,      -- new let
 545                   FreeVarsInfo, -- variables free in the whole let
 546                   EscVarsSet,   -- variables that escape from the whole let
 547                   Bool)         -- True <=> none of the binders in the bindings
 548                                 -- is among the escaping vars
 549
 550 coreToStgLet let_no_escape bind body
 551   = fixLne (\ ~(_, _, _, _, _, rec_body_fvs, _, _) ->
 552
 553         -- Do the bindings, setting live_in_cont to empty if
 554         -- we ain't in a let-no-escape world
 555         getVarsLiveInCont               `thenLne` \ live_in_cont ->
 556         setVarsLiveInCont (if let_no_escape
 557                                 then live_in_cont
 558                                 else emptyLiveInfo)
 559                           (vars_bind rec_body_fvs bind)
 560             `thenLne` \ ( bind2, bind_fvs, bind_escs, bind_lv_info, env_ext) ->
 561
 562         -- Do the body
 563         extendVarEnvLne env_ext (
 564           coreToStgExpr body          `thenLne` \(body2, body_fvs, body_escs) ->
 565           freeVarsToLiveVars body_fvs `thenLne` \ body_lv_info ->
 566
 567           returnLne (bind2, bind_fvs, bind_escs, getLiveVars bind_lv_info,
 568                      body2, body_fvs, body_escs, getLiveVars body_lv_info)
 569         )
 570
 571     ) `thenLne` (\ (bind2, bind_fvs, bind_escs, bind_lvs,
 572                     body2, body_fvs, body_escs, body_lvs) ->
 573
 574
 575         -- Compute the new let-expression
 576     let
 577         new_let | let_no_escape = StgLetNoEscape live_in_whole_let bind_lvs bind2 body2
 578                 | otherwise     = StgLet bind2 body2
 579
 580         free_in_whole_let
 581           = binders `minusFVBinders` (bind_fvs `unionFVInfo` body_fvs)
 582
 583         live_in_whole_let
 584           = bind_lvs `unionVarSet` (body_lvs `delVarSetList` binders)
 585
 586         real_bind_escs = if let_no_escape then
 587                             bind_escs
 588                          else
 589                             getFVSet bind_fvs
 590                             -- Everything escapes which is free in the bindings
 591
 592         let_escs = (real_bind_escs `unionVarSet` body_escs) `delVarSetList` binders
 593
 594         all_escs = bind_escs `unionVarSet` body_escs    -- Still includes binders of
 595                                                         -- this let(rec)
 596
 597         no_binder_escapes = isEmptyVarSet (set_of_binders `intersectVarSet` all_escs)
 598
 599 #ifdef DEBUG
 600         -- Debugging code as requested by Andrew Kennedy
 601         checked_no_binder_escapes
 602                 | not no_binder_escapes && any is_join_var binders
 603                 = pprTrace "Interesting!  A join var that isn't let-no-escaped" (ppr binders)
 604                   False
 605                 | otherwise = no_binder_escapes
 606 #else
 607         checked_no_binder_escapes = no_binder_escapes
 608 #endif
 609
 610                 -- Mustn't depend on the passed-in let_no_escape flag, since
 611                 -- no_binder_escapes is used by the caller to derive the flag!
 612     in
 613     returnLne (
 614         new_let,
 615         free_in_whole_let,
 616         let_escs,
 617         checked_no_binder_escapes
 618     ))
 619   where
 620     set_of_binders = mkVarSet binders
 621     binders        = bindersOf bind
 622
 623     mk_binding bind_lv_info binder rhs
 624         = (binder, LetBound (NestedLet live_vars) (manifestArity rhs))
 625         where
 626            live_vars | let_no_escape = addLiveVar bind_lv_info binder
 627                      | otherwise     = unitLiveVar binder
 628                 -- c.f. the invariant on NestedLet
 629
 630     vars_bind :: FreeVarsInfo           -- Free var info for body of binding
 631               -> CoreBind
 632               -> LneM (StgBinding,
 633                        FreeVarsInfo,
 634                        EscVarsSet,        -- free vars; escapee vars
 635                        LiveInfo,          -- Vars and CAFs live in binding
 636                        [(Id, HowBound)])  -- extension to environment
 637
 638
 639     vars_bind body_fvs (NonRec binder rhs)
 640       = coreToStgRhs body_fvs [] (binder,rhs)
 641                                 `thenLne` \ (rhs2, bind_fvs, bind_lv_info, escs) ->
 642         let
 643             env_ext_item = mk_binding bind_lv_info binder rhs
 644         in
 645         returnLne (StgNonRec binder rhs2,
 646                    bind_fvs, escs, bind_lv_info, [env_ext_item])
 647
 648
 649     vars_bind body_fvs (Rec pairs)
 650       = fixLne (\ ~(_, rec_rhs_fvs, _, bind_lv_info, _) ->
 651            let
 652                 rec_scope_fvs = unionFVInfo body_fvs rec_rhs_fvs
 653                 binders = map fst pairs
 654                 env_ext = [ mk_binding bind_lv_info b rhs
 655                           | (b,rhs) <- pairs ]
 656            in
 657            extendVarEnvLne env_ext (
 658               mapAndUnzip4Lne (coreToStgRhs rec_scope_fvs binders) pairs
 659                                         `thenLne` \ (rhss2, fvss, lv_infos, escss) ->
 660               let
 661                         bind_fvs = unionFVInfos fvss
 662                         bind_lv_info = foldr unionLiveInfo emptyLiveInfo lv_infos
 663                         escs     = unionVarSets escss
 664               in
 665               returnLne (StgRec (binders `zip` rhss2),
 666                          bind_fvs, escs, bind_lv_info, env_ext)
 667            )
 668         )
 669
 670 is_join_var :: Id -> Bool
 671 -- A hack (used only for compiler debuggging) to tell if
 672 -- a variable started life as a join point ($j)
 673 is_join_var j = occNameUserString (getOccName j) == "$j"
 674 \end{code}
 675
 676 \begin{code}
 677 coreToStgRhs :: FreeVarsInfo            -- Free var info for the scope of the binding
 678              -> [Id]
 679              -> (Id,CoreExpr)
 680              -> LneM (StgRhs, FreeVarsInfo, LiveInfo, EscVarsSet)
 681
 682 coreToStgRhs scope_fv_info binders (bndr, rhs)
 683   = coreToStgExpr rhs           `thenLne` \ (new_rhs, rhs_fvs, rhs_escs) ->
 684     getEnvLne                   `thenLne` \ env ->
 685     freeVarsToLiveVars (binders `minusFVBinders` rhs_fvs) `thenLne` \ lv_info ->
 686     returnLne (mkStgRhs rhs_fvs (mkSRT lv_info) bndr_info new_rhs,
 687                rhs_fvs, lv_info, rhs_escs)
 688   where
 689     bndr_info = lookupFVInfo scope_fv_info bndr
 690
 691 mkStgRhs :: FreeVarsInfo -> SRT -> StgBinderInfo -> StgExpr -> StgRhs
 692
 693 mkStgRhs rhs_fvs srt binder_info (StgConApp con args)
 694   = StgRhsCon noCCS con args
 695
 696 mkStgRhs rhs_fvs srt binder_info (StgLam _ bndrs body)
 697   = StgRhsClosure noCCS binder_info
 698                   (getFVs rhs_fvs)
 699                   ReEntrant
 700                   srt bndrs body
 701
 702 mkStgRhs rhs_fvs srt binder_info rhs
 703   = StgRhsClosure noCCS binder_info
 704                   (getFVs rhs_fvs)
 705                   upd_flag srt [] rhs
 706   where
 707    upd_flag = Updatable
 708   {-
 709     SDM: disabled.  Eval/Apply can't handle functions with arity zero very
 710     well; and making these into simple non-updatable thunks breaks other
 711     assumptions (namely that they will be entered only once).
 712
 713     upd_flag | isPAP env rhs  = ReEntrant
 714              | otherwise      = Updatable
 715   -}
 716
 717 {- ToDo:
 718           upd = if isOnceDem dem
 719                     then (if isNotTop toplev
 720                             then SingleEntry    -- HA!  Paydirt for "dem"
 721                             else
 722 #ifdef DEBUG
 723                      trace "WARNING: SE CAFs unsupported, forcing UPD instead" $
 724 #endif
 725                      Updatable)
 726                 else Updatable
 727         -- For now we forbid SingleEntry CAFs; they tickle the
 728         -- ASSERT in rts/Storage.c line 215 at newCAF() re mut_link,
 729         -- and I don't understand why.  There's only one SE_CAF (well,
 730         -- only one that tickled a great gaping bug in an earlier attempt
 731         -- at ClosureInfo.getEntryConvention) in the whole of nofib,
 732         -- specifically Main.lvl6 in spectral/cryptarithm2.
 733         -- So no great loss.  KSW 2000-07.
 734 -}
 735 \end{code}
 736
 737 Detect thunks which will reduce immediately to PAPs, and make them
 738 non-updatable.  This has several advantages:
 739
 740         - the non-updatable thunk behaves exactly like the PAP,
 741
 742         - the thunk is more efficient to enter, because it is
 743           specialised to the task.
 744
 745         - we save one update frame, one stg_update_PAP, one update
 746           and lots of PAP_enters.
 747
 748         - in the case where the thunk is top-level, we save building
 749           a black hole and futhermore the thunk isn't considered to
 750           be a CAF any more, so it doesn't appear in any SRTs.
 751
 752 We do it here, because the arity information is accurate, and we need
 753 to do it before the SRT pass to save the SRT entries associated with
 754 any top-level PAPs.
 755
 756 isPAP env (StgApp f args) = listLengthCmp args arity == LT -- idArity f > length args
 757                           where
 758                             arity = stgArity f (lookupBinding env f)
 759 isPAP env _               = False
 760
 761
 762 %************************************************************************
 763 %*                                                                      *
 764 \subsection[LNE-monad]{A little monad for this let-no-escaping pass}
 765 %*                                                                      *
 766 %************************************************************************
 767
 768 There's a lot of stuff to pass around, so we use this @LneM@ monad to
 769 help.  All the stuff here is only passed *down*.
 770
 771 \begin{code}
 772 type LneM a =  IdEnv HowBound
 773             -> LiveInfo         -- Vars and CAFs live in continuation
 774             -> a
 775
 776 type LiveInfo = (StgLiveVars,   -- Dynamic live variables;
 777                                 -- i.e. ones with a nested (non-top-level) binding
 778                  CafSet)        -- Static live variables;
 779                                 -- i.e. top-level variables that are CAFs or refer to them
 780
 781 type EscVarsSet = IdSet
 782 type CafSet     = IdSet
 783
 784 data HowBound
 785   = ImportBound         -- Used only as a response to lookupBinding; never
 786                         -- exists in the range of the (IdEnv HowBound)
 787
 788   | LetBound            -- A let(rec) in this module
 789         LetInfo         -- Whether top level or nested
 790         Arity           -- Its arity (local Ids don't have arity info at this point)
 791
 792   | LambdaBound         -- Used for both lambda and case
 793
 794 data LetInfo
 795   = TopLet              -- top level things
 796   | NestedLet LiveInfo  -- For nested things, what is live if this
 797                         -- thing is live?  Invariant: the binder
 798                         -- itself is always a member of
 799                         -- the dynamic set of its own LiveInfo
 800
 801 isLetBound (LetBound _ _) = True
 802 isLetBound other          = False
 803
 804 topLevelBound ImportBound         = True
 805 topLevelBound (LetBound TopLet _) = True
 806 topLevelBound other               = False
 807 \end{code}
 808
 809 For a let(rec)-bound variable, x, we record LiveInfo, the set of
 810 variables that are live if x is live.  This LiveInfo comprises
 811         (a) dynamic live variables (ones with a non-top-level binding)
 812         (b) static live variabes (CAFs or things that refer to CAFs)
 813
 814 For "normal" variables (a) is just x alone.  If x is a let-no-escaped
 815 variable then x is represented by a code pointer and a stack pointer
 816 (well, one for each stack).  So all of the variables needed in the
 817 execution of x are live if x is, and are therefore recorded in the
 818 LetBound constructor; x itself *is* included.
 819
 820 The set of dynamic live variables is guaranteed ot have no further let-no-escaped
 821 variables in it.
 822
 823 \begin{code}
 824 emptyLiveInfo :: LiveInfo
 825 emptyLiveInfo = (emptyVarSet,emptyVarSet)
 826
 827 unitLiveVar :: Id -> LiveInfo
 828 unitLiveVar lv = (unitVarSet lv, emptyVarSet)
 829
 830 unitLiveCaf :: Id -> LiveInfo
 831 unitLiveCaf caf = (emptyVarSet, unitVarSet caf)
 832
 833 addLiveVar :: LiveInfo -> Id -> LiveInfo
 834 addLiveVar (lvs, cafs) id = (lvs `extendVarSet` id, cafs)
 835
 836 unionLiveInfo :: LiveInfo -> LiveInfo -> LiveInfo
 837 unionLiveInfo (lv1,caf1) (lv2,caf2) = (lv1 `unionVarSet` lv2, caf1 `unionVarSet` caf2)
 838
 839 mkSRT :: LiveInfo -> SRT
 840 mkSRT (_, cafs) = SRTEntries cafs
 841
 842 getLiveVars :: LiveInfo -> StgLiveVars
 843 getLiveVars (lvs, _) = lvs
 844 \end{code}
 845
 846
 847 The std monad functions:
 848 \begin{code}
 849 initLne :: IdEnv HowBound -> LneM a -> a
 850 initLne env m = m env emptyLiveInfo
 851
 852
 853
 854 {-# INLINE thenLne #-}
 855 {-# INLINE returnLne #-}
 856
 857 returnLne :: a -> LneM a
 858 returnLne e env lvs_cont = e
 859
 860 thenLne :: LneM a -> (a -> LneM b) -> LneM b
 861 thenLne m k env lvs_cont
 862   = k (m env lvs_cont) env lvs_cont
 863
 864 mapAndUnzipLne  :: (a -> LneM (b,c))   -> [a] -> LneM ([b],[c])
 865 mapAndUnzipLne f [] = returnLne ([],[])
 866 mapAndUnzipLne f (x:xs)
 867   = f x                 `thenLne` \ (r1,  r2)  ->
 868     mapAndUnzipLne f xs `thenLne` \ (rs1, rs2) ->
 869     returnLne (r1:rs1, r2:rs2)
 870
 871 mapAndUnzip3Lne :: (a -> LneM (b,c,d)) -> [a] -> LneM ([b],[c],[d])
 872 mapAndUnzip3Lne f []    = returnLne ([],[],[])
 873 mapAndUnzip3Lne f (x:xs)
 874   = f x                  `thenLne` \ (r1,  r2,  r3)  ->
 875     mapAndUnzip3Lne f xs `thenLne` \ (rs1, rs2, rs3) ->
 876     returnLne (r1:rs1, r2:rs2, r3:rs3)
 877
 878 mapAndUnzip4Lne :: (a -> LneM (b,c,d,e)) -> [a] -> LneM ([b],[c],[d],[e])
 879 mapAndUnzip4Lne f []    = returnLne ([],[],[],[])
 880 mapAndUnzip4Lne f (x:xs)
 881   = f x                  `thenLne` \ (r1,  r2,  r3, r4)  ->
 882     mapAndUnzip4Lne f xs `thenLne` \ (rs1, rs2, rs3, rs4) ->
 883     returnLne (r1:rs1, r2:rs2, r3:rs3, r4:rs4)
 884
 885 fixLne :: (a -> LneM a) -> LneM a
 886 fixLne expr env lvs_cont
 887   = result
 888   where
 889     result = expr result env lvs_cont
 890 \end{code}
 891
 892 Functions specific to this monad:
 893
 894 \begin{code}
 895 getVarsLiveInCont :: LneM LiveInfo
 896 getVarsLiveInCont env lvs_cont = lvs_cont
 897
 898 setVarsLiveInCont :: LiveInfo -> LneM a -> LneM a
 899 setVarsLiveInCont new_lvs_cont expr env lvs_cont
 900   = expr env new_lvs_cont
 901
 902 extendVarEnvLne :: [(Id, HowBound)] -> LneM a -> LneM a
 903 extendVarEnvLne ids_w_howbound expr env lvs_cont
 904   = expr (extendVarEnvList env ids_w_howbound) lvs_cont
 905
 906 lookupVarLne :: Id -> LneM HowBound
 907 lookupVarLne v env lvs_cont = returnLne (lookupBinding env v) env lvs_cont
 908
 909 getEnvLne :: LneM (IdEnv HowBound)
 910 getEnvLne env lvs_cont = returnLne env env lvs_cont
 911
 912 lookupBinding :: IdEnv HowBound -> Id -> HowBound
 913 lookupBinding env v = case lookupVarEnv env v of
 914                         Just xx -> xx
 915                         Nothing -> ASSERT2( isGlobalId v, ppr v ) ImportBound
 916
 917
 918 -- The result of lookupLiveVarsForSet, a set of live variables, is
 919 -- only ever tacked onto a decorated expression. It is never used as
 920 -- the basis of a control decision, which might give a black hole.
 921
 922 freeVarsToLiveVars :: FreeVarsInfo -> LneM LiveInfo
 923 freeVarsToLiveVars fvs env live_in_cont
 924   = returnLne live_info env live_in_cont
 925   where
 926     live_info    = foldr unionLiveInfo live_in_cont lvs_from_fvs
 927     lvs_from_fvs = map do_one (allFreeIds fvs)
 928
 929     do_one (v, how_bound)
 930       = case how_bound of
 931           ImportBound                     -> unitLiveCaf v      -- Only CAF imports are
 932                                                                 -- recorded in fvs
 933           LetBound TopLet _
 934                 | mayHaveCafRefs (idCafInfo v) -> unitLiveCaf v
 935                 | otherwise                    -> emptyLiveInfo
 936
 937           LetBound (NestedLet lvs) _      -> lvs        -- lvs already contains v
 938                                                         -- (see the invariant on NestedLet)
 939
 940           _lambda_or_case_binding         -> unitLiveVar v      -- Bound by lambda or case
 941 \end{code}
 942
 943 %************************************************************************
 944 %*                                                                      *
 945 \subsection[Free-var info]{Free variable information}
 946 %*                                                                      *
 947 %************************************************************************
 948
 949 \begin{code}
 950 type FreeVarsInfo = VarEnv (Var, HowBound, StgBinderInfo)
 951         -- The Var is so we can gather up the free variables
 952         -- as a set.
 953         --
 954         -- The HowBound info just saves repeated lookups;
 955         -- we look up just once when we encounter the occurrence.
 956         -- INVARIANT: Any ImportBound Ids are HaveCafRef Ids
 957         --            Imported Ids without CAF refs are simply
 958         --            not put in the FreeVarsInfo for an expression.
 959         --            See singletonFVInfo and freeVarsToLiveVars
 960         --
 961         -- StgBinderInfo records how it occurs; notably, we
 962         -- are interested in whether it only occurs in saturated
 963         -- applications, because then we don't need to build a
 964         -- curried version.
 965         -- If f is mapped to noBinderInfo, that means
 966         -- that f *is* mentioned (else it wouldn't be in the
 967         -- IdEnv at all), but perhaps in an unsaturated applications.
 968         --
 969         -- All case/lambda-bound things are also mapped to
 970         -- noBinderInfo, since we aren't interested in their
 971         -- occurence info.
 972         --
 973         -- For ILX we track free var info for type variables too;
 974         -- hence VarEnv not IdEnv
 975 \end{code}
 976
 977 \begin{code}
 978 emptyFVInfo :: FreeVarsInfo
 979 emptyFVInfo = emptyVarEnv
 980
 981 singletonFVInfo :: Id -> HowBound -> StgBinderInfo -> FreeVarsInfo
 982 -- Don't record non-CAF imports at all, to keep free-var sets small
 983 singletonFVInfo id ImportBound info
 984    | mayHaveCafRefs (idCafInfo id) = unitVarEnv id (id, ImportBound, info)
 985    | otherwise                     = emptyVarEnv
 986 singletonFVInfo id how_bound info  = unitVarEnv id (id, how_bound, info)
 987
 988 tyvarFVInfo :: TyVarSet -> FreeVarsInfo
 989 tyvarFVInfo tvs = foldVarSet add emptyFVInfo tvs
 990         where
 991           add tv fvs = extendVarEnv fvs tv (tv, LambdaBound, noBinderInfo)
 992                 -- Type variables must be lambda-bound
 993
 994 unionFVInfo :: FreeVarsInfo -> FreeVarsInfo -> FreeVarsInfo
 995 unionFVInfo fv1 fv2 = plusVarEnv_C plusFVInfo fv1 fv2
 996
 997 unionFVInfos :: [FreeVarsInfo] -> FreeVarsInfo
 998 unionFVInfos fvs = foldr unionFVInfo emptyFVInfo fvs
 999
1000 minusFVBinders :: [Id] -> FreeVarsInfo -> FreeVarsInfo
1001 minusFVBinders vs fv = foldr minusFVBinder fv vs
1002
1003 minusFVBinder :: Id -> FreeVarsInfo -> FreeVarsInfo
1004 minusFVBinder v fv | isId v && opt_RuntimeTypes
1005                    = (fv `delVarEnv` v) `unionFVInfo`
1006                      tyvarFVInfo (tyVarsOfType (idType v))
1007                    | otherwise = fv `delVarEnv` v
1008         -- When removing a binder, remember to add its type variables
1009         -- c.f. CoreFVs.delBinderFV
1010
1011 elementOfFVInfo :: Id -> FreeVarsInfo -> Bool
1012 elementOfFVInfo id fvs = maybeToBool (lookupVarEnv fvs id)
1013
1014 lookupFVInfo :: FreeVarsInfo -> Id -> StgBinderInfo
1015 -- Find how the given Id is used.
1016 -- Externally visible things may be used any old how
1017 lookupFVInfo fvs id
1018   | isExternalName (idName id) = noBinderInfo
1019   | otherwise = case lookupVarEnv fvs id of
1020                         Nothing         -> noBinderInfo
1021                         Just (_,_,info) -> info
1022
1023 allFreeIds :: FreeVarsInfo -> [(Id,HowBound)]   -- Both top level and non-top-level Ids
1024 allFreeIds fvs = [(id,how_bound) | (id,how_bound,_) <- rngVarEnv fvs, isId id]
1025
1026 -- Non-top-level things only, both type variables and ids
1027 -- (type variables only if opt_RuntimeTypes)
1028 getFVs :: FreeVarsInfo -> [Var]
1029 getFVs fvs = [id | (id, how_bound, _) <- rngVarEnv fvs,
1030                     not (topLevelBound how_bound) ]
1031
1032 getFVSet :: FreeVarsInfo -> VarSet
1033 getFVSet fvs = mkVarSet (getFVs fvs)
1034
1035 plusFVInfo (id1,hb1,info1) (id2,hb2,info2)
1036   = ASSERT (id1 == id2 && hb1 `check_eq_how_bound` hb2)
1037     (id1, hb1, combineStgBinderInfo info1 info2)
1038
1039 #ifdef DEBUG
1040 -- The HowBound info for a variable in the FVInfo should be consistent
1041 check_eq_how_bound ImportBound        ImportBound        = True
1042 check_eq_how_bound LambdaBound        LambdaBound        = True
1043 check_eq_how_bound (LetBound li1 ar1) (LetBound li2 ar2) = ar1 == ar2 && check_eq_li li1 li2
1044 check_eq_how_bound hb1                hb2                = False
1045
1046 check_eq_li (NestedLet _) (NestedLet _) = True
1047 check_eq_li TopLet        TopLet        = True
1048 check_eq_li li1           li2           = False
1049 #endif
1050 \end{code}
1051
1052 Misc.
1053 \begin{code}
1054 filterStgBinders :: [Var] -> [Var]
1055 filterStgBinders bndrs
1056   | opt_RuntimeTypes = bndrs
1057   | otherwise        = filter isId bndrs
1058 \end{code}
1059
1060
1061 \begin{code}
1062         -- Ignore all notes except SCC
1063 myCollectBinders expr
1064   = go [] expr
1065   where
1066     go bs (Lam b e)          = go (b:bs) e
1067     go bs e@(Note (SCC _) _) = (reverse bs, e)
1068     go bs (Note _ e)         = go bs e
1069     go bs e                  = (reverse bs, e)
1070
1071 myCollectArgs :: CoreExpr -> (Id, [CoreArg])
1072         -- We assume that we only have variables
1073         -- in the function position by now
1074 myCollectArgs expr
1075   = go expr []
1076   where
1077     go (Var v)          as = (v, as)
1078     go (App f a) as        = go f (a:as)
1079     go (Note (SCC _) e) as = pprPanic "CoreToStg.myCollectArgs" (ppr expr)
1080     go (Note n e)       as = go e as
1081     go _                as = pprPanic "CoreToStg.myCollectArgs" (ppr expr)
1082 \end{code}
1083
1084 \begin{code}
1085 stgArity :: Id -> HowBound -> Arity
1086 stgArity f (LetBound _ arity) = arity
1087 stgArity f ImportBound        = idArity f
1088 stgArity f LambdaBound        = 0
1089 \end{code}