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