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