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_KeepStgTypes )
  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_KeepStgTypes 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_KeepStgTypes 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
 792   | CaseBound
 793   | LambdaBound
 794   | LetBound
 795         TopLevelCafInfo
 796         (StgLiveVars, IdSet) -- (Live vars, Live CAFs)... see notes below
 797         Arity      -- its arity (local Ids don't have arity info at this point)
 798
 799 isLetBound (LetBound _ _ _) = True
 800 isLetBound other            = False
 801 \end{code}
 802
 803 For a let(rec)-bound variable, x, we record StgLiveVars, the set of
 804 variables that are live if x is live.  For "normal" variables that is
 805 just x alone.  If x is a let-no-escaped variable then x is represented
 806 by a code pointer and a stack pointer (well, one for each stack).  So
 807 all of the variables needed in the execution of x are live if x is,
 808 and are therefore recorded in the LetBound constructor; x itself
 809 *is* included.
 810
 811 The set of live variables is guaranteed ot have no further let-no-escaped
 812 variables in it.
 813
 814 The std monad functions:
 815 \begin{code}
 816 initLne :: IdEnv HowBound -> LneM a -> a
 817 initLne env m = m env emptyLVS
 818
 819 emptyLVS = (emptyVarSet,emptyVarSet)
 820
 821 {-# INLINE thenLne #-}
 822 {-# INLINE returnLne #-}
 823
 824 returnLne :: a -> LneM a
 825 returnLne e env lvs_cont = e
 826
 827 thenLne :: LneM a -> (a -> LneM b) -> LneM b
 828 thenLne m k env lvs_cont
 829   = k (m env lvs_cont) env lvs_cont
 830
 831 mapLne  :: (a -> LneM b)   -> [a] -> LneM [b]
 832 mapLne f [] = returnLne []
 833 mapLne f (x:xs)
 834   = f x         `thenLne` \ r  ->
 835     mapLne f xs `thenLne` \ rs ->
 836     returnLne (r:rs)
 837
 838 mapAndUnzipLne  :: (a -> LneM (b,c))   -> [a] -> LneM ([b],[c])
 839
 840 mapAndUnzipLne f [] = returnLne ([],[])
 841 mapAndUnzipLne f (x:xs)
 842   = f x                 `thenLne` \ (r1,  r2)  ->
 843     mapAndUnzipLne f xs `thenLne` \ (rs1, rs2) ->
 844     returnLne (r1:rs1, r2:rs2)
 845
 846 mapAndUnzip3Lne :: (a -> LneM (b,c,d)) -> [a] -> LneM ([b],[c],[d])
 847
 848 mapAndUnzip3Lne f []    = returnLne ([],[],[])
 849 mapAndUnzip3Lne f (x:xs)
 850   = f x                  `thenLne` \ (r1,  r2,  r3)  ->
 851     mapAndUnzip3Lne f xs `thenLne` \ (rs1, rs2, rs3) ->
 852     returnLne (r1:rs1, r2:rs2, r3:rs3)
 853
 854 fixLne :: (a -> LneM a) -> LneM a
 855 fixLne expr env lvs_cont
 856   = result
 857   where
 858     result = expr result env lvs_cont
 859 \end{code}
 860
 861 Functions specific to this monad:
 862
 863 \begin{code}
 864 getVarsLiveInCont :: LneM (StgLiveVars, IdSet)
 865 getVarsLiveInCont env lvs_cont = lvs_cont
 866
 867 setVarsLiveInCont :: (StgLiveVars,IdSet) -> LneM a -> LneM a
 868 setVarsLiveInCont new_lvs_cont expr env lvs_cont
 869   = expr env new_lvs_cont
 870
 871 extendVarEnvLne :: [(Id, HowBound)] -> LneM a -> LneM a
 872 extendVarEnvLne ids_w_howbound expr env lvs_cont
 873   = expr (extendVarEnvList env ids_w_howbound) lvs_cont
 874
 875 lookupVarLne :: Id -> LneM HowBound
 876 lookupVarLne v env lvs_cont
 877   = returnLne (
 878       case (lookupVarEnv env v) of
 879         Just xx -> xx
 880         Nothing -> ImportBound
 881     ) env lvs_cont
 882
 883 -- The result of lookupLiveVarsForSet, a set of live variables, is
 884 -- only ever tacked onto a decorated expression. It is never used as
 885 -- the basis of a control decision, which might give a black hole.
 886
 887 freeVarsToLiveVars :: FreeVarsInfo -> LneM (StgLiveVars, IdSet)
 888 freeVarsToLiveVars fvs env live_in_cont
 889   = returnLne (lvs, cafs) env live_in_cont
 890   where
 891     (lvs_cont, cafs_cont) = live_in_cont -- not a strict pattern match!
 892     (local, global) = partition isLocalId (allFreeIds fvs)
 893
 894     (lvs_from_fvs, caf_extras) = unzip (map do_one local)
 895
 896     lvs = unionVarSets lvs_from_fvs
 897                 `unionVarSet` lvs_cont
 898
 899     cafs = mkVarSet (filter is_caf_one global)
 900                 `unionVarSet` (unionVarSets caf_extras)
 901                 `unionVarSet` cafs_cont
 902
 903     do_one v
 904       = case (lookupVarEnv env v) of
 905               Just (LetBound _ (lvs,cafs) _) -> (extendVarSet lvs v, cafs)
 906               Just _                         -> (unitVarSet v, emptyVarSet)
 907               Nothing -> pprPanic "lookupLiveVarsForSet/do_one:" (ppr v)
 908
 909     is_caf_one v
 910       = case lookupVarEnv env v of
 911                 Just (LetBound TopLevelHasCafs (lvs,_) _) ->
 912                     ASSERT( isEmptyVarSet lvs ) True
 913                 Just (LetBound _ _ _) -> False
 914                 _otherwise          -> mayHaveCafRefs (idCafInfo v)
 915 \end{code}
 916
 917 %************************************************************************
 918 %*                                                                      *
 919 \subsection[Free-var info]{Free variable information}
 920 %*                                                                      *
 921 %************************************************************************
 922
 923 \begin{code}
 924 type FreeVarsInfo = VarEnv (Var, TopLevelCafInfo, StgBinderInfo)
 925         -- If f is mapped to noBinderInfo, that means
 926         -- that f *is* mentioned (else it wouldn't be in the
 927         -- IdEnv at all), but perhaps in an unsaturated applications.
 928         --
 929         -- All case/lambda-bound things are also mapped to
 930         -- noBinderInfo, since we aren't interested in their
 931         -- occurence info.
 932         --
 933         -- For ILX we track free var info for type variables too;
 934         -- hence VarEnv not IdEnv
 935
 936 data TopLevelCafInfo
 937   = NotTopLevelBound
 938   | TopLevelNoCafs
 939   | TopLevelHasCafs
 940   deriving Eq
 941
 942 type EscVarsSet = IdSet
 943 \end{code}
 944
 945 \begin{code}
 946 emptyFVInfo :: FreeVarsInfo
 947 emptyFVInfo = emptyVarEnv
 948
 949 singletonFVInfo :: Id -> HowBound -> StgBinderInfo -> FreeVarsInfo
 950 singletonFVInfo id ImportBound info
 951    | mayHaveCafRefs (idCafInfo id) = unitVarEnv id (id, TopLevelHasCafs, info)
 952    | otherwise                     = emptyVarEnv
 953 singletonFVInfo id (LetBound top_level _ _) info
 954    = unitVarEnv id (id, top_level, info)
 955 singletonFVInfo id other info
 956    = unitVarEnv id (id, NotTopLevelBound, info)
 957
 958 tyvarFVInfo :: TyVarSet -> FreeVarsInfo
 959 tyvarFVInfo tvs = foldVarSet add emptyFVInfo tvs
 960         where
 961           add tv fvs = extendVarEnv fvs tv (tv, NotTopLevelBound, noBinderInfo)
 962
 963 unionFVInfo :: FreeVarsInfo -> FreeVarsInfo -> FreeVarsInfo
 964 unionFVInfo fv1 fv2 = plusVarEnv_C plusFVInfo fv1 fv2
 965
 966 unionFVInfos :: [FreeVarsInfo] -> FreeVarsInfo
 967 unionFVInfos fvs = foldr unionFVInfo emptyFVInfo fvs
 968
 969 minusFVBinders :: [Id] -> FreeVarsInfo -> FreeVarsInfo
 970 minusFVBinders vs fv = foldr minusFVBinder fv vs
 971
 972 minusFVBinder :: Id -> FreeVarsInfo -> FreeVarsInfo
 973 minusFVBinder v fv | isId v && opt_KeepStgTypes
 974                    = (fv `delVarEnv` v) `unionFVInfo`
 975                      tyvarFVInfo (tyVarsOfType (idType v))
 976                    | otherwise = fv `delVarEnv` v
 977         -- When removing a binder, remember to add its type variables
 978         -- c.f. CoreFVs.delBinderFV
 979
 980 elementOfFVInfo :: Id -> FreeVarsInfo -> Bool
 981 elementOfFVInfo id fvs = maybeToBool (lookupVarEnv fvs id)
 982
 983 lookupFVInfo :: FreeVarsInfo -> Id -> StgBinderInfo
 984 -- Find how the given Id is used.
 985 -- Externally visible things may be used any old how
 986 lookupFVInfo fvs id
 987   | isExternallyVisibleName (idName id) = noBinderInfo
 988   | otherwise = case lookupVarEnv fvs id of
 989                         Nothing         -> noBinderInfo
 990                         Just (_,_,info) -> info
 991
 992 allFreeIds :: FreeVarsInfo -> [Id]      -- Non-top-level things only
 993 allFreeIds fvs = [id | (id,_,_) <- rngVarEnv fvs, isId id]
 994
 995 -- Non-top-level things only, both type variables and ids (type variables
 996 -- only if opt_KeepStgTypes.
 997 getFVs :: FreeVarsInfo -> [Var]
 998 getFVs fvs = [id | (id,NotTopLevelBound,_) <- rngVarEnv fvs]
 999
1000 getFVSet :: FreeVarsInfo -> VarSet
1001 getFVSet fvs = mkVarSet (getFVs fvs)
1002
1003 plusFVInfo (id1,top1,info1) (id2,top2,info2)
1004   = ASSERT (id1 == id2 && top1 == top2)
1005     (id1, top1, combineStgBinderInfo info1 info2)
1006 \end{code}
1007
1008 Misc.
1009 \begin{code}
1010 filterStgBinders :: [Var] -> [Var]
1011 filterStgBinders bndrs
1012   | opt_KeepStgTypes = bndrs
1013   | otherwise        = filter isId bndrs
1014 \end{code}
1015
1016
1017 \begin{code}
1018         -- Ignore all notes except SCC
1019 myCollectBinders expr
1020   = go [] expr
1021   where
1022     go bs (Lam b e)          = go (b:bs) e
1023     go bs e@(Note (SCC _) _) = (reverse bs, e)
1024     go bs (Note _ e)         = go bs e
1025     go bs e                  = (reverse bs, e)
1026
1027 myCollectArgs :: CoreExpr -> (Id, [CoreArg])
1028         -- We assume that we only have variables
1029         -- in the function position by now
1030 myCollectArgs expr
1031   = go expr []
1032   where
1033     go (Var v)          as = (v, as)
1034     go (App f a) as        = go f (a:as)
1035     go (Note (SCC _) e) as = pprPanic "CoreToStg.myCollectArgs" (ppr expr)
1036     go (Note n e)       as = go e as
1037     go _                as = pprPanic "CoreToStg.myCollectArgs" (ppr expr)
1038 \end{code}
1039
1040 %************************************************************************
1041 %*                                                                      *
1042 \subsection{Figuring out CafInfo for an expression}
1043 %*                                                                      *
1044 %************************************************************************
1045
1046 hasCafRefs decides whether a top-level closure can point into the dynamic heap.
1047 We mark such things as `MayHaveCafRefs' because this information is
1048 used to decide whether a particular closure needs to be referenced
1049 in an SRT or not.
1050
1051 There are two reasons for setting MayHaveCafRefs:
1052         a) The RHS is a CAF: a top-level updatable thunk.
1053         b) The RHS refers to something that MayHaveCafRefs
1054
1055 Possible improvement: In an effort to keep the number of CAFs (and
1056 hence the size of the SRTs) down, we could also look at the expression and
1057 decide whether it requires a small bounded amount of heap, so we can ignore
1058 it as a CAF.  In these cases however, we would need to use an additional
1059 CAF list to keep track of non-collectable CAFs.
1060
1061 \begin{code}
1062 hasCafRefs  :: IdEnv HowBound -> CoreExpr -> CafInfo
1063 -- Only called for the RHS of top-level lets
1064 hasCafRefss :: IdEnv HowBound -> [CoreExpr] -> CafInfo
1065         -- predicate returns True for a given Id if we look at this Id when
1066         -- calculating the result.  Used to *avoid* looking at the CafInfo
1067         -- field for an Id that is part of the current recursive group.
1068
1069 hasCafRefs p expr
1070   | isCAF expr || isFastTrue (cafRefs p expr) =  MayHaveCafRefs
1071   | otherwise = NoCafRefs
1072
1073         -- used for recursive groups.  The whole group is set to
1074         -- "MayHaveCafRefs" if at least one of the group is a CAF or
1075         -- refers to any CAFs.
1076 hasCafRefss p exprs
1077   | any isCAF exprs || isFastTrue (cafRefss p exprs) = MayHaveCafRefs
1078   | otherwise = NoCafRefs
1079
1080 -- cafRefs compiles to beautiful code :)
1081
1082 cafRefs p (Var id)
1083   | isLocalId id = fastBool False
1084   | otherwise =
1085       case lookupVarEnv p id of
1086         Just (LetBound TopLevelHasCafs _ _) -> fastBool True
1087         Just (LetBound _ _ _) -> fastBool False
1088         Nothing -> fastBool (cgMayHaveCafRefs (idCgInfo id)) --  imported Ids
1089
1090 cafRefs p (Lit l)            = fastBool False
1091 cafRefs p (App f a)          = fastOr (cafRefs p f) (cafRefs p) a
1092 cafRefs p (Lam x e)          = cafRefs p e
1093 cafRefs p (Let b e)          = fastOr (cafRefss p (rhssOfBind b)) (cafRefs p) e
1094 cafRefs p (Case e bndr alts) = fastOr (cafRefs p e)
1095                                 (cafRefss p) (rhssOfAlts alts)
1096 cafRefs p (Note n e)         = cafRefs p e
1097 cafRefs p (Type t)           = fastBool False
1098
1099 cafRefss p []     = fastBool False
1100 cafRefss p (e:es) = fastOr (cafRefs p e) (cafRefss p) es
1101
1102 -- hack for lazy-or over FastBool.
1103 fastOr a f x = fastBool (isFastTrue a || isFastTrue (f x))
1104
1105 isCAF :: CoreExpr -> Bool
1106 -- Only called for the RHS of top-level lets
1107 isCAF e = not (rhsIsNonUpd e)
1108   {- ToDo: check type for onceness, i.e. non-updatable thunks? -}
1109
1110
1111 rhsIsNonUpd :: CoreExpr -> Bool
1112   -- True => Value-lambda, constructor, PAP
1113   -- This is a bit like CoreUtils.exprIsValue, with the following differences:
1114   --    a) scc "foo" (\x -> ...) is updatable (so we catch the right SCC)
1115   --
1116   --    b) (C x xs), where C is a contructors is updatable if the application is
1117   --       dynamic: see isDynConApp
1118   --
1119   --    c) don't look through unfolding of f in (f x).  I'm suspicious of this one
1120
1121 -- This function has to line up with what the update flag
1122 -- for the StgRhs gets set to in mkStgRhs (above)
1123 --
1124 -- When opt_KeepStgTypes is on, we keep type lambdas and treat
1125 -- them as making the RHS re-entrant (non-updatable).
1126 rhsIsNonUpd (Lam b e)          = isRuntimeVar b || rhsIsNonUpd e
1127 rhsIsNonUpd (Note (SCC _) e)   = False
1128 rhsIsNonUpd (Note _ e)         = rhsIsNonUpd e
1129 rhsIsNonUpd other_expr
1130   = go other_expr 0 []
1131   where
1132     go (Var f) n_args args = idAppIsNonUpd f n_args args
1133
1134     go (App f a) n_args args
1135         | isTypeArg a = go f n_args args
1136         | otherwise   = go f (n_args + 1) (a:args)
1137
1138     go (Note (SCC _) f) n_args args = False
1139     go (Note _ f) n_args args       = go f n_args args
1140
1141     go other n_args args = False
1142
1143 idAppIsNonUpd :: Id -> Int -> [CoreExpr] -> Bool
1144 idAppIsNonUpd id n_val_args args
1145   | Just con <- isDataConId_maybe id = not (isCrossDllConApp con args)
1146   | otherwise                        = n_val_args < idArity id
1147
1148 isCrossDllConApp :: DataCon -> [CoreExpr] -> Bool
1149 isCrossDllConApp con args = isDllName (dataConName con) || any isCrossDllArg args
1150 -- Top-level constructor applications can usually be allocated
1151 -- statically, but they can't if
1152 --      a) the constructor, or any of the arguments, come from another DLL
1153 --      b) any of the arguments are LitLits
1154 -- (because we can't refer to static labels in other DLLs).
1155 -- If this happens we simply make the RHS into an updatable thunk,
1156 -- and 'exectute' it rather than allocating it statically.
1157 -- All this should match the decision in (see CoreToStg.coreToStgRhs)
1158
1159
1160 isCrossDllArg :: CoreExpr -> Bool
1161 -- True if somewhere in the expression there's a cross-DLL reference
1162 isCrossDllArg (Type _)    = False
1163 isCrossDllArg (Var v)     = isDllName (idName v)
1164 isCrossDllArg (Note _ e)  = isCrossDllArg e
1165 isCrossDllArg (Lit lit)   = isLitLitLit lit
1166 isCrossDllArg (App e1 e2) = isCrossDllArg e1 || isCrossDllArg e2        -- must be a type app
1167 isCrossDllArg (Lam v e)   = isCrossDllArg e     -- must be a type lam
1168 \end{code}