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