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 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          = singletonFVInfo f how_bound fun_occ
 511
 512         f_arity = case how_bound of
 513                         LetBound _ _ arity -> arity
 514                         _                  -> 0
 515
 516         fun_occ
 517          | not_letrec_bound                     = noBinderInfo  -- Uninteresting variable
 518          | f_arity > 0 && f_arity <= n_val_args = stgSatOcc     -- Saturated or over-saturated function call
 519          | otherwise                            = stgUnsatOcc   -- Unsaturated function or thunk
 520
 521         fun_escs
 522          | not_letrec_bound      = emptyVarSet  -- Only letrec-bound escapees are interesting
 523          | f_arity == n_val_args = emptyVarSet  -- A function *or thunk* with an exactly
 524                                                 -- saturated call doesn't escape
 525                                                 -- (let-no-escape applies to 'thunks' too)
 526
 527          | otherwise         = unitVarSet f     -- Inexact application; it does escape
 528
 529         -- At the moment of the call:
 530
 531         --  either the function is *not* let-no-escaped, in which case
 532         --         nothing is live except live_in_cont
 533         --      or the function *is* let-no-escaped in which case the
 534         --         variables it uses are live, but still the function
 535         --         itself is not.  PS.  In this case, the function's
 536         --         live vars should already include those of the
 537         --         continuation, but it does no harm to just union the
 538         --         two regardless.
 539
 540         res_ty = exprType (mkApps (Var f) args)
 541         app = case globalIdDetails f of
 542                 DataConId dc -> StgConApp dc                             args'
 543                 PrimOpId op  -> StgOpApp  (StgPrimOp op)                 args' res_ty
 544                 FCallId call -> StgOpApp  (StgFCallOp call (idUnique f)) args' res_ty
 545                 _other       -> StgApp f args'
 546
 547     in
 548     returnLne (
 549         app,
 550         fun_fvs  `unionFVInfo` args_fvs,
 551         fun_escs `unionVarSet` (getFVSet args_fvs)
 552                                 -- All the free vars of the args are disqualified
 553                                 -- from being let-no-escaped.
 554     )
 555
 556
 557
 558 -- ---------------------------------------------------------------------------
 559 -- Argument lists
 560 -- This is the guy that turns applications into A-normal form
 561 -- ---------------------------------------------------------------------------
 562
 563 coreToStgArgs :: [CoreArg] -> LneM ([StgArg], FreeVarsInfo)
 564 coreToStgArgs []
 565   = returnLne ([], emptyFVInfo)
 566
 567 coreToStgArgs (Type ty : args)  -- Type argument
 568   = coreToStgArgs args  `thenLne` \ (args', fvs) ->
 569     if opt_KeepStgTypes then
 570         returnLne (StgTypeArg ty : args', fvs `unionFVInfo` tyvarFVInfo (tyVarsOfType ty))
 571     else
 572     returnLne (args', fvs)
 573
 574 coreToStgArgs (arg : args)      -- Non-type argument
 575   = coreToStgArgs args  `thenLne` \ (stg_args, args_fvs) ->
 576     coreToStgExpr arg   `thenLne` \ (arg', arg_fvs, escs) ->
 577     let
 578         fvs = args_fvs `unionFVInfo` arg_fvs
 579         stg_arg = case arg' of
 580                        StgApp v []      -> StgVarArg v
 581                        StgConApp con [] -> StgVarArg (dataConWrapId con)
 582                        StgLit lit       -> StgLitArg lit
 583                        _                -> pprPanic "coreToStgArgs" (ppr arg)
 584     in
 585     returnLne (stg_arg : stg_args, fvs)
 586
 587
 588 -- ---------------------------------------------------------------------------
 589 -- The magic for lets:
 590 -- ---------------------------------------------------------------------------
 591
 592 coreToStgLet
 593          :: Bool        -- True <=> yes, we are let-no-escaping this let
 594          -> CoreBind    -- bindings
 595          -> CoreExpr    -- body
 596          -> LneM (StgExpr,      -- new let
 597                   FreeVarsInfo, -- variables free in the whole let
 598                   EscVarsSet,   -- variables that escape from the whole let
 599                   Bool)         -- True <=> none of the binders in the bindings
 600                                 -- is among the escaping vars
 601
 602 coreToStgLet let_no_escape bind body
 603   = fixLne (\ ~(_, _, _, _, _, _, rec_body_fvs, _, _) ->
 604
 605         -- Do the bindings, setting live_in_cont to empty if
 606         -- we ain't in a let-no-escape world
 607         getVarsLiveInCont               `thenLne` \ live_in_cont ->
 608         setVarsLiveInCont (if let_no_escape
 609                                 then live_in_cont
 610                                 else emptyLVS)
 611                           (vars_bind rec_body_fvs bind)
 612             `thenLne` \ ( bind2, bind_fvs, bind_escs
 613                         , bind_lvs, bind_cafs, env_ext) ->
 614
 615         -- Do the body
 616         extendVarEnvLne env_ext (
 617           coreToStgExpr body          `thenLne` \(body2, body_fvs, body_escs) ->
 618           freeVarsToLiveVars body_fvs `thenLne` \(body_lvs, _) ->
 619
 620           returnLne (bind2, bind_fvs, bind_escs, bind_lvs, bind_cafs,
 621                      body2, body_fvs, body_escs, body_lvs)
 622         )
 623
 624     ) `thenLne` (\ (bind2, bind_fvs, bind_escs, bind_lvs, bind_cafs,
 625                     body2, body_fvs, body_escs, body_lvs) ->
 626
 627
 628         -- Compute the new let-expression
 629     let
 630         new_let | let_no_escape = StgLetNoEscape live_in_whole_let bind_lvs bind2 body2
 631                 | otherwise     = StgLet bind2 body2
 632
 633         free_in_whole_let
 634           = binders `minusFVBinders` (bind_fvs `unionFVInfo` body_fvs)
 635
 636         live_in_whole_let
 637           = bind_lvs `unionVarSet` (body_lvs `minusVarSet` set_of_binders)
 638
 639         real_bind_escs = if let_no_escape then
 640                             bind_escs
 641                          else
 642                             getFVSet bind_fvs
 643                             -- Everything escapes which is free in the bindings
 644
 645         let_escs = (real_bind_escs `unionVarSet` body_escs) `minusVarSet` set_of_binders
 646
 647         all_escs = bind_escs `unionVarSet` body_escs    -- Still includes binders of
 648                                                         -- this let(rec)
 649
 650         no_binder_escapes = isEmptyVarSet (set_of_binders `intersectVarSet` all_escs)
 651
 652 #ifdef DEBUG
 653         -- Debugging code as requested by Andrew Kennedy
 654         checked_no_binder_escapes
 655                 | not no_binder_escapes && any is_join_var binders
 656                 = pprTrace "Interesting!  A join var that isn't let-no-escaped" (ppr binders)
 657                   False
 658                 | otherwise = no_binder_escapes
 659 #else
 660         checked_no_binder_escapes = no_binder_escapes
 661 #endif
 662
 663                 -- Mustn't depend on the passed-in let_no_escape flag, since
 664                 -- no_binder_escapes is used by the caller to derive the flag!
 665     in
 666     returnLne (
 667         new_let,
 668         free_in_whole_let,
 669         let_escs,
 670         checked_no_binder_escapes
 671     ))
 672   where
 673     set_of_binders = mkVarSet binders
 674     binders        = case bind of
 675                         NonRec binder rhs -> [binder]
 676                         Rec pairs         -> map fst pairs
 677
 678     mk_binding bind_lvs bind_cafs binder rhs
 679         = (binder,  LetBound  NotTopLevelBound  -- Not top level
 680                         live_vars (predictArity rhs)
 681            )
 682         where
 683            live_vars = if let_no_escape then
 684                             (extendVarSet bind_lvs binder, bind_cafs)
 685                        else
 686                             (unitVarSet binder, emptyVarSet)
 687
 688     vars_bind :: FreeVarsInfo           -- Free var info for body of binding
 689               -> CoreBind
 690               -> LneM (StgBinding,
 691                        FreeVarsInfo,
 692                        EscVarsSet,        -- free vars; escapee vars
 693                        StgLiveVars,       -- vars live in binding
 694                        IdSet,             -- CAFs live in binding
 695                        [(Id, HowBound)])  -- extension to environment
 696
 697
 698     vars_bind body_fvs (NonRec binder rhs)
 699       = coreToStgRhs body_fvs NotTopLevel (binder,rhs)
 700                                 `thenLne` \ (rhs2, bind_fvs, escs) ->
 701
 702         freeVarsToLiveVars bind_fvs `thenLne` \ (bind_lvs, bind_cafs) ->
 703         let
 704             env_ext_item = mk_binding bind_lvs bind_cafs binder rhs
 705         in
 706         returnLne (StgNonRec (SRTEntries bind_cafs) binder rhs2,
 707                         bind_fvs, escs, bind_lvs, bind_cafs, [env_ext_item])
 708
 709
 710     vars_bind body_fvs (Rec pairs)
 711       = fixLne (\ ~(_, rec_rhs_fvs, _, bind_lvs, bind_cafs, _) ->
 712            let
 713                 rec_scope_fvs = unionFVInfo body_fvs rec_rhs_fvs
 714                 binders = map fst pairs
 715                 env_ext = [ mk_binding bind_lvs bind_cafs b rhs
 716                           | (b,rhs) <- pairs ]
 717            in
 718            extendVarEnvLne env_ext (
 719               mapAndUnzip3Lne (coreToStgRhs rec_scope_fvs NotTopLevel) pairs
 720                                         `thenLne` \ (rhss2, fvss, escss) ->
 721               let
 722                         bind_fvs = unionFVInfos fvss
 723                         escs     = unionVarSets escss
 724               in
 725               freeVarsToLiveVars (binders `minusFVBinders` bind_fvs)
 726                                         `thenLne` \ (bind_lvs, bind_cafs) ->
 727
 728               returnLne (StgRec (SRTEntries bind_cafs) (binders `zip` rhss2),
 729                                 bind_fvs, escs, bind_lvs, bind_cafs, env_ext)
 730            )
 731         )
 732
 733 is_join_var :: Id -> Bool
 734 -- A hack (used only for compiler debuggging) to tell if
 735 -- a variable started life as a join point ($j)
 736 is_join_var j = occNameUserString (getOccName j) == "$j"
 737 \end{code}
 738
 739 %************************************************************************
 740 %*                                                                      *
 741 \subsection{Arity prediction}
 742 %*                                                                      *
 743 %************************************************************************
 744
 745 To avoid yet another knot, we predict the arity of each function from
 746 its Core form, based on the number of visible top-level lambdas.
 747 It should be the same as the arity of the STG RHS!
 748
 749 \begin{code}
 750 predictArity :: CoreExpr -> Int
 751 predictArity (Lam x e)
 752   | isTyVar x = predictArity e
 753   | otherwise = 1 + predictArity e
 754 predictArity (Note _ e)
 755   -- Ignore coercions.   Top level sccs are removed by the final
 756   -- profiling pass, so we ignore those too.
 757   = predictArity e
 758 predictArity _ = 0
 759 \end{code}
 760
 761
 762 %************************************************************************
 763 %*                                                                      *
 764 \subsection[LNE-monad]{A little monad for this let-no-escaping pass}
 765 %*                                                                      *
 766 %************************************************************************
 767
 768 There's a lot of stuff to pass around, so we use this @LneM@ monad to
 769 help.  All the stuff here is only passed *down*.
 770
 771 \begin{code}
 772 type LneM a =  IdEnv HowBound
 773             -> (StgLiveVars,    -- vars live in continuation
 774                 IdSet)          -- cafs live in continuation
 775             -> a
 776
 777 data HowBound
 778   = ImportBound
 779   | CaseBound
 780   | LambdaBound
 781   | LetBound
 782         TopLevelCafInfo
 783         (StgLiveVars, IdSet) -- (Live vars, Live CAFs)... see notes below
 784         Arity      -- its arity (local Ids don't have arity info at this point)
 785
 786 isLetBound (LetBound _ _ _) = True
 787 isLetBound other            = False
 788 \end{code}
 789
 790 For a let(rec)-bound variable, x, we record StgLiveVars, the set of
 791 variables that are live if x is live.  For "normal" variables that is
 792 just x alone.  If x is a let-no-escaped variable then x is represented
 793 by a code pointer and a stack pointer (well, one for each stack).  So
 794 all of the variables needed in the execution of x are live if x is,
 795 and are therefore recorded in the LetBound constructor; x itself
 796 *is* included.
 797
 798 The set of live variables is guaranteed ot have no further let-no-escaped
 799 variables in it.
 800
 801 The std monad functions:
 802 \begin{code}
 803 initLne :: IdEnv HowBound -> LneM a -> a
 804 initLne env m = m env emptyLVS
 805
 806 emptyLVS = (emptyVarSet,emptyVarSet)
 807
 808 {-# INLINE thenLne #-}
 809 {-# INLINE returnLne #-}
 810
 811 returnLne :: a -> LneM a
 812 returnLne e env lvs_cont = e
 813
 814 thenLne :: LneM a -> (a -> LneM b) -> LneM b
 815 thenLne m k env lvs_cont
 816   = k (m env lvs_cont) env lvs_cont
 817
 818 mapLne  :: (a -> LneM b)   -> [a] -> LneM [b]
 819 mapLne f [] = returnLne []
 820 mapLne f (x:xs)
 821   = f x         `thenLne` \ r  ->
 822     mapLne f xs `thenLne` \ rs ->
 823     returnLne (r:rs)
 824
 825 mapAndUnzipLne  :: (a -> LneM (b,c))   -> [a] -> LneM ([b],[c])
 826
 827 mapAndUnzipLne f [] = returnLne ([],[])
 828 mapAndUnzipLne f (x:xs)
 829   = f x                 `thenLne` \ (r1,  r2)  ->
 830     mapAndUnzipLne f xs `thenLne` \ (rs1, rs2) ->
 831     returnLne (r1:rs1, r2:rs2)
 832
 833 mapAndUnzip3Lne :: (a -> LneM (b,c,d)) -> [a] -> LneM ([b],[c],[d])
 834
 835 mapAndUnzip3Lne f []    = returnLne ([],[],[])
 836 mapAndUnzip3Lne f (x:xs)
 837   = f x                  `thenLne` \ (r1,  r2,  r3)  ->
 838     mapAndUnzip3Lne f xs `thenLne` \ (rs1, rs2, rs3) ->
 839     returnLne (r1:rs1, r2:rs2, r3:rs3)
 840
 841 fixLne :: (a -> LneM a) -> LneM a
 842 fixLne expr env lvs_cont
 843   = result
 844   where
 845     result = expr result env lvs_cont
 846 \end{code}
 847
 848 Functions specific to this monad:
 849
 850 \begin{code}
 851 getVarsLiveInCont :: LneM (StgLiveVars, IdSet)
 852 getVarsLiveInCont env lvs_cont = lvs_cont
 853
 854 setVarsLiveInCont :: (StgLiveVars,IdSet) -> LneM a -> LneM a
 855 setVarsLiveInCont new_lvs_cont expr env lvs_cont
 856   = expr env new_lvs_cont
 857
 858 extendVarEnvLne :: [(Id, HowBound)] -> LneM a -> LneM a
 859 extendVarEnvLne ids_w_howbound expr env lvs_cont
 860   = expr (extendVarEnvList env ids_w_howbound) lvs_cont
 861
 862 lookupVarLne :: Id -> LneM HowBound
 863 lookupVarLne v env lvs_cont
 864   = returnLne (
 865       case (lookupVarEnv env v) of
 866         Just xx -> xx
 867         Nothing -> ImportBound
 868     ) env lvs_cont
 869
 870 -- The result of lookupLiveVarsForSet, a set of live variables, is
 871 -- only ever tacked onto a decorated expression. It is never used as
 872 -- the basis of a control decision, which might give a black hole.
 873
 874 freeVarsToLiveVars :: FreeVarsInfo -> LneM (StgLiveVars, IdSet)
 875 freeVarsToLiveVars fvs env live_in_cont
 876   = returnLne (lvs, cafs) env live_in_cont
 877   where
 878     (lvs_cont, cafs_cont) = live_in_cont -- not a strict pattern match!
 879     (local, global) = partition isLocalId (allFVs fvs)
 880
 881     (lvs_from_fvs, caf_extras) = unzip (map do_one local)
 882
 883     lvs = unionVarSets lvs_from_fvs
 884                 `unionVarSet` lvs_cont
 885
 886     cafs = mkVarSet (filter is_caf_one global)
 887                 `unionVarSet` (unionVarSets caf_extras)
 888                 `unionVarSet` cafs_cont
 889
 890     do_one v
 891       = case (lookupVarEnv env v) of
 892               Just (LetBound _ (lvs,cafs) _) -> (extendVarSet lvs v, cafs)
 893               Just _                         -> (unitVarSet v, emptyVarSet)
 894               Nothing -> pprPanic "lookupLiveVarsForSet/do_one:" (ppr v)
 895
 896     is_caf_one v
 897          = case lookupVarEnv env v of
 898                 Just (LetBound TopLevelHasCafs (lvs,_) _) ->
 899                     ASSERT( isEmptyVarSet lvs ) True
 900                 Just (LetBound _ _ _) -> False
 901                 _otherwise          -> mayHaveCafRefs (idCafInfo v)
 902 \end{code}
 903
 904 %************************************************************************
 905 %*                                                                      *
 906 \subsection[Free-var info]{Free variable information}
 907 %*                                                                      *
 908 %************************************************************************
 909
 910 \begin{code}
 911 type FreeVarsInfo = VarEnv (Var, TopLevelCafInfo, StgBinderInfo)
 912         -- If f is mapped to noBinderInfo, that means
 913         -- that f *is* mentioned (else it wouldn't be in the
 914         -- IdEnv at all), but perhaps in an unsaturated applications.
 915         --
 916         -- All case/lambda-bound things are also mapped to
 917         -- noBinderInfo, since we aren't interested in their
 918         -- occurence info.
 919         --
 920         -- For ILX we track free var info for type variables too;
 921         -- hence VarEnv not IdEnv
 922
 923 data TopLevelCafInfo
 924   = NotTopLevelBound
 925   | TopLevelNoCafs
 926   | TopLevelHasCafs
 927   deriving Eq
 928
 929 type EscVarsSet = IdSet
 930 \end{code}
 931
 932 \begin{code}
 933 emptyFVInfo :: FreeVarsInfo
 934 emptyFVInfo = emptyVarEnv
 935
 936 singletonFVInfo :: Id -> HowBound -> StgBinderInfo -> FreeVarsInfo
 937 singletonFVInfo id ImportBound info
 938    | mayHaveCafRefs (idCafInfo id) = unitVarEnv id (id, TopLevelHasCafs, info)
 939    | otherwise                     = emptyVarEnv
 940 singletonFVInfo id (LetBound top_level _ _) info
 941    = unitVarEnv id (id, top_level, info)
 942 singletonFVInfo id other info
 943    = unitVarEnv id (id, NotTopLevelBound, info)
 944
 945 tyvarFVInfo :: TyVarSet -> FreeVarsInfo
 946 tyvarFVInfo tvs = foldVarSet add emptyFVInfo tvs
 947         where
 948           add tv fvs = extendVarEnv fvs tv (tv, NotTopLevelBound, noBinderInfo)
 949
 950 unionFVInfo :: FreeVarsInfo -> FreeVarsInfo -> FreeVarsInfo
 951 unionFVInfo fv1 fv2 = plusVarEnv_C plusFVInfo fv1 fv2
 952
 953 unionFVInfos :: [FreeVarsInfo] -> FreeVarsInfo
 954 unionFVInfos fvs = foldr unionFVInfo emptyFVInfo fvs
 955
 956 minusFVBinders :: [Id] -> FreeVarsInfo -> FreeVarsInfo
 957 minusFVBinders vs fv = foldr minusFVBinder fv vs
 958
 959 minusFVBinder :: Id -> FreeVarsInfo -> FreeVarsInfo
 960 minusFVBinder v fv | isId v && opt_KeepStgTypes
 961                    = (fv `delVarEnv` v) `unionFVInfo`
 962                      tyvarFVInfo (tyVarsOfType (idType v))
 963                    | otherwise = fv `delVarEnv` v
 964         -- When removing a binder, remember to add its type variables
 965         -- c.f. CoreFVs.delBinderFV
 966
 967 elementOfFVInfo :: Id -> FreeVarsInfo -> Bool
 968 elementOfFVInfo id fvs = maybeToBool (lookupVarEnv fvs id)
 969
 970 lookupFVInfo :: FreeVarsInfo -> Id -> StgBinderInfo
 971 -- Find how the given Id is used.
 972 -- Externally visible things may be used any old how
 973 lookupFVInfo fvs id
 974   | isExternallyVisibleName (idName id) = noBinderInfo
 975   | otherwise = case lookupVarEnv fvs id of
 976                         Nothing         -> noBinderInfo
 977                         Just (_,_,info) -> info
 978
 979 allFVs :: FreeVarsInfo -> [Id]  -- Non-top-level things only
 980 allFVs fvs = [id | (id,_,_) <- rngVarEnv fvs]
 981
 982 getFVs :: FreeVarsInfo -> [Id]  -- Non-top-level things only
 983 getFVs fvs = [id | (id,NotTopLevelBound,_) <- rngVarEnv fvs]
 984
 985 getFVSet :: FreeVarsInfo -> IdSet
 986 getFVSet fvs = mkVarSet (getFVs fvs)
 987
 988 plusFVInfo (id1,top1,info1) (id2,top2,info2)
 989   = ASSERT (id1 == id2 && top1 == top2)
 990     (id1, top1, combineStgBinderInfo info1 info2)
 991 \end{code}
 992
 993 Misc.
 994 \begin{code}
 995 filterStgBinders :: [Var] -> [Var]
 996 filterStgBinders bndrs
 997   | opt_KeepStgTypes = bndrs
 998   | otherwise        = filter isId bndrs
 999 \end{code}
1000
1001
1002 \begin{code}
1003         -- Ignore all notes except SCC
1004 myCollectBinders expr
1005   = go [] expr
1006   where
1007     go bs (Lam b e)          = go (b:bs) e
1008     go bs e@(Note (SCC _) _) = (reverse bs, e)
1009     go bs (Note _ e)         = go bs e
1010     go bs e                  = (reverse bs, e)
1011
1012 myCollectArgs :: CoreExpr -> (Id, [CoreArg])
1013         -- We assume that we only have variables
1014         -- in the function position by now
1015 myCollectArgs expr
1016   = go expr []
1017   where
1018     go (Var v)          as = (v, as)
1019     go (App f a) as        = go f (a:as)
1020     go (Note (SCC _) e) as = pprPanic "CoreToStg.myCollectArgs" (ppr expr)
1021     go (Note n e)       as = go e as
1022     go _                as = pprPanic "CoreToStg.myCollectArgs" (ppr expr)
1023 \end{code}
1024
1025 %************************************************************************
1026 %*                                                                      *
1027 \subsection{Figuring out CafInfo for an expression}
1028 %*                                                                      *
1029 %************************************************************************
1030
1031 hasCafRefs decides whether a top-level closure can point into the dynamic heap.
1032 We mark such things as `MayHaveCafRefs' because this information is
1033 used to decide whether a particular closure needs to be referenced
1034 in an SRT or not.
1035
1036 There are two reasons for setting MayHaveCafRefs:
1037         a) The RHS is a CAF: a top-level updatable thunk.
1038         b) The RHS refers to something that MayHaveCafRefs
1039
1040 Possible improvement: In an effort to keep the number of CAFs (and
1041 hence the size of the SRTs) down, we could also look at the expression and
1042 decide whether it requires a small bounded amount of heap, so we can ignore
1043 it as a CAF.  In these cases however, we would need to use an additional
1044 CAF list to keep track of non-collectable CAFs.
1045
1046 \begin{code}
1047 hasCafRefs  :: IdEnv HowBound -> CoreExpr -> CafInfo
1048 -- Only called for the RHS of top-level lets
1049 hasCafRefss :: IdEnv HowBound -> [CoreExpr] -> CafInfo
1050         -- predicate returns True for a given Id if we look at this Id when
1051         -- calculating the result.  Used to *avoid* looking at the CafInfo
1052         -- field for an Id that is part of the current recursive group.
1053
1054 hasCafRefs p expr
1055   | isCAF expr || isFastTrue (cafRefs p expr) =  MayHaveCafRefs
1056   | otherwise = NoCafRefs
1057
1058         -- used for recursive groups.  The whole group is set to
1059         -- "MayHaveCafRefs" if at least one of the group is a CAF or
1060         -- refers to any CAFs.
1061 hasCafRefss p exprs
1062   | any isCAF exprs || isFastTrue (cafRefss p exprs) = MayHaveCafRefs
1063   | otherwise = NoCafRefs
1064
1065 -- cafRefs compiles to beautiful code :)
1066
1067 cafRefs p (Var id)
1068   | isLocalId id = fastBool False
1069   | otherwise =
1070       case lookupVarEnv p id of
1071         Just (LetBound TopLevelHasCafs _ _) -> fastBool True
1072         Just (LetBound _ _ _) -> fastBool False
1073         Nothing -> fastBool (cgMayHaveCafRefs (idCgInfo id)) --  imported Ids
1074
1075 cafRefs p (Lit l)            = fastBool False
1076 cafRefs p (App f a)          = fastOr (cafRefs p f) (cafRefs p) a
1077 cafRefs p (Lam x e)          = cafRefs p e
1078 cafRefs p (Let b e)          = fastOr (cafRefss p (rhssOfBind b)) (cafRefs p) e
1079 cafRefs p (Case e bndr alts) = fastOr (cafRefs p e)
1080                                 (cafRefss p) (rhssOfAlts alts)
1081 cafRefs p (Note n e)         = cafRefs p e
1082 cafRefs p (Type t)           = fastBool False
1083
1084 cafRefss p []     = fastBool False
1085 cafRefss p (e:es) = fastOr (cafRefs p e) (cafRefss p) es
1086
1087 -- hack for lazy-or over FastBool.
1088 fastOr a f x = fastBool (isFastTrue a || isFastTrue (f x))
1089
1090 isCAF :: CoreExpr -> Bool
1091 -- Only called for the RHS of top-level lets
1092 isCAF e = not (rhsIsNonUpd e)
1093   {- ToDo: check type for onceness, i.e. non-updatable thunks? -}
1094
1095
1096 rhsIsNonUpd :: CoreExpr -> Bool
1097   -- True => Value-lambda, constructor, PAP
1098   -- This is a bit like CoreUtils.exprIsValue, with the following differences:
1099   --    a) scc "foo" (\x -> ...) is updatable (so we catch the right SCC)
1100   --
1101   --    b) (C x xs), where C is a contructors is updatable if the application is
1102   --       dynamic: see isDynConApp
1103   --
1104   --    c) don't look through unfolding of f in (f x).  I'm suspicious of this one
1105
1106 rhsIsNonUpd (Lam b e)          = isId b || rhsIsNonUpd e
1107 rhsIsNonUpd (Note (SCC _) e)   = False
1108 rhsIsNonUpd (Note _ e)         = rhsIsNonUpd e
1109 rhsIsNonUpd other_expr
1110   = go other_expr 0 []
1111   where
1112     go (Var f) n_args args = idAppIsNonUpd f n_args args
1113
1114     go (App f a) n_args args
1115         | isTypeArg a = go f n_args args
1116         | otherwise   = go f (n_args + 1) (a:args)
1117
1118     go (Note (SCC _) f) n_args args = False
1119     go (Note _ f) n_args args       = go f n_args args
1120
1121     go other n_args args = False
1122
1123 idAppIsNonUpd :: Id -> Int -> [CoreExpr] -> Bool
1124 idAppIsNonUpd id n_val_args args
1125   | Just con <- isDataConId_maybe id = not (isDynConApp con args)
1126   | otherwise                        = n_val_args < idArity id
1127
1128 isDynConApp :: DataCon -> [CoreExpr] -> Bool
1129 isDynConApp con args = isDllName (dataConName con) || any isDynArg args
1130 -- Top-level constructor applications can usually be allocated
1131 -- statically, but they can't if
1132 --      a) the constructor, or any of the arguments, come from another DLL
1133 --      b) any of the arguments are LitLits
1134 -- (because we can't refer to static labels in other DLLs).
1135 -- If this happens we simply make the RHS into an updatable thunk,
1136 -- and 'exectute' it rather than allocating it statically.
1137 -- All this should match the decision in (see CoreToStg.coreToStgRhs)
1138
1139
1140 isDynArg :: CoreExpr -> Bool
1141 isDynArg (Var v)    = isDllName (idName v)
1142 isDynArg (Note _ e) = isDynArg e
1143 isDynArg (Lit lit)  = isLitLitLit lit
1144 isDynArg (App e _)  = isDynArg e        -- must be a type app
1145 isDynArg (Lam _ e)  = isDynArg e        -- must be a type lam
1146 \end{code}