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