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