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