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 )
  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 TysPrim          ( foreignObjPrimTyCon )
  31 import Maybes           ( maybeToBool )
  32 import Name             ( getOccName, isExternallyVisibleName, isDllName )
  33 import OccName          ( occNameUserString )
  34 import BasicTypes       ( TopLevelFlag(..), isNotTopLevel, Arity )
  35 import CmdLineOpts      ( DynFlags, opt_KeepStgTypes )
  36 import FastTypes        hiding ( fastOr )
  37 import Outputable
  38
  39 import List             ( partition )
  40
  41 infixr 9 `thenLne`
  42 \end{code}
  43
  44 %************************************************************************
  45 %*                                                                      *
  46 \subsection[live-vs-free-doc]{Documentation}
  47 %*                                                                      *
  48 %************************************************************************
  49
  50 (There is other relevant documentation in codeGen/CgLetNoEscape.)
  51
  52 The actual Stg datatype is decorated with {\em live variable}
  53 information, as well as {\em free variable} information.  The two are
  54 {\em not} the same.  Liveness is an operational property rather than a
  55 semantic one.  A variable is live at a particular execution point if
  56 it can be referred to {\em directly} again.  In particular, a dead
  57 variable's stack slot (if it has one):
  58 \begin{enumerate}
  59 \item
  60 should be stubbed to avoid space leaks, and
  61 \item
  62 may be reused for something else.
  63 \end{enumerate}
  64
  65 There ought to be a better way to say this.  Here are some examples:
  66 \begin{verbatim}
  67         let v = [q] \[x] -> e
  68         in
  69         ...v...  (but no q's)
  70 \end{verbatim}
  71
  72 Just after the `in', v is live, but q is dead.  If the whole of that
  73 let expression was enclosed in a case expression, thus:
  74 \begin{verbatim}
  75         case (let v = [q] \[x] -> e in ...v...) of
  76                 alts[...q...]
  77 \end{verbatim}
  78 (ie @alts@ mention @q@), then @q@ is live even after the `in'; because
  79 we'll return later to the @alts@ and need it.
  80
  81 Let-no-escapes make this a bit more interesting:
  82 \begin{verbatim}
  83         let-no-escape v = [q] \ [x] -> e
  84         in
  85         ...v...
  86 \end{verbatim}
  87 Here, @q@ is still live at the `in', because @v@ is represented not by
  88 a closure but by the current stack state.  In other words, if @v@ is
  89 live then so is @q@.  Furthermore, if @e@ mentions an enclosing
  90 let-no-escaped variable, then {\em its} free variables are also live
  91 if @v@ is.
  92
  93 %************************************************************************
  94 %*                                                                      *
  95 \subsection[caf-info]{Collecting live CAF info}
  96 %*                                                                      *
  97 %************************************************************************
  98
  99 In this pass we also collect information on which CAFs are live for
 100 constructing SRTs (see SRT.lhs).
 101
 102 A top-level Id has CafInfo, which is
 103
 104         - MayHaveCafRefs, if it may refer indirectly to
 105           one or more CAFs, or
 106         - NoCafRefs if it definitely doesn't
 107
 108 we collect the CafInfo first by analysing the original Core expression, and
 109 also place this information in the environment.
 110
 111 During CoreToStg, we then pin onto each binding and case expression, a
 112 list of Ids which represents the "live" CAFs at that point.  The meaning
 113 of "live" here is the same as for live variables, see above (which is
 114 why it's convenient to collect CAF information here rather than elsewhere).
 115
 116 The later SRT pass takes these lists of Ids and uses them to construct
 117 the actual nested SRTs, and replaces the lists of Ids with (offset,length)
 118 pairs.
 119
 120 %************************************************************************
 121 %*                                                                      *
 122 \subsection[binds-StgVarInfo]{Setting variable info: top-level, binds, RHSs}
 123 %*                                                                      *
 124 %************************************************************************
 125
 126 \begin{code}
 127 coreToStg :: DynFlags -> [CoreBind] -> IO [StgBinding]
 128 coreToStg dflags pgm
 129   = return pgm'
 130   where (_, _, pgm') = coreTopBindsToStg emptyVarEnv pgm
 131
 132 coreExprToStg :: CoreExpr -> StgExpr
 133 coreExprToStg expr
 134   = new_expr where (new_expr,_,_) = initLne emptyVarEnv (coreToStgExpr expr)
 135
 136
 137 coreTopBindsToStg
 138     :: IdEnv HowBound           -- environment for the bindings
 139     -> [CoreBind]
 140     -> (IdEnv HowBound, FreeVarsInfo, [StgBinding])
 141
 142 coreTopBindsToStg env [] = (env, emptyFVInfo, [])
 143 coreTopBindsToStg env (b:bs)
 144   = (env2, fvs2, b':bs')
 145   where
 146         -- env accumulates down the list of binds, fvs accumulates upwards
 147         (env1, fvs2, b' ) = coreTopBindToStg env fvs1 b
 148         (env2, fvs1, bs') = coreTopBindsToStg env1 bs
 149
 150
 151 coreTopBindToStg
 152         :: IdEnv HowBound
 153         -> FreeVarsInfo         -- Info about the body
 154         -> CoreBind
 155         -> (IdEnv HowBound, FreeVarsInfo, StgBinding)
 156
 157 coreTopBindToStg env body_fvs (NonRec id rhs)
 158   = let
 159         caf_info = hasCafRefs env rhs
 160
 161         env' = extendVarEnv env id (LetBound how_bound emptyLVS (predictArity rhs))
 162
 163         how_bound | mayHaveCafRefs caf_info = TopLevelHasCafs
 164                   | otherwise               = TopLevelNoCafs
 165
 166         (stg_rhs, fvs', cafs) =
 167             initLne env (
 168               coreToStgRhs body_fvs TopLevel (id,rhs)
 169                         `thenLne` \ (stg_rhs, fvs', _) ->
 170               freeVarsToLiveVars fvs' `thenLne` \ (_, cafs) ->
 171               returnLne (stg_rhs, fvs', cafs)
 172            )
 173
 174         bind = StgNonRec (SRTEntries cafs) id stg_rhs
 175     in
 176     ASSERT2(predictArity rhs == stgRhsArity stg_rhs, ppr id)
 177     ASSERT2(consistent caf_info bind, ppr id)
 178 --    WARN(not (consistent caf_info bind), ppr id <+> ppr cafs <+> ppCafInfo caf_info)
 179     (env', fvs' `unionFVInfo` body_fvs, bind)
 180
 181 coreTopBindToStg env body_fvs (Rec pairs)
 182   = let
 183         (binders, rhss) = unzip pairs
 184
 185         -- to calculate caf_info, we initially map all the binders to
 186         -- TopLevelNoCafs.
 187         env1 = extendVarEnvList env
 188                 [ (b, LetBound TopLevelNoCafs emptyLVS (error "no arity"))
 189                 | b <- binders ]
 190
 191         caf_info = hasCafRefss env1{-NB: not env'-} rhss
 192
 193         env' = extendVarEnvList env
 194                 [ (b, LetBound how_bound emptyLVS (predictArity rhs))
 195                 | (b,rhs) <- pairs ]
 196
 197         how_bound | mayHaveCafRefs caf_info = TopLevelHasCafs
 198                   | otherwise               = TopLevelNoCafs
 199
 200         (stg_rhss, fvs', cafs)
 201           = initLne env' (
 202                mapAndUnzip3Lne (coreToStgRhs body_fvs TopLevel) pairs
 203                         `thenLne` \ (stg_rhss, fvss', _) ->
 204                let fvs' = unionFVInfos fvss' in
 205                freeVarsToLiveVars fvs'  `thenLne` \ (_, cafs) ->
 206                returnLne (stg_rhss, fvs', cafs)
 207            )
 208
 209         bind = StgRec (SRTEntries cafs) (zip binders stg_rhss)
 210     in
 211     ASSERT2(and [predictArity rhs == stgRhsArity stg_rhs | (rhs,stg_rhs) <- rhss `zip` stg_rhss], ppr binders)
 212     ASSERT2(consistent caf_info bind, ppr binders)
 213 --    WARN(not (consistent caf_info bind), ppr binders <+> ppr cafs <+> ppCafInfo caf_info)
 214     (env', fvs' `unionFVInfo` body_fvs, bind)
 215
 216 -- assertion helper
 217 consistent caf_info bind = mayHaveCafRefs caf_info == stgBindHasCafRefs bind
 218 \end{code}
 219
 220 \begin{code}
 221 coreToStgRhs
 222         :: FreeVarsInfo         -- Free var info for the scope of the binding
 223         -> TopLevelFlag
 224         -> (Id,CoreExpr)
 225         -> LneM (StgRhs, FreeVarsInfo, EscVarsSet)
 226
 227 coreToStgRhs scope_fv_info top (binder, rhs)
 228   = coreToStgExpr rhs  `thenLne` \ (new_rhs, rhs_fvs, rhs_escs) ->
 229     returnLne (mkStgRhs top rhs_fvs binder_info new_rhs,
 230                rhs_fvs, rhs_escs)
 231   where
 232     binder_info = lookupFVInfo scope_fv_info binder
 233
 234 mkStgRhs :: TopLevelFlag -> FreeVarsInfo -> StgBinderInfo
 235          -> StgExpr -> StgRhs
 236
 237 mkStgRhs top rhs_fvs binder_info (StgLam _ bndrs body)
 238   = StgRhsClosure noCCS binder_info
 239                   (getFVs rhs_fvs)
 240                   ReEntrant
 241                   bndrs body
 242
 243 mkStgRhs top rhs_fvs binder_info (StgConApp con args)
 244   | isNotTopLevel top || not (isDllConApp con args)
 245   = StgRhsCon noCCS con args
 246
 247 mkStgRhs top rhs_fvs binder_info rhs
 248   = StgRhsClosure noCCS binder_info
 249                   (getFVs rhs_fvs)
 250                   (updatable [] rhs)
 251                   [] rhs
 252   where
 253     updatable args body | null args && isPAP body  = ReEntrant
 254                         | otherwise                = Updatable
 255 {- ToDo:
 256           upd = if isOnceDem dem
 257                     then (if isNotTop toplev
 258                             then SingleEntry    -- HA!  Paydirt for "dem"
 259                             else
 260 #ifdef DEBUG
 261                      trace "WARNING: SE CAFs unsupported, forcing UPD instead" $
 262 #endif
 263                      Updatable)
 264                 else Updatable
 265         -- For now we forbid SingleEntry CAFs; they tickle the
 266         -- ASSERT in rts/Storage.c line 215 at newCAF() re mut_link,
 267         -- and I don't understand why.  There's only one SE_CAF (well,
 268         -- only one that tickled a great gaping bug in an earlier attempt
 269         -- at ClosureInfo.getEntryConvention) in the whole of nofib,
 270         -- specifically Main.lvl6 in spectral/cryptarithm2.
 271         -- So no great loss.  KSW 2000-07.
 272 -}
 273 \end{code}
 274
 275 Detect thunks which will reduce immediately to PAPs, and make them
 276 non-updatable.  This has several advantages:
 277
 278         - the non-updatable thunk behaves exactly like the PAP,
 279
 280         - the thunk is more efficient to enter, because it is
 281           specialised to the task.
 282
 283         - we save one update frame, one stg_update_PAP, one update
 284           and lots of PAP_enters.
 285
 286         - in the case where the thunk is top-level, we save building
 287           a black hole and futhermore the thunk isn't considered to
 288           be a CAF any more, so it doesn't appear in any SRTs.
 289
 290 We do it here, because the arity information is accurate, and we need
 291 to do it before the SRT pass to save the SRT entries associated with
 292 any top-level PAPs.
 293
 294 \begin{code}
 295 isPAP (StgApp f args) = idArity f > length args
 296 isPAP _               = False
 297 \end{code}
 298
 299
 300 -- ---------------------------------------------------------------------------
 301 -- Expressions
 302 -- ---------------------------------------------------------------------------
 303
 304 \begin{code}
 305 coreToStgExpr
 306         :: CoreExpr
 307         -> LneM (StgExpr,       -- Decorated STG expr
 308                  FreeVarsInfo,  -- Its free vars (NB free, not live)
 309                  EscVarsSet)    -- Its escapees, a subset of its free vars;
 310                                 -- also a subset of the domain of the envt
 311                                 -- because we are only interested in the escapees
 312                                 -- for vars which might be turned into
 313                                 -- let-no-escaped ones.
 314 \end{code}
 315
 316 The second and third components can be derived in a simple bottom up pass, not
 317 dependent on any decisions about which variables will be let-no-escaped or
 318 not.  The first component, that is, the decorated expression, may then depend
 319 on these components, but it in turn is not scrutinised as the basis for any
 320 decisions.  Hence no black holes.
 321
 322 \begin{code}
 323 coreToStgExpr (Lit l) = returnLne (StgLit l, emptyFVInfo, emptyVarSet)
 324 coreToStgExpr (Var v) = coreToStgApp Nothing v []
 325
 326 coreToStgExpr expr@(App _ _)
 327   = coreToStgApp Nothing f args
 328   where
 329     (f, args) = myCollectArgs expr
 330
 331 coreToStgExpr expr@(Lam _ _)
 332   = let (args, body) = myCollectBinders expr
 333         args'        = filterStgBinders args
 334     in
 335     extendVarEnvLne [ (a, LambdaBound) | a <- args' ] $
 336     coreToStgExpr body  `thenLne` \ (body, body_fvs, body_escs) ->
 337     let
 338         set_of_args     = mkVarSet args'
 339         fvs             = args' `minusFVBinders` body_fvs
 340         escs            = body_escs `minusVarSet`    set_of_args
 341         result_expr | null args' = body
 342                     | otherwise  = StgLam (exprType expr) args' body
 343     in
 344     returnLne (result_expr, fvs, escs)
 345
 346 coreToStgExpr (Note (SCC cc) expr)
 347   = coreToStgExpr expr          `thenLne` ( \ (expr2, fvs, escs) ->
 348     returnLne (StgSCC cc expr2, fvs, escs) )
 349
 350 coreToStgExpr (Note other_note expr)
 351   = coreToStgExpr expr
 352
 353
 354 -- Cases require a little more real work.
 355
 356 coreToStgExpr (Case scrut bndr alts)
 357   = extendVarEnvLne [(bndr, CaseBound)] $
 358     vars_alts (findDefault alts)   `thenLne` \ (alts2, alts_fvs, alts_escs) ->
 359     freeVarsToLiveVars  alts_fvs   `thenLne` \ (alts_lvs, alts_caf_refs) ->
 360     let
 361         -- determine whether the default binder is dead or not
 362         -- This helps the code generator to avoid generating an assignment
 363         -- for the case binder (is extremely rare cases) ToDo: remove.
 364         bndr'= if (bndr `elementOfFVInfo` alts_fvs)
 365                   then bndr
 366                   else bndr `setIdOccInfo` IAmDead
 367
 368         -- Don't consider the default binder as being 'live in alts',
 369         -- since this is from the point of view of the case expr, where
 370         -- the default binder is not free.
 371         live_in_alts = (alts_lvs `minusVarSet` unitVarSet bndr)
 372     in
 373         -- we tell the scrutinee that everything live in the alts
 374         -- is live in it, too.
 375     setVarsLiveInCont (live_in_alts,alts_caf_refs) (
 376         coreToStgExpr scrut       `thenLne` \ (scrut2, scrut_fvs, scrut_escs) ->
 377         freeVarsToLiveVars scrut_fvs `thenLne` \ (scrut_lvs, _) ->
 378         returnLne (scrut2, scrut_fvs, scrut_escs, scrut_lvs)
 379       )
 380                 `thenLne` \ (scrut2, scrut_fvs, scrut_escs, scrut_lvs) ->
 381
 382     let srt = SRTEntries alts_caf_refs
 383     in
 384     returnLne (
 385       StgCase scrut2 scrut_lvs live_in_alts bndr' srt alts2,
 386       bndr `minusFVBinder` (scrut_fvs `unionFVInfo` alts_fvs),
 387       (alts_escs `minusVarSet` unitVarSet bndr) `unionVarSet` getFVSet scrut_fvs
 388                 -- You might think we should have scrut_escs, not
 389                 -- (getFVSet scrut_fvs), but actually we can't call, and
 390                 -- then return from, a let-no-escape thing.
 391       )
 392   where
 393     scrut_ty   = idType bndr
 394     prim_case  = isUnLiftedType scrut_ty && not (isUnboxedTupleType scrut_ty)
 395
 396     vars_alts (alts,deflt)
 397         | prim_case
 398         = mapAndUnzip3Lne vars_prim_alt alts
 399                         `thenLne` \ (alts2,  alts_fvs_list,  alts_escs_list) ->
 400           let
 401               alts_fvs  = unionFVInfos alts_fvs_list
 402               alts_escs = unionVarSets alts_escs_list
 403           in
 404           vars_deflt deflt `thenLne` \ (deflt2, deflt_fvs, deflt_escs) ->
 405           returnLne (
 406               mkStgPrimAlts scrut_ty alts2 deflt2,
 407               alts_fvs  `unionFVInfo`   deflt_fvs,
 408               alts_escs `unionVarSet` deflt_escs
 409           )
 410
 411         | otherwise
 412         = mapAndUnzip3Lne vars_alg_alt alts
 413                         `thenLne` \ (alts2,  alts_fvs_list,  alts_escs_list) ->
 414           let
 415               alts_fvs  = unionFVInfos alts_fvs_list
 416               alts_escs = unionVarSets alts_escs_list
 417           in
 418           vars_deflt deflt `thenLne` \ (deflt2, deflt_fvs, deflt_escs) ->
 419           returnLne (
 420               mkStgAlgAlts scrut_ty alts2 deflt2,
 421               alts_fvs  `unionFVInfo`   deflt_fvs,
 422               alts_escs `unionVarSet` deflt_escs
 423           )
 424
 425       where
 426         vars_prim_alt (LitAlt lit, _, rhs)
 427           = coreToStgExpr rhs   `thenLne` \ (rhs2, rhs_fvs, rhs_escs) ->
 428             returnLne ((lit, rhs2), rhs_fvs, rhs_escs)
 429
 430         vars_alg_alt (DataAlt con, binders, rhs)
 431           = let
 432                 -- remove type variables
 433                 binders' = filterStgBinders binders
 434             in
 435             extendVarEnvLne [(b, CaseBound) | b <- binders']    $
 436             coreToStgExpr rhs   `thenLne` \ (rhs2, rhs_fvs, rhs_escs) ->
 437             let
 438                 good_use_mask = [ b `elementOfFVInfo` rhs_fvs | b <- binders' ]
 439                 -- records whether each param is used in the RHS
 440             in
 441             returnLne (
 442                 (con, binders', good_use_mask, rhs2),
 443                 binders' `minusFVBinders` rhs_fvs,
 444                 rhs_escs `minusVarSet`   mkVarSet binders'
 445                         -- ToDo: remove the minusVarSet;
 446                         -- since escs won't include any of these binders
 447             )
 448         vars_alg_alt other = pprPanic "vars_alg_alt" (ppr other)
 449
 450         vars_deflt Nothing
 451            = returnLne (StgNoDefault, emptyFVInfo, emptyVarSet)
 452
 453         vars_deflt (Just rhs)
 454            = coreToStgExpr rhs  `thenLne` \ (rhs2, rhs_fvs, rhs_escs) ->
 455              returnLne (StgBindDefault rhs2, rhs_fvs, rhs_escs)
 456 \end{code}
 457
 458 Lets not only take quite a bit of work, but this is where we convert
 459 then to let-no-escapes, if we wish.
 460
 461 (Meanwhile, we don't expect to see let-no-escapes...)
 462 \begin{code}
 463 coreToStgExpr (Let bind body)
 464   = fixLne (\ ~(_, _, _, no_binder_escapes) ->
 465         coreToStgLet no_binder_escapes bind body
 466     )                           `thenLne` \ (new_let, fvs, escs, _) ->
 467
 468     returnLne (new_let, fvs, escs)
 469 \end{code}
 470
 471 If we've got a case containing a _ccall_GC_ primop, we need to
 472 ensure that the arguments are kept live for the duration of the
 473 call. This only an issue
 474
 475 \begin{code}
 476 isForeignObjArg :: Id -> Bool
 477 isForeignObjArg x = isId x && isForeignObjPrimTy (idType x)
 478
 479 isForeignObjPrimTy ty
 480    = case splitTyConApp_maybe ty of
 481         Just (tycon, _) -> tycon == foreignObjPrimTyCon
 482         Nothing         -> False
 483 \end{code}
 484
 485 \begin{code}
 486 mkStgAlgAlts ty alts deflt
 487  =  case alts of
 488                 -- Get the tycon from the data con
 489         (dc, _, _, _) : _rest
 490             -> StgAlgAlts (Just (dataConTyCon dc)) alts deflt
 491
 492                 -- Otherwise just do your best
 493         [] -> case splitTyConApp_maybe (repType ty) of
 494                 Just (tc,_) | isAlgTyCon tc
 495                         -> StgAlgAlts (Just tc) alts deflt
 496                 other
 497                         -> StgAlgAlts Nothing alts deflt
 498
 499 mkStgPrimAlts ty alts deflt
 500   = StgPrimAlts (tyConAppTyCon ty) alts deflt
 501 \end{code}
 502
 503
 504 -- ---------------------------------------------------------------------------
 505 -- Applications
 506 -- ---------------------------------------------------------------------------
 507
 508 \begin{code}
 509 coreToStgApp
 510          :: Maybe UpdateFlag            -- Just upd <=> this application is
 511                                         -- the rhs of a thunk binding
 512                                         --      x = [...] \upd [] -> the_app
 513                                         -- with specified update flag
 514         -> Id                           -- Function
 515         -> [CoreArg]                    -- Arguments
 516         -> LneM (StgExpr, FreeVarsInfo, EscVarsSet)
 517
 518 coreToStgApp maybe_thunk_body f args
 519   = coreToStgArgs args          `thenLne` \ (args', args_fvs) ->
 520     lookupVarLne f              `thenLne` \ how_bound ->
 521
 522     let
 523         n_val_args       = valArgCount args
 524         not_letrec_bound = not (isLetBound how_bound)
 525         fun_fvs          = singletonFVInfo f how_bound fun_occ
 526
 527         f_arity = case how_bound of
 528                         LetBound _ _ arity -> arity
 529                         _                  -> 0
 530
 531         fun_occ
 532          | not_letrec_bound                     = noBinderInfo  -- Uninteresting variable
 533          | f_arity > 0 && f_arity <= n_val_args = stgSatOcc     -- Saturated or over-saturated function call
 534          | otherwise                            = stgUnsatOcc   -- Unsaturated function or thunk
 535
 536         fun_escs
 537          | not_letrec_bound      = emptyVarSet  -- Only letrec-bound escapees are interesting
 538          | f_arity == n_val_args = emptyVarSet  -- A function *or thunk* with an exactly
 539                                                 -- saturated call doesn't escape
 540                                                 -- (let-no-escape applies to 'thunks' too)
 541
 542          | otherwise         = unitVarSet f     -- Inexact application; it does escape
 543
 544         -- At the moment of the call:
 545
 546         --  either the function is *not* let-no-escaped, in which case
 547         --         nothing is live except live_in_cont
 548         --      or the function *is* let-no-escaped in which case the
 549         --         variables it uses are live, but still the function
 550         --         itself is not.  PS.  In this case, the function's
 551         --         live vars should already include those of the
 552         --         continuation, but it does no harm to just union the
 553         --         two regardless.
 554
 555         app = case globalIdDetails f of
 556                 DataConId dc -> StgConApp dc args'
 557                 PrimOpId op  -> StgPrimApp op args' (exprType (mkApps (Var f) args))
 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 (allFVs 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 allFVs :: FreeVarsInfo -> [Id]  -- Non-top-level things only
 993 allFVs fvs = [id | (id,_,_) <- rngVarEnv fvs]
 994
 995 getFVs :: FreeVarsInfo -> [Id]  -- Non-top-level things only
 996 getFVs fvs = [id | (id,NotTopLevelBound,_) <- rngVarEnv fvs]
 997
 998 getFVSet :: FreeVarsInfo -> IdSet
 999 getFVSet fvs = mkVarSet (getFVs fvs)
1000
1001 plusFVInfo (id1,top1,info1) (id2,top2,info2)
1002   = ASSERT (id1 == id2 && top1 == top2)
1003     (id1, top1, combineStgBinderInfo info1 info2)
1004 \end{code}
1005
1006 Misc.
1007 \begin{code}
1008 filterStgBinders :: [Var] -> [Var]
1009 filterStgBinders bndrs
1010   | opt_KeepStgTypes = bndrs
1011   | otherwise        = filter isId bndrs
1012 \end{code}
1013
1014
1015 \begin{code}
1016         -- Ignore all notes except SCC
1017 myCollectBinders expr
1018   = go [] expr
1019   where
1020     go bs (Lam b e)          = go (b:bs) e
1021     go bs e@(Note (SCC _) _) = (reverse bs, e)
1022     go bs (Note _ e)         = go bs e
1023     go bs e                  = (reverse bs, e)
1024
1025 myCollectArgs :: CoreExpr -> (Id, [CoreArg])
1026         -- We assume that we only have variables
1027         -- in the function position by now
1028 myCollectArgs expr
1029   = go expr []
1030   where
1031     go (Var v)          as = (v, as)
1032     go (App f a) as        = go f (a:as)
1033     go (Note (SCC _) e) as = pprPanic "CoreToStg.myCollectArgs" (ppr expr)
1034     go (Note n e)       as = go e as
1035     go _                as = pprPanic "CoreToStg.myCollectArgs" (ppr expr)
1036 \end{code}
1037
1038 %************************************************************************
1039 %*                                                                      *
1040 \subsection{Figuring out CafInfo for an expression}
1041 %*                                                                      *
1042 %************************************************************************
1043
1044 hasCafRefs decides whether a top-level closure can point into the dynamic heap.
1045 We mark such things as `MayHaveCafRefs' because this information is
1046 used to decide whether a particular closure needs to be referenced
1047 in an SRT or not.
1048
1049 There are two reasons for setting MayHaveCafRefs:
1050         a) The RHS is a CAF: a top-level updatable thunk.
1051         b) The RHS refers to something that MayHaveCafRefs
1052
1053 Possible improvement: In an effort to keep the number of CAFs (and
1054 hence the size of the SRTs) down, we could also look at the expression and
1055 decide whether it requires a small bounded amount of heap, so we can ignore
1056 it as a CAF.  In these cases however, we would need to use an additional
1057 CAF list to keep track of non-collectable CAFs.
1058
1059 \begin{code}
1060 hasCafRefs  :: IdEnv HowBound -> CoreExpr -> CafInfo
1061 -- Only called for the RHS of top-level lets
1062 hasCafRefss :: IdEnv HowBound -> [CoreExpr] -> CafInfo
1063         -- predicate returns True for a given Id if we look at this Id when
1064         -- calculating the result.  Used to *avoid* looking at the CafInfo
1065         -- field for an Id that is part of the current recursive group.
1066
1067 hasCafRefs p expr
1068   | isCAF expr || isFastTrue (cafRefs p expr) =  MayHaveCafRefs
1069   | otherwise = NoCafRefs
1070
1071         -- used for recursive groups.  The whole group is set to
1072         -- "MayHaveCafRefs" if at least one of the group is a CAF or
1073         -- refers to any CAFs.
1074 hasCafRefss p exprs
1075   | any isCAF exprs || isFastTrue (cafRefss p exprs) = MayHaveCafRefs
1076   | otherwise = NoCafRefs
1077
1078 -- cafRefs compiles to beautiful code :)
1079
1080 cafRefs p (Var id)
1081   | isLocalId id = fastBool False
1082   | otherwise =
1083       case lookupVarEnv p id of
1084         Just (LetBound TopLevelHasCafs _ _) -> fastBool True
1085         Just (LetBound _ _ _) -> fastBool False
1086         Nothing -> fastBool (cgMayHaveCafRefs (idCgInfo id)) --  imported Ids
1087
1088 cafRefs p (Lit l)            = fastBool False
1089 cafRefs p (App f a)          = fastOr (cafRefs p f) (cafRefs p) a
1090 cafRefs p (Lam x e)          = cafRefs p e
1091 cafRefs p (Let b e)          = fastOr (cafRefss p (rhssOfBind b)) (cafRefs p) e
1092 cafRefs p (Case e bndr alts) = fastOr (cafRefs p e)
1093                                 (cafRefss p) (rhssOfAlts alts)
1094 cafRefs p (Note n e)         = cafRefs p e
1095 cafRefs p (Type t)           = fastBool False
1096
1097 cafRefss p []     = fastBool False
1098 cafRefss p (e:es) = fastOr (cafRefs p e) (cafRefss p) es
1099
1100 -- hack for lazy-or over FastBool.
1101 fastOr a f x = fastBool (isFastTrue a || isFastTrue (f x))
1102
1103 isCAF :: CoreExpr -> Bool
1104 -- Only called for the RHS of top-level lets
1105 isCAF e = not (rhsIsNonUpd e)
1106   {- ToDo: check type for onceness, i.e. non-updatable thunks? -}
1107
1108
1109 rhsIsNonUpd :: CoreExpr -> Bool
1110   -- True => Value-lambda, constructor, PAP
1111   -- This is a bit like CoreUtils.exprIsValue, with the following differences:
1112   --    a) scc "foo" (\x -> ...) is updatable (so we catch the right SCC)
1113   --
1114   --    b) (C x xs), where C is a contructors is updatable if the application is
1115   --       dynamic: see isDynConApp
1116   --
1117   --    c) don't look through unfolding of f in (f x).  I'm suspicious of this one
1118
1119 rhsIsNonUpd (Lam b e)          = isId b || rhsIsNonUpd e
1120 rhsIsNonUpd (Note (SCC _) e)   = False
1121 rhsIsNonUpd (Note _ e)         = rhsIsNonUpd e
1122 rhsIsNonUpd other_expr
1123   = go other_expr 0 []
1124   where
1125     go (Var f) n_args args = idAppIsNonUpd f n_args args
1126
1127     go (App f a) n_args args
1128         | isTypeArg a = go f n_args args
1129         | otherwise   = go f (n_args + 1) (a:args)
1130
1131     go (Note (SCC _) f) n_args args = False
1132     go (Note _ f) n_args args       = go f n_args args
1133
1134     go other n_args args = False
1135
1136 idAppIsNonUpd :: Id -> Int -> [CoreExpr] -> Bool
1137 idAppIsNonUpd id n_val_args args
1138   | Just con <- isDataConId_maybe id = not (isDynConApp con args)
1139   | otherwise                        = n_val_args < idArity id
1140
1141 isDynConApp :: DataCon -> [CoreExpr] -> Bool
1142 isDynConApp con args = isDllName (dataConName con) || any isDynArg args
1143 -- Top-level constructor applications can usually be allocated
1144 -- statically, but they can't if
1145 --      a) the constructor, or any of the arguments, come from another DLL
1146 --      b) any of the arguments are LitLits
1147 -- (because we can't refer to static labels in other DLLs).
1148 -- If this happens we simply make the RHS into an updatable thunk,
1149 -- and 'exectute' it rather than allocating it statically.
1150 -- All this should match the decision in (see CoreToStg.coreToStgRhs)
1151
1152
1153 isDynArg :: CoreExpr -> Bool
1154 isDynArg (Var v)    = isDllName (idName v)
1155 isDynArg (Note _ e) = isDynArg e
1156 isDynArg (Lit lit)  = isLitLitLit lit
1157 isDynArg (App e _)  = isDynArg e        -- must be a type app
1158 isDynArg (Lam _ e)  = isDynArg e        -- must be a type lam
1159 \end{code}