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 Literal
  21 import Id
  22 import Var              ( Var, globalIdDetails, varType )
  23 import TyCon            ( isUnboxedTupleTyCon, isPrimTyCon, isFunTyCon )
  24 #ifdef ILX
  25 import MkId             ( unsafeCoerceId )
  26 #endif
  27 import IdInfo
  28 import DataCon
  29 import CostCentre       ( noCCS )
  30 import VarSet
  31 import VarEnv
  32 import Maybes           ( maybeToBool )
  33 import Name             ( getOccName, isExternalName, nameOccName )
  34 import OccName          ( occNameUserString, occNameFS )
  35 import BasicTypes       ( Arity )
  36 import CmdLineOpts      ( DynFlags, opt_RuntimeTypes )
  37 import Outputable
  38
  39 infixr 9 `thenLne`
  40 \end{code}
  41
  42 %************************************************************************
  43 %*                                                                      *
  44 \subsection[live-vs-free-doc]{Documentation}
  45 %*                                                                      *
  46 %************************************************************************
  47
  48 (There is other relevant documentation in codeGen/CgLetNoEscape.)
  49
  50 The actual Stg datatype is decorated with {\em live variable}
  51 information, as well as {\em free variable} information.  The two are
  52 {\em not} the same.  Liveness is an operational property rather than a
  53 semantic one.  A variable is live at a particular execution point if
  54 it can be referred to {\em directly} again.  In particular, a dead
  55 variable's stack slot (if it has one):
  56 \begin{enumerate}
  57 \item
  58 should be stubbed to avoid space leaks, and
  59 \item
  60 may be reused for something else.
  61 \end{enumerate}
  62
  63 There ought to be a better way to say this.  Here are some examples:
  64 \begin{verbatim}
  65         let v = [q] \[x] -> e
  66         in
  67         ...v...  (but no q's)
  68 \end{verbatim}
  69
  70 Just after the `in', v is live, but q is dead.  If the whole of that
  71 let expression was enclosed in a case expression, thus:
  72 \begin{verbatim}
  73         case (let v = [q] \[x] -> e in ...v...) of
  74                 alts[...q...]
  75 \end{verbatim}
  76 (ie @alts@ mention @q@), then @q@ is live even after the `in'; because
  77 we'll return later to the @alts@ and need it.
  78
  79 Let-no-escapes make this a bit more interesting:
  80 \begin{verbatim}
  81         let-no-escape v = [q] \ [x] -> e
  82         in
  83         ...v...
  84 \end{verbatim}
  85 Here, @q@ is still live at the `in', because @v@ is represented not by
  86 a closure but by the current stack state.  In other words, if @v@ is
  87 live then so is @q@.  Furthermore, if @e@ mentions an enclosing
  88 let-no-escaped variable, then {\em its} free variables are also live
  89 if @v@ is.
  90
  91 %************************************************************************
  92 %*                                                                      *
  93 \subsection[caf-info]{Collecting live CAF info}
  94 %*                                                                      *
  95 %************************************************************************
  96
  97 In this pass we also collect information on which CAFs are live for
  98 constructing SRTs (see SRT.lhs).
  99
 100 A top-level Id has CafInfo, which is
 101
 102         - MayHaveCafRefs, if it may refer indirectly to
 103           one or more CAFs, or
 104         - NoCafRefs if it definitely doesn't
 105
 106 The CafInfo has already been calculated during the CoreTidy pass.
 107
 108 During CoreToStg, we then pin onto each binding and case expression, a
 109 list of Ids which represents the "live" CAFs at that point.  The meaning
 110 of "live" here is the same as for live variables, see above (which is
 111 why it's convenient to collect CAF information here rather than elsewhere).
 112
 113 The later SRT pass takes these lists of Ids and uses them to construct
 114 the actual nested SRTs, and replaces the lists of Ids with (offset,length)
 115 pairs.
 116
 117
 118 Interaction of let-no-escape with SRTs   [Sept 01]
 119 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 120 Consider
 121
 122         let-no-escape x = ...caf1...caf2...
 123         in
 124         ...x...x...x...
 125
 126 where caf1,caf2 are CAFs.  Since x doesn't have a closure, we
 127 build SRTs just as if x's defn was inlined at each call site, and
 128 that means that x's CAF refs get duplicated in the overall SRT.
 129
 130 This is unlike ordinary lets, in which the CAF refs are not duplicated.
 131
 132 We could fix this loss of (static) sharing by making a sort of pseudo-closure
 133 for x, solely to put in the SRTs lower down.
 134
 135
 136 %************************************************************************
 137 %*                                                                      *
 138 \subsection[binds-StgVarInfo]{Setting variable info: top-level, binds, RHSs}
 139 %*                                                                      *
 140 %************************************************************************
 141
 142 \begin{code}
 143 coreToStg :: DynFlags -> [CoreBind] -> IO [StgBinding]
 144 coreToStg dflags pgm
 145   = return pgm'
 146   where (_, _, pgm') = coreTopBindsToStg emptyVarEnv pgm
 147
 148 coreExprToStg :: CoreExpr -> StgExpr
 149 coreExprToStg expr
 150   = new_expr where (new_expr,_,_) = initLne emptyVarEnv (coreToStgExpr expr)
 151
 152
 153 coreTopBindsToStg
 154     :: IdEnv HowBound           -- environment for the bindings
 155     -> [CoreBind]
 156     -> (IdEnv HowBound, FreeVarsInfo, [StgBinding])
 157
 158 coreTopBindsToStg env [] = (env, emptyFVInfo, [])
 159 coreTopBindsToStg env (b:bs)
 160   = (env2, fvs2, b':bs')
 161   where
 162         -- env accumulates down the list of binds, fvs accumulates upwards
 163         (env1, fvs2, b' ) = coreTopBindToStg env fvs1 b
 164         (env2, fvs1, bs') = coreTopBindsToStg env1 bs
 165
 166
 167 coreTopBindToStg
 168         :: IdEnv HowBound
 169         -> FreeVarsInfo         -- Info about the body
 170         -> CoreBind
 171         -> (IdEnv HowBound, FreeVarsInfo, StgBinding)
 172
 173 coreTopBindToStg env body_fvs (NonRec id rhs)
 174   = let
 175         env'      = extendVarEnv env id how_bound
 176         how_bound = LetBound TopLet (manifestArity rhs)
 177
 178         (stg_rhs, fvs') =
 179             initLne env (
 180               coreToTopStgRhs body_fvs (id,rhs) `thenLne` \ (stg_rhs, fvs') ->
 181               returnLne (stg_rhs, fvs')
 182            )
 183
 184         bind = StgNonRec id stg_rhs
 185     in
 186     ASSERT2(manifestArity rhs == stgRhsArity stg_rhs, ppr id)
 187     ASSERT2(consistentCafInfo id bind, ppr id)
 188 --    WARN(not (consistent caf_info bind), ppr id <+> ppr cafs <+> ppCafInfo caf_info)
 189     (env', fvs' `unionFVInfo` body_fvs, bind)
 190
 191 coreTopBindToStg env body_fvs (Rec pairs)
 192   = let
 193         (binders, rhss) = unzip pairs
 194
 195         extra_env' = [ (b, LetBound TopLet (manifestArity rhs))
 196                      | (b, rhs) <- pairs ]
 197         env' = extendVarEnvList env extra_env'
 198
 199         (stg_rhss, fvs')
 200           = initLne env' (
 201                mapAndUnzipLne (coreToTopStgRhs body_fvs) pairs
 202                                                 `thenLne` \ (stg_rhss, fvss') ->
 203                let fvs' = unionFVInfos fvss' in
 204                returnLne (stg_rhss, fvs')
 205            )
 206
 207         bind = StgRec (zip binders stg_rhss)
 208     in
 209     ASSERT2(and [manifestArity rhs == stgRhsArity stg_rhs | (rhs,stg_rhs) <- rhss `zip` stg_rhss], ppr binders)
 210     ASSERT2(consistentCafInfo (head binders) bind, ppr binders)
 211     (env', fvs' `unionFVInfo` body_fvs, bind)
 212
 213 #ifdef DEBUG
 214 -- Assertion helper: this checks that the CafInfo on the Id matches
 215 -- what CoreToStg has figured out about the binding's SRT.  The
 216 -- CafInfo will be exact in all cases except when CorePrep has
 217 -- floated out a binding, in which case it will be approximate.
 218 consistentCafInfo id bind
 219   | occNameFS (nameOccName (idName id)) == FSLIT("sat")
 220   = safe
 221   | otherwise
 222   = WARN (not exact, ppr id) safe
 223   where
 224         safe  = id_marked_caffy || not binding_is_caffy
 225         exact = id_marked_caffy == binding_is_caffy
 226         id_marked_caffy  = mayHaveCafRefs (idCafInfo id)
 227         binding_is_caffy = stgBindHasCafRefs bind
 228 #endif
 229 \end{code}
 230
 231 \begin{code}
 232 coreToTopStgRhs
 233         :: FreeVarsInfo         -- Free var info for the scope of the binding
 234         -> (Id,CoreExpr)
 235         -> LneM (StgRhs, FreeVarsInfo)
 236
 237 coreToTopStgRhs scope_fv_info (bndr, rhs)
 238   = coreToStgExpr rhs           `thenLne` \ (new_rhs, rhs_fvs, _) ->
 239     freeVarsToLiveVars rhs_fvs  `thenLne` \ lv_info ->
 240     returnLne (mkTopStgRhs is_static rhs_fvs (mkSRT lv_info) bndr_info new_rhs, rhs_fvs)
 241   where
 242     bndr_info = lookupFVInfo scope_fv_info bndr
 243     is_static = rhsIsStatic rhs
 244
 245 mkTopStgRhs :: Bool -> FreeVarsInfo -> SRT -> StgBinderInfo -> StgExpr
 246         -> StgRhs
 247
 248 mkTopStgRhs is_static rhs_fvs srt binder_info (StgLam _ bndrs body)
 249   = ASSERT( is_static )
 250     StgRhsClosure noCCS binder_info
 251                   (getFVs rhs_fvs)
 252                   ReEntrant
 253                   srt
 254                   bndrs body
 255
 256 mkTopStgRhs is_static rhs_fvs srt binder_info (StgConApp con args)
 257   | is_static    -- StgConApps can be updatable (see isCrossDllConApp)
 258   = StgRhsCon noCCS con args
 259
 260 mkTopStgRhs is_static rhs_fvs srt binder_info rhs
 261   = ASSERT( not is_static )
 262     StgRhsClosure noCCS binder_info
 263                   (getFVs rhs_fvs)
 264                   Updatable
 265                   srt
 266                   [] rhs
 267 \end{code}
 268
 269
 270 -- ---------------------------------------------------------------------------
 271 -- Expressions
 272 -- ---------------------------------------------------------------------------
 273
 274 \begin{code}
 275 coreToStgExpr
 276         :: CoreExpr
 277         -> LneM (StgExpr,       -- Decorated STG expr
 278                  FreeVarsInfo,  -- Its free vars (NB free, not live)
 279                  EscVarsSet)    -- Its escapees, a subset of its free vars;
 280                                 -- also a subset of the domain of the envt
 281                                 -- because we are only interested in the escapees
 282                                 -- for vars which might be turned into
 283                                 -- let-no-escaped ones.
 284 \end{code}
 285
 286 The second and third components can be derived in a simple bottom up pass, not
 287 dependent on any decisions about which variables will be let-no-escaped or
 288 not.  The first component, that is, the decorated expression, may then depend
 289 on these components, but it in turn is not scrutinised as the basis for any
 290 decisions.  Hence no black holes.
 291
 292 \begin{code}
 293 coreToStgExpr (Lit l) = returnLne (StgLit l, emptyFVInfo, emptyVarSet)
 294 coreToStgExpr (Var v) = coreToStgApp Nothing v []
 295
 296 coreToStgExpr expr@(App _ _)
 297   = coreToStgApp Nothing f args
 298   where
 299     (f, args) = myCollectArgs expr
 300
 301 coreToStgExpr expr@(Lam _ _)
 302   = let
 303         (args, body) = myCollectBinders expr
 304         args'        = filterStgBinders args
 305     in
 306     extendVarEnvLne [ (a, LambdaBound) | a <- args' ] $
 307     coreToStgExpr body  `thenLne` \ (body, body_fvs, body_escs) ->
 308     let
 309         fvs             = args' `minusFVBinders` body_fvs
 310         escs            = body_escs `delVarSetList` args'
 311         result_expr | null args' = body
 312                     | otherwise  = StgLam (exprType expr) args' body
 313     in
 314     returnLne (result_expr, fvs, escs)
 315
 316 coreToStgExpr (Note (SCC cc) expr)
 317   = coreToStgExpr expr          `thenLne` ( \ (expr2, fvs, escs) ->
 318     returnLne (StgSCC cc expr2, fvs, escs) )
 319
 320 #ifdef ILX
 321 -- For ILX, convert (__coerce__ to_ty from_ty e)
 322 --          into    (coerce to_ty from_ty e)
 323 -- where coerce is real function
 324 coreToStgExpr (Note (Coerce to_ty from_ty) expr)
 325   = coreToStgExpr (mkApps (Var unsafeCoerceId)
 326                           [Type from_ty, Type to_ty, expr])
 327 #endif
 328
 329 coreToStgExpr (Note other_note expr)
 330   = coreToStgExpr expr
 331
 332 -- Cases require a little more real work.
 333
 334 coreToStgExpr (Case scrut bndr alts)
 335   = extendVarEnvLne [(bndr, LambdaBound)]       (
 336          mapAndUnzip3Lne vars_alt alts  `thenLne` \ (alts2, fvs_s, escs_s) ->
 337          returnLne ( alts2,
 338                      unionFVInfos fvs_s,
 339                      unionVarSets escs_s )
 340     )                                   `thenLne` \ (alts2, alts_fvs, alts_escs) ->
 341     let
 342         -- Determine whether the default binder is dead or not
 343         -- This helps the code generator to avoid generating an assignment
 344         -- for the case binder (is extremely rare cases) ToDo: remove.
 345         bndr' | bndr `elementOfFVInfo` alts_fvs = bndr
 346               | otherwise                       = bndr `setIdOccInfo` IAmDead
 347
 348         -- Don't consider the default binder as being 'live in alts',
 349         -- since this is from the point of view of the case expr, where
 350         -- the default binder is not free.
 351         alts_fvs_wo_bndr  = bndr `minusFVBinder` alts_fvs
 352         alts_escs_wo_bndr = alts_escs `delVarSet` bndr
 353     in
 354
 355     freeVarsToLiveVars alts_fvs_wo_bndr         `thenLne` \ alts_lv_info ->
 356
 357         -- We tell the scrutinee that everything
 358         -- live in the alts is live in it, too.
 359     setVarsLiveInCont alts_lv_info (
 360         coreToStgExpr scrut       `thenLne` \ (scrut2, scrut_fvs, scrut_escs) ->
 361         freeVarsToLiveVars scrut_fvs `thenLne` \ scrut_lv_info ->
 362         returnLne (scrut2, scrut_fvs, scrut_escs, scrut_lv_info)
 363       )
 364                 `thenLne` \ (scrut2, scrut_fvs, scrut_escs, scrut_lv_info) ->
 365
 366     returnLne (
 367       StgCase scrut2 (getLiveVars scrut_lv_info)
 368                      (getLiveVars alts_lv_info)
 369                      bndr'
 370                      (mkSRT alts_lv_info)
 371                      (mkStgAltType (idType bndr))
 372                      alts2,
 373       scrut_fvs `unionFVInfo` alts_fvs_wo_bndr,
 374       alts_escs_wo_bndr `unionVarSet` getFVSet scrut_fvs
 375                 -- You might think we should have scrut_escs, not
 376                 -- (getFVSet scrut_fvs), but actually we can't call, and
 377                 -- then return from, a let-no-escape thing.
 378       )
 379   where
 380     vars_alt (con, binders, rhs)
 381       = let     -- Remove type variables
 382             binders' = filterStgBinders binders
 383         in
 384         extendVarEnvLne [(b, LambdaBound) | b <- binders']      $
 385         coreToStgExpr rhs       `thenLne` \ (rhs2, rhs_fvs, rhs_escs) ->
 386         let
 387                 -- Records whether each param is used in the RHS
 388             good_use_mask = [ b `elementOfFVInfo` rhs_fvs | b <- binders' ]
 389         in
 390         returnLne ( (con, binders', good_use_mask, rhs2),
 391                     binders' `minusFVBinders` rhs_fvs,
 392                     rhs_escs `delVarSetList` binders' )
 393                 -- ToDo: remove the delVarSet;
 394                 -- since escs won't include any of these binders
 395 \end{code}
 396
 397 Lets not only take quite a bit of work, but this is where we convert
 398 then to let-no-escapes, if we wish.
 399
 400 (Meanwhile, we don't expect to see let-no-escapes...)
 401 \begin{code}
 402 coreToStgExpr (Let bind body)
 403   = fixLne (\ ~(_, _, _, no_binder_escapes) ->
 404         coreToStgLet no_binder_escapes bind body
 405     )                           `thenLne` \ (new_let, fvs, escs, _) ->
 406
 407     returnLne (new_let, fvs, escs)
 408 \end{code}
 409
 410 \begin{code}
 411 mkStgAltType scrut_ty
 412   = case splitTyConApp_maybe (repType scrut_ty) of
 413         Just (tc,_) | isUnboxedTupleTyCon tc -> UbxTupAlt tc
 414                     | isPrimTyCon tc         -> PrimAlt tc
 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 (varType 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 mapLne  :: (a -> LneM b)   -> [a] -> LneM [b]
 865 mapLne f [] = returnLne []
 866 mapLne f (x:xs)
 867   = f x         `thenLne` \ r  ->
 868     mapLne f xs `thenLne` \ rs ->
 869     returnLne (r:rs)
 870
 871 mapAndUnzipLne  :: (a -> LneM (b,c))   -> [a] -> LneM ([b],[c])
 872
 873 mapAndUnzipLne f [] = returnLne ([],[])
 874 mapAndUnzipLne f (x:xs)
 875   = f x                 `thenLne` \ (r1,  r2)  ->
 876     mapAndUnzipLne f xs `thenLne` \ (rs1, rs2) ->
 877     returnLne (r1:rs1, r2:rs2)
 878
 879 mapAndUnzip3Lne :: (a -> LneM (b,c,d)) -> [a] -> LneM ([b],[c],[d])
 880
 881 mapAndUnzip3Lne f []    = returnLne ([],[],[])
 882 mapAndUnzip3Lne f (x:xs)
 883   = f x                  `thenLne` \ (r1,  r2,  r3)  ->
 884     mapAndUnzip3Lne f xs `thenLne` \ (rs1, rs2, rs3) ->
 885     returnLne (r1:rs1, r2:rs2, r3:rs3)
 886
 887 mapAndUnzip4Lne :: (a -> LneM (b,c,d,e)) -> [a] -> LneM ([b],[c],[d],[e])
 888
 889 mapAndUnzip4Lne f []    = returnLne ([],[],[],[])
 890 mapAndUnzip4Lne f (x:xs)
 891   = f x                  `thenLne` \ (r1,  r2,  r3, r4)  ->
 892     mapAndUnzip4Lne f xs `thenLne` \ (rs1, rs2, rs3, rs4) ->
 893     returnLne (r1:rs1, r2:rs2, r3:rs3, r4:rs4)
 894
 895 fixLne :: (a -> LneM a) -> LneM a
 896 fixLne expr env lvs_cont
 897   = result
 898   where
 899     result = expr result env lvs_cont
 900 \end{code}
 901
 902 Functions specific to this monad:
 903
 904 \begin{code}
 905 getVarsLiveInCont :: LneM LiveInfo
 906 getVarsLiveInCont env lvs_cont = lvs_cont
 907
 908 setVarsLiveInCont :: LiveInfo -> LneM a -> LneM a
 909 setVarsLiveInCont new_lvs_cont expr env lvs_cont
 910   = expr env new_lvs_cont
 911
 912 extendVarEnvLne :: [(Id, HowBound)] -> LneM a -> LneM a
 913 extendVarEnvLne ids_w_howbound expr env lvs_cont
 914   = expr (extendVarEnvList env ids_w_howbound) lvs_cont
 915
 916 lookupVarLne :: Id -> LneM HowBound
 917 lookupVarLne v env lvs_cont = returnLne (lookupBinding env v) env lvs_cont
 918
 919 getEnvLne :: LneM (IdEnv HowBound)
 920 getEnvLne env lvs_cont = returnLne env env lvs_cont
 921
 922 lookupBinding :: IdEnv HowBound -> Id -> HowBound
 923 lookupBinding env v = case lookupVarEnv env v of
 924                         Just xx -> xx
 925                         Nothing -> ASSERT2( isGlobalId v, ppr v ) ImportBound
 926
 927
 928 -- The result of lookupLiveVarsForSet, a set of live variables, is
 929 -- only ever tacked onto a decorated expression. It is never used as
 930 -- the basis of a control decision, which might give a black hole.
 931
 932 freeVarsToLiveVars :: FreeVarsInfo -> LneM LiveInfo
 933 freeVarsToLiveVars fvs env live_in_cont
 934   = returnLne live_info env live_in_cont
 935   where
 936     live_info    = foldr unionLiveInfo live_in_cont lvs_from_fvs
 937     lvs_from_fvs = map do_one (allFreeIds fvs)
 938
 939     do_one (v, how_bound)
 940       = case how_bound of
 941           ImportBound                     -> unitLiveCaf v      -- Only CAF imports are
 942                                                                 -- recorded in fvs
 943           LetBound TopLet _
 944                 | mayHaveCafRefs (idCafInfo v) -> unitLiveCaf v
 945                 | otherwise                    -> emptyLiveInfo
 946
 947           LetBound (NestedLet lvs) _      -> lvs        -- lvs already contains v
 948                                                         -- (see the invariant on NestedLet)
 949
 950           _lambda_or_case_binding         -> unitLiveVar v      -- Bound by lambda or case
 951 \end{code}
 952
 953 %************************************************************************
 954 %*                                                                      *
 955 \subsection[Free-var info]{Free variable information}
 956 %*                                                                      *
 957 %************************************************************************
 958
 959 \begin{code}
 960 type FreeVarsInfo = VarEnv (Var, HowBound, StgBinderInfo)
 961         -- The Var is so we can gather up the free variables
 962         -- as a set.
 963         --
 964         -- The HowBound info just saves repeated lookups;
 965         -- we look up just once when we encounter the occurrence.
 966         -- INVARIANT: Any ImportBound Ids are HaveCafRef Ids
 967         --            Imported Ids without CAF refs are simply
 968         --            not put in the FreeVarsInfo for an expression.
 969         --            See singletonFVInfo and freeVarsToLiveVars
 970         --
 971         -- StgBinderInfo records how it occurs; notably, we
 972         -- are interested in whether it only occurs in saturated
 973         -- applications, because then we don't need to build a
 974         -- curried version.
 975         -- If f is mapped to noBinderInfo, that means
 976         -- that f *is* mentioned (else it wouldn't be in the
 977         -- IdEnv at all), but perhaps in an unsaturated applications.
 978         --
 979         -- All case/lambda-bound things are also mapped to
 980         -- noBinderInfo, since we aren't interested in their
 981         -- occurence info.
 982         --
 983         -- For ILX we track free var info for type variables too;
 984         -- hence VarEnv not IdEnv
 985 \end{code}
 986
 987 \begin{code}
 988 emptyFVInfo :: FreeVarsInfo
 989 emptyFVInfo = emptyVarEnv
 990
 991 singletonFVInfo :: Id -> HowBound -> StgBinderInfo -> FreeVarsInfo
 992 -- Don't record non-CAF imports at all, to keep free-var sets small
 993 singletonFVInfo id ImportBound info
 994    | mayHaveCafRefs (idCafInfo id) = unitVarEnv id (id, ImportBound, info)
 995    | otherwise                     = emptyVarEnv
 996 singletonFVInfo id how_bound info  = unitVarEnv id (id, how_bound, info)
 997
 998 tyvarFVInfo :: TyVarSet -> FreeVarsInfo
 999 tyvarFVInfo tvs = foldVarSet add emptyFVInfo tvs
1000         where
1001           add tv fvs = extendVarEnv fvs tv (tv, LambdaBound, noBinderInfo)
1002                 -- Type variables must be lambda-bound
1003
1004 unionFVInfo :: FreeVarsInfo -> FreeVarsInfo -> FreeVarsInfo
1005 unionFVInfo fv1 fv2 = plusVarEnv_C plusFVInfo fv1 fv2
1006
1007 unionFVInfos :: [FreeVarsInfo] -> FreeVarsInfo
1008 unionFVInfos fvs = foldr unionFVInfo emptyFVInfo fvs
1009
1010 minusFVBinders :: [Id] -> FreeVarsInfo -> FreeVarsInfo
1011 minusFVBinders vs fv = foldr minusFVBinder fv vs
1012
1013 minusFVBinder :: Id -> FreeVarsInfo -> FreeVarsInfo
1014 minusFVBinder v fv | isId v && opt_RuntimeTypes
1015                    = (fv `delVarEnv` v) `unionFVInfo`
1016                      tyvarFVInfo (tyVarsOfType (idType v))
1017                    | otherwise = fv `delVarEnv` v
1018         -- When removing a binder, remember to add its type variables
1019         -- c.f. CoreFVs.delBinderFV
1020
1021 elementOfFVInfo :: Id -> FreeVarsInfo -> Bool
1022 elementOfFVInfo id fvs = maybeToBool (lookupVarEnv fvs id)
1023
1024 lookupFVInfo :: FreeVarsInfo -> Id -> StgBinderInfo
1025 -- Find how the given Id is used.
1026 -- Externally visible things may be used any old how
1027 lookupFVInfo fvs id
1028   | isExternalName (idName id) = noBinderInfo
1029   | otherwise = case lookupVarEnv fvs id of
1030                         Nothing         -> noBinderInfo
1031                         Just (_,_,info) -> info
1032
1033 allFreeIds :: FreeVarsInfo -> [(Id,HowBound)]   -- Both top level and non-top-level Ids
1034 allFreeIds fvs = [(id,how_bound) | (id,how_bound,_) <- rngVarEnv fvs, isId id]
1035
1036 -- Non-top-level things only, both type variables and ids
1037 -- (type variables only if opt_RuntimeTypes)
1038 getFVs :: FreeVarsInfo -> [Var]
1039 getFVs fvs = [id | (id, how_bound, _) <- rngVarEnv fvs,
1040                     not (topLevelBound how_bound) ]
1041
1042 getFVSet :: FreeVarsInfo -> VarSet
1043 getFVSet fvs = mkVarSet (getFVs fvs)
1044
1045 plusFVInfo (id1,hb1,info1) (id2,hb2,info2)
1046   = ASSERT (id1 == id2 && hb1 `check_eq_how_bound` hb2)
1047     (id1, hb1, combineStgBinderInfo info1 info2)
1048
1049 #ifdef DEBUG
1050 -- The HowBound info for a variable in the FVInfo should be consistent
1051 check_eq_how_bound ImportBound        ImportBound        = True
1052 check_eq_how_bound LambdaBound        LambdaBound        = True
1053 check_eq_how_bound (LetBound li1 ar1) (LetBound li2 ar2) = ar1 == ar2 && check_eq_li li1 li2
1054 check_eq_how_bound hb1                hb2                = False
1055
1056 check_eq_li (NestedLet _) (NestedLet _) = True
1057 check_eq_li TopLet        TopLet        = True
1058 check_eq_li li1           li2           = False
1059 #endif
1060 \end{code}
1061
1062 Misc.
1063 \begin{code}
1064 filterStgBinders :: [Var] -> [Var]
1065 filterStgBinders bndrs
1066   | opt_RuntimeTypes = bndrs
1067   | otherwise        = filter isId bndrs
1068 \end{code}
1069
1070
1071 \begin{code}
1072         -- Ignore all notes except SCC
1073 myCollectBinders expr
1074   = go [] expr
1075   where
1076     go bs (Lam b e)          = go (b:bs) e
1077     go bs e@(Note (SCC _) _) = (reverse bs, e)
1078     go bs (Note _ e)         = go bs e
1079     go bs e                  = (reverse bs, e)
1080
1081 myCollectArgs :: CoreExpr -> (Id, [CoreArg])
1082         -- We assume that we only have variables
1083         -- in the function position by now
1084 myCollectArgs expr
1085   = go expr []
1086   where
1087     go (Var v)          as = (v, as)
1088     go (App f a) as        = go f (a:as)
1089     go (Note (SCC _) e) as = pprPanic "CoreToStg.myCollectArgs" (ppr expr)
1090     go (Note n e)       as = go e as
1091     go _                as = pprPanic "CoreToStg.myCollectArgs" (ppr expr)
1092 \end{code}
1093
1094 \begin{code}
1095 stgArity :: Id -> HowBound -> Arity
1096 stgArity f (LetBound _ arity) = arity
1097 stgArity f ImportBound        = idArity f
1098 stgArity f LambdaBound        = 0
1099 \end{code}