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