CoreToStg.lhs 37.3 KB
Newer Older
1
%
2
% (c) The GRASP/AQUA Project, Glasgow University, 1993-1998
3
%
4
\section[CoreToStg]{Converts Core to STG Syntax}
5

6
7
And, as we have the info in hand, we may convert some lets to
let-no-escapes.
8
9

\begin{code}
10
module CoreToStg ( coreToStg, coreExprToStg ) where
11

12
#include "HsVersions.h"
13

14
import CoreSyn
15
import CoreUtils	( rhsIsStatic, manifestArity, exprType, findDefault )
16
import StgSyn
17

18
import Type
19
import TyCon		( isAlgTyCon )
20
import Id
21
import Var		( Var, globalIdDetails, idType )
22
import TyCon		( isUnboxedTupleTyCon, isPrimTyCon, isFunTyCon, isHiBootTyCon )
23
24
25
26
import IdInfo
import DataCon
import CostCentre	( noCCS )
import VarSet
27
import VarEnv
28
import Maybes		( maybeToBool )
29
import Name		( getOccName, isExternalName, nameOccName )
30
import OccName		( occNameString, occNameFS )
31
import BasicTypes       ( Arity )
32
import StaticFlags	( opt_RuntimeTypes )
Simon Marlow's avatar
Simon Marlow committed
33
import PackageConfig	( PackageId )
34
import Outputable
35

36
infixr 9 `thenLne`
37
38
\end{code}

39
40
%************************************************************************
%*									*
41
\subsection[live-vs-free-doc]{Documentation}
42
43
44
%*									*
%************************************************************************

45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
(There is other relevant documentation in codeGen/CgLetNoEscape.)

The actual Stg datatype is decorated with {\em live variable}
information, as well as {\em free variable} information.  The two are
{\em not} the same.  Liveness is an operational property rather than a
semantic one.  A variable is live at a particular execution point if
it can be referred to {\em directly} again.  In particular, a dead
variable's stack slot (if it has one):
\begin{enumerate}
\item
should be stubbed to avoid space leaks, and
\item
may be reused for something else.
\end{enumerate}

There ought to be a better way to say this.  Here are some examples:
\begin{verbatim}
	let v = [q] \[x] -> e
	in
	...v...	 (but no q's)
\end{verbatim}

Just after the `in', v is live, but q is dead.	If the whole of that
let expression was enclosed in a case expression, thus:
\begin{verbatim}
	case (let v = [q] \[x] -> e in ...v...) of
		alts[...q...]
\end{verbatim}
(ie @alts@ mention @q@), then @q@ is live even after the `in'; because
we'll return later to the @alts@ and need it.

Let-no-escapes make this a bit more interesting:
\begin{verbatim}
	let-no-escape v = [q] \ [x] -> e
	in
	...v...
\end{verbatim}
Here, @q@ is still live at the `in', because @v@ is represented not by
a closure but by the current stack state.  In other words, if @v@ is
live then so is @q@.  Furthermore, if @e@ mentions an enclosing
let-no-escaped variable, then {\em its} free variables are also live
if @v@ is.
87

88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
%************************************************************************
%*									*
\subsection[caf-info]{Collecting live CAF info}
%*									*
%************************************************************************

In this pass we also collect information on which CAFs are live for 
constructing SRTs (see SRT.lhs).  

A top-level Id has CafInfo, which is

	- MayHaveCafRefs, if it may refer indirectly to
	  one or more CAFs, or
	- NoCafRefs if it definitely doesn't

103
The CafInfo has already been calculated during the CoreTidy pass.
104
105
106
107
108
109
110
111
112
113

During CoreToStg, we then pin onto each binding and case expression, a
list of Ids which represents the "live" CAFs at that point.  The meaning
of "live" here is the same as for live variables, see above (which is
why it's convenient to collect CAF information here rather than elsewhere).

The later SRT pass takes these lists of Ids and uses them to construct
the actual nested SRTs, and replaces the lists of Ids with (offset,length)
pairs.

114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132

Interaction of let-no-escape with SRTs   [Sept 01]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider

	let-no-escape x = ...caf1...caf2...
	in
	...x...x...x...

where caf1,caf2 are CAFs.  Since x doesn't have a closure, we 
build SRTs just as if x's defn was inlined at each call site, and
that means that x's CAF refs get duplicated in the overall SRT.

This is unlike ordinary lets, in which the CAF refs are not duplicated.

We could fix this loss of (static) sharing by making a sort of pseudo-closure
for x, solely to put in the SRTs lower down.


133
134
%************************************************************************
%*									*
135
\subsection[binds-StgVarInfo]{Setting variable info: top-level, binds, RHSs}
136
137
138
139
%*									*
%************************************************************************

\begin{code}
Simon Marlow's avatar
Simon Marlow committed
140
141
coreToStg :: PackageId -> [CoreBind] -> IO [StgBinding]
coreToStg this_pkg pgm
142
  = return pgm'
Simon Marlow's avatar
Simon Marlow committed
143
  where (_, _, pgm') = coreTopBindsToStg this_pkg emptyVarEnv pgm
144
145
146

coreExprToStg :: CoreExpr -> StgExpr
coreExprToStg expr 
147
148
149
150
  = new_expr where (new_expr,_,_) = initLne emptyVarEnv (coreToStgExpr expr)


coreTopBindsToStg
Simon Marlow's avatar
Simon Marlow committed
151
    :: PackageId
152
    -> IdEnv HowBound		-- environment for the bindings
153
154
155
    -> [CoreBind]
    -> (IdEnv HowBound, FreeVarsInfo, [StgBinding])

Simon Marlow's avatar
Simon Marlow committed
156
157
coreTopBindsToStg this_pkg env [] = (env, emptyFVInfo, [])
coreTopBindsToStg this_pkg env (b:bs)
158
  = (env2, fvs2, b':bs')
159
160
  where
	-- env accumulates down the list of binds, fvs accumulates upwards
Simon Marlow's avatar
Simon Marlow committed
161
162
	(env1, fvs2, b' ) = coreTopBindToStg this_pkg env fvs1 b
  	(env2, fvs1, bs') = coreTopBindsToStg this_pkg env1 bs
163
164
165


coreTopBindToStg
Simon Marlow's avatar
Simon Marlow committed
166
	:: PackageId
167
	-> IdEnv HowBound
168
169
	-> FreeVarsInfo		-- Info about the body
	-> CoreBind
170
	-> (IdEnv HowBound, FreeVarsInfo, StgBinding)
171

Simon Marlow's avatar
Simon Marlow committed
172
coreTopBindToStg this_pkg env body_fvs (NonRec id rhs)
173
  = let 
174
	env' 	  = extendVarEnv env id how_bound
175
	how_bound = LetBound TopLet $! manifestArity rhs
176

177
        (stg_rhs, fvs') = 
178
	    initLne env (
Simon Marlow's avatar
Simon Marlow committed
179
              coreToTopStgRhs this_pkg body_fvs (id,rhs)	`thenLne` \ (stg_rhs, fvs') ->
180
	      returnLne (stg_rhs, fvs')
181
182
           )
	
183
	bind = StgNonRec id stg_rhs
184
    in
185
    ASSERT2(manifestArity rhs == stgRhsArity stg_rhs, ppr id $$ (ptext SLIT("rhs:")) <+> ppr rhs $$ (ptext SLIT("stg_rhs:"))<+> ppr stg_rhs $$ (ptext SLIT("Manifest:")) <+> (ppr $ manifestArity rhs) $$ (ptext SLIT("STG:")) <+>(ppr $ stgRhsArity stg_rhs) )
186
    ASSERT2(consistentCafInfo id bind, ppr id)
187
188
189
--    WARN(not (consistent caf_info bind), ppr id <+> ppr cafs <+> ppCafInfo caf_info)
    (env', fvs' `unionFVInfo` body_fvs, bind)

Simon Marlow's avatar
Simon Marlow committed
190
coreTopBindToStg this_pkg env body_fvs (Rec pairs)
191
192
193
  = let 
	(binders, rhss) = unzip pairs

194
	extra_env' = [ (b, LetBound TopLet $! manifestArity rhs)
195
		     | (b, rhs) <- pairs ]
196
	env' = extendVarEnvList env extra_env'
197

198
        (stg_rhss, fvs')
199
	  = initLne env' (
Simon Marlow's avatar
Simon Marlow committed
200
	       mapAndUnzipLne (coreToTopStgRhs this_pkg body_fvs) pairs
201
						`thenLne` \ (stg_rhss, fvss') ->
202
	       let fvs' = unionFVInfos fvss' in
203
	       returnLne (stg_rhss, fvs')
204
205
           )

206
	bind = StgRec (zip binders stg_rhss)
207
    in
208
    ASSERT2(and [manifestArity rhs == stgRhsArity stg_rhs | (rhs,stg_rhs) <- rhss `zip` stg_rhss], ppr binders)
209
    ASSERT2(consistentCafInfo (head binders) bind, ppr binders)
210
211
    (env', fvs' `unionFVInfo` body_fvs, bind)

212
213
214
215
216
217
218
#ifdef DEBUG
-- Assertion helper: this checks that the CafInfo on the Id matches
-- what CoreToStg has figured out about the binding's SRT.  The
-- CafInfo will be exact in all cases except when CorePrep has
-- floated out a binding, in which case it will be approximate.
consistentCafInfo id bind
  | occNameFS (nameOccName (idName id)) == FSLIT("sat")
219
  = safe
220
  | otherwise
221
  = WARN (not exact, ppr id) safe
222
  where
223
224
	safe  = id_marked_caffy || not binding_is_caffy
	exact = id_marked_caffy == binding_is_caffy
225
226
227
	id_marked_caffy  = mayHaveCafRefs (idCafInfo id)
	binding_is_caffy = stgBindHasCafRefs bind
#endif
228
229
230
\end{code}

\begin{code}
231
coreToTopStgRhs
Simon Marlow's avatar
Simon Marlow committed
232
	:: PackageId
233
	-> FreeVarsInfo		-- Free var info for the scope of the binding
234
	-> (Id,CoreExpr)
235
	-> LneM (StgRhs, FreeVarsInfo)
236

Simon Marlow's avatar
Simon Marlow committed
237
coreToTopStgRhs this_pkg scope_fv_info (bndr, rhs)
238
  = coreToStgExpr rhs 		`thenLne` \ (new_rhs, rhs_fvs, _) ->
239
    freeVarsToLiveVars rhs_fvs	`thenLne` \ lv_info ->
240
    returnLne (mkTopStgRhs is_static rhs_fvs (mkSRT lv_info) bndr_info new_rhs, rhs_fvs)
241
  where
242
    bndr_info = lookupFVInfo scope_fv_info bndr
Simon Marlow's avatar
Simon Marlow committed
243
    is_static = rhsIsStatic this_pkg rhs
244

245
mkTopStgRhs :: Bool -> FreeVarsInfo -> SRT -> StgBinderInfo -> StgExpr
246
	-> StgRhs
247

248
249
250
mkTopStgRhs is_static rhs_fvs srt binder_info (StgLam _ bndrs body)
  = ASSERT( is_static )
    StgRhsClosure noCCS binder_info
251
252
		  (getFVs rhs_fvs)		 
		  ReEntrant
253
		  srt
254
		  bndrs body
255
	
256
257
mkTopStgRhs is_static rhs_fvs srt binder_info (StgConApp con args)
  | is_static	 -- StgConApps can be updatable (see isCrossDllConApp)
258
259
  = StgRhsCon noCCS con args

260
mkTopStgRhs is_static rhs_fvs srt binder_info rhs
261
  = ASSERT2( not is_static, ppr rhs )
262
    StgRhsClosure noCCS binder_info
263
		  (getFVs rhs_fvs)		 
264
	          Updatable
265
		  srt
266
267
	          [] rhs
\end{code}
268
269
270
271
272


-- ---------------------------------------------------------------------------
-- Expressions
-- ---------------------------------------------------------------------------
273

274
\begin{code}
275
276
277
278
279
280
281
282
283
coreToStgExpr
  	:: CoreExpr
	-> LneM (StgExpr,	-- Decorated STG expr
		 FreeVarsInfo,	-- Its free vars (NB free, not live)
		 EscVarsSet)	-- Its escapees, a subset of its free vars;
				-- also a subset of the domain of the envt
				-- because we are only interested in the escapees
				-- for vars which might be turned into
				-- let-no-escaped ones.
284
285
\end{code}

286
287
288
289
290
The second and third components can be derived in a simple bottom up pass, not
dependent on any decisions about which variables will be let-no-escaped or
not.  The first component, that is, the decorated expression, may then depend
on these components, but it in turn is not scrutinised as the basis for any
decisions.  Hence no black holes.
291
292

\begin{code}
293
294
coreToStgExpr (Lit l) = returnLne (StgLit l, emptyFVInfo, emptyVarSet)
coreToStgExpr (Var v) = coreToStgApp Nothing v []
sof's avatar
sof committed
295

296
coreToStgExpr expr@(App _ _)
297
298
299
  = coreToStgApp Nothing f args
  where
    (f, args) = myCollectArgs expr
300

301
coreToStgExpr expr@(Lam _ _)
302
303
  = let
	(args, body) = myCollectBinders expr 
304
	args'	     = filterStgBinders args
305
306
307
308
    in
    extendVarEnvLne [ (a, LambdaBound) | a <- args' ] $
    coreToStgExpr body  `thenLne` \ (body, body_fvs, body_escs) ->
    let
309
	fvs		= args' `minusFVBinders` body_fvs
310
	escs		= body_escs `delVarSetList` args'
311
312
	result_expr | null args' = body
		    | otherwise  = StgLam (exprType expr) args' body
313
    in
314
    returnLne (result_expr, fvs, escs)
315
316
317
318
319

coreToStgExpr (Note (SCC cc) expr)
  = coreToStgExpr expr		`thenLne` ( \ (expr2, fvs, escs) ->
    returnLne (StgSCC cc expr2, fvs, escs) )

andy@galois.com's avatar
andy@galois.com committed
320
321
322
323
324
325
326
327
328
coreToStgExpr (Note (TickBox m n) expr)
  = coreToStgExpr expr         `thenLne` ( \ (expr2, fvs, escs) ->
    returnLne (StgTick m n expr2, fvs, escs) )

-- BinaryTickBox'es are are removed by the CorePrep pass.

coreToStgExpr expr@(Note (BinaryTickBox m t e) _)	
  = pprPanic "coreToStgExpr: " (ppr expr)

329
330
coreToStgExpr (Note other_note expr)
  = coreToStgExpr expr
331

332
333
334
coreToStgExpr (Cast expr co)
  = coreToStgExpr expr

335
336
-- Cases require a little more real work.

337
coreToStgExpr (Case scrut bndr _ alts)
338
339
  = extendVarEnvLne [(bndr, LambdaBound)]	(
	 mapAndUnzip3Lne vars_alt alts	`thenLne` \ (alts2, fvs_s, escs_s) ->
340
	 returnLne ( alts2,
341
342
343
		     unionFVInfos fvs_s,
		     unionVarSets escs_s )
    )			   		`thenLne` \ (alts2, alts_fvs, alts_escs) ->
344
    let
345
	-- Determine whether the default binder is dead or not
346
347
	-- This helps the code generator to avoid generating an assignment
	-- for the case binder (is extremely rare cases) ToDo: remove.
348
349
	bndr' | bndr `elementOfFVInfo` alts_fvs = bndr
	      | otherwise			= bndr `setIdOccInfo` IAmDead
350
351
352
353

	-- Don't consider the default binder as being 'live in alts',
	-- since this is from the point of view of the case expr, where
	-- the default binder is not free.
354
355
	alts_fvs_wo_bndr  = bndr `minusFVBinder` alts_fvs
	alts_escs_wo_bndr = alts_escs `delVarSet` bndr
356
    in
357
358
359
360
361
362

    freeVarsToLiveVars alts_fvs_wo_bndr		`thenLne` \ alts_lv_info ->

	-- We tell the scrutinee that everything 
	-- live in the alts is live in it, too.
    setVarsLiveInCont alts_lv_info (
363
	coreToStgExpr scrut	  `thenLne` \ (scrut2, scrut_fvs, scrut_escs) ->
364
365
        freeVarsToLiveVars scrut_fvs `thenLne` \ scrut_lv_info ->
	returnLne (scrut2, scrut_fvs, scrut_escs, scrut_lv_info)
366
      )    
367
		`thenLne` \ (scrut2, scrut_fvs, scrut_escs, scrut_lv_info) ->
368

369
    returnLne (
370
371
372
373
      StgCase scrut2 (getLiveVars scrut_lv_info)
		     (getLiveVars alts_lv_info)
		     bndr'
		     (mkSRT alts_lv_info)
374
		     (mkStgAltType (idType bndr) alts)
375
376
377
		     alts2,
      scrut_fvs `unionFVInfo` alts_fvs_wo_bndr,
      alts_escs_wo_bndr `unionVarSet` getFVSet scrut_fvs
378
379
380
		-- You might think we should have scrut_escs, not 
		-- (getFVSet scrut_fvs), but actually we can't call, and 
		-- then return from, a let-no-escape thing.
381
382
      )
  where
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
    vars_alt (con, binders, rhs)
      = let    	-- Remove type variables
	    binders' = filterStgBinders binders
        in	
        extendVarEnvLne [(b, LambdaBound) | b <- binders']	$
        coreToStgExpr rhs	`thenLne` \ (rhs2, rhs_fvs, rhs_escs) ->
        let
	    	-- Records whether each param is used in the RHS
	    good_use_mask = [ b `elementOfFVInfo` rhs_fvs | b <- binders' ]
        in
        returnLne ( (con, binders', good_use_mask, rhs2),
		    binders' `minusFVBinders` rhs_fvs,
		    rhs_escs `delVarSetList` binders' )
    		-- ToDo: remove the delVarSet;
    		-- since escs won't include any of these binders
398
399
\end{code}

400
401
Lets not only take quite a bit of work, but this is where we convert
then to let-no-escapes, if we wish.
402

403
(Meanwhile, we don't expect to see let-no-escapes...)
404
\begin{code}
405
406
407
408
coreToStgExpr (Let bind body)
  = fixLne (\ ~(_, _, _, no_binder_escapes) ->
	coreToStgLet no_binder_escapes bind body
    )				`thenLne` \ (new_let, fvs, escs, _) ->
409

410
    returnLne (new_let, fvs, escs)
411
412
\end{code}

413
\begin{code}
414
mkStgAltType scrut_ty alts
415
416
417
  = case splitTyConApp_maybe (repType scrut_ty) of
	Just (tc,_) | isUnboxedTupleTyCon tc -> UbxTupAlt tc
		    | isPrimTyCon tc	     -> PrimAlt tc
418
		    | isHiBootTyCon tc	     -> look_for_better_tycon
419
		    | isAlgTyCon tc 	     -> AlgAlt tc
420
421
422
		    | isFunTyCon tc	     -> PolyAlt
		    | otherwise		     -> pprPanic "mkStgAlts" (ppr tc)
	Nothing				     -> PolyAlt
423
424
425
426
427
428
429
430
431
432
433
434
435

  where
   -- Sometimes, the TyCon in the type of the scrutinee is an HiBootTyCon,
   -- which may not have any constructors inside it.  If so, then we
   -- can get a better TyCon by grabbing the one from a constructor alternative
   -- if one exists.
   look_for_better_tycon
	| ((DataAlt con, _, _) : _) <- data_alts = 
		AlgAlt (dataConTyCon con)
	| otherwise =
		ASSERT(null data_alts)
		PolyAlt
	where
436
		(data_alts, _deflt) = findDefault alts
437
438
\end{code}

439

440
441
442
443
-- ---------------------------------------------------------------------------
-- Applications
-- ---------------------------------------------------------------------------

444
\begin{code}
445
446
447
448
449
450
451
452
453
454
coreToStgApp
	 :: Maybe UpdateFlag		-- Just upd <=> this application is
					-- the rhs of a thunk binding
					-- 	x = [...] \upd [] -> the_app
					-- with specified update flag
	-> Id				-- Function
	-> [CoreArg]			-- Arguments
	-> LneM (StgExpr, FreeVarsInfo, EscVarsSet)

coreToStgApp maybe_thunk_body f args
455
  = coreToStgArgs args		`thenLne` \ (args', args_fvs) ->
456
457
458
    lookupVarLne f		`thenLne` \ how_bound ->

    let
459
	n_val_args	 = valArgCount args
460
	not_letrec_bound = not (isLetBound how_bound)
461
462
463
464
465
	fun_fvs	 	 
          = let fvs = singletonFVInfo f how_bound fun_occ in
            -- e.g. (f :: a -> int) (x :: a) 
            -- Here the free variables are "f", "x" AND the type variable "a"
            -- coreToStgArgs will deal with the arguments recursively
466
            if opt_RuntimeTypes then
467
	      fvs `unionFVInfo` tyvarFVInfo (tyVarsOfType (idType f))
468
469
470
471
472
473
474
475
	    else fvs

	-- Mostly, the arity info of a function is in the fn's IdInfo
	-- But new bindings introduced by CoreSat may not have no
	-- arity info; it would do us no good anyway.  For example:
	--	let f = \ab -> e in f
	-- No point in having correct arity info for f!
	-- Hence the hasArity stuff below.
476
	-- NB: f_arity is only consulted for LetBound things
477
	f_arity   = stgArity f how_bound
478
	saturated = f_arity <= n_val_args
479

480
	fun_occ 
481
482
483
	 | not_letrec_bound	    = noBinderInfo	-- Uninteresting variable
	 | f_arity > 0 && saturated = stgSatOcc	-- Saturated or over-saturated function call
	 | otherwise		    = stgUnsatOcc	-- Unsaturated function or thunk
484
485

	fun_escs
486
487
	 | not_letrec_bound      = emptyVarSet	-- Only letrec-bound escapees are interesting
	 | f_arity == n_val_args = emptyVarSet	-- A function *or thunk* with an exactly
488
489
490
491
						-- saturated call doesn't escape
						-- (let-no-escape applies to 'thunks' too)

	 | otherwise 	     = unitVarSet f	-- Inexact application; it does escape
492
493
494
495
496
497
498
499
500
501
502
503

	-- At the moment of the call:

	--  either the function is *not* let-no-escaped, in which case
	--  	   nothing is live except live_in_cont
	--	or the function *is* let-no-escaped in which case the
	--	   variables it uses are live, but still the function
	--	   itself is not.  PS.  In this case, the function's
	--	   live vars should already include those of the
	--	   continuation, but it does no harm to just union the
	--	   two regardless.

504
	res_ty = exprType (mkApps (Var f) args)
505
	app = case globalIdDetails f of
506
      		DataConWorkId dc | saturated -> StgConApp dc args'
507
508
	        PrimOpId op  	 -> ASSERT( saturated )
				    StgOpApp (StgPrimOp op) args' res_ty
509
510
511
		FCallId call	 -> ASSERT( saturated )
				    StgOpApp (StgFCallOp call (idUnique f)) args' res_ty
		_other      	 -> StgApp f args'
512

513
    in
514
515
516
517
518
519
520
521
522
    returnLne (
	app,
	fun_fvs  `unionFVInfo` args_fvs,
	fun_escs `unionVarSet` (getFVSet args_fvs)
				-- All the free vars of the args are disqualified
				-- from being let-no-escaped.
    )


523
524
525
526
527
528
529
530
531
532
533
534

-- ---------------------------------------------------------------------------
-- Argument lists
-- This is the guy that turns applications into A-normal form
-- ---------------------------------------------------------------------------

coreToStgArgs :: [CoreArg] -> LneM ([StgArg], FreeVarsInfo)
coreToStgArgs []
  = returnLne ([], emptyFVInfo)

coreToStgArgs (Type ty : args)	-- Type argument
  = coreToStgArgs args	`thenLne` \ (args', fvs) ->
535
    if opt_RuntimeTypes then
536
537
538
539
540
541
542
543
544
545
546
 	returnLne (StgTypeArg ty : args', fvs `unionFVInfo` tyvarFVInfo (tyVarsOfType ty))
    else
    returnLne (args', fvs)

coreToStgArgs (arg : args)	-- Non-type argument
  = coreToStgArgs args	`thenLne` \ (stg_args, args_fvs) ->
    coreToStgExpr arg	`thenLne` \ (arg', arg_fvs, escs) ->
    let
	fvs = args_fvs `unionFVInfo` arg_fvs
	stg_arg = case arg' of
		       StgApp v []      -> StgVarArg v
547
		       StgConApp con [] -> StgVarArg (dataConWorkId con)
548
549
550
		       StgLit lit       -> StgLitArg lit
		       _ 		-> pprPanic "coreToStgArgs" (ppr arg)
    in
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
	-- WARNING: what if we have an argument like (v `cast` co)
	-- 	    where 'co' changes the representation type?
	--	    (This really only happens if co is unsafe.)
	-- Then all the getArgAmode stuff in CgBindery will set the
	-- cg_rep of the CgIdInfo based on the type of v, rather
	-- than the type of 'co'.
	-- This matters particularly when the function is a primop
	-- or foreign call.
	-- Wanted: a better solution than this hacky warning
    let
	arg_ty = exprType arg
	stg_arg_ty = stgArgType stg_arg
    in
    WARN( isUnLiftedType arg_ty /= isUnLiftedType stg_arg_ty, 
	  ptext SLIT("Dangerous-looking argument. Probable cause: bad unsafeCoerce#") $$ ppr arg)
566
567
568
    returnLne (stg_arg : stg_args, fvs)


569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
-- ---------------------------------------------------------------------------
-- The magic for lets:
-- ---------------------------------------------------------------------------

coreToStgLet
	 :: Bool	-- True <=> yes, we are let-no-escaping this let
	 -> CoreBind	-- bindings
	 -> CoreExpr	-- body
    	 -> LneM (StgExpr,	-- new let
		  FreeVarsInfo,	-- variables free in the whole let
		  EscVarsSet,	-- variables that escape from the whole let
		  Bool)		-- True <=> none of the binders in the bindings
				-- is among the escaping vars

coreToStgLet let_no_escape bind body
584
  = fixLne (\ ~(_, _, _, _, _, rec_body_fvs, _, _) ->
585
586
587
588

	-- Do the bindings, setting live_in_cont to empty if
	-- we ain't in a let-no-escape world
	getVarsLiveInCont		`thenLne` \ live_in_cont ->
589
590
	setVarsLiveInCont (if let_no_escape 
				then live_in_cont 
591
				else emptyLiveInfo)
592
			  (vars_bind rec_body_fvs bind)
593
	    `thenLne` \ ( bind2, bind_fvs, bind_escs, bind_lv_info, env_ext) ->
594

595
596
  	-- Do the body
	extendVarEnvLne env_ext (
597
	  coreToStgExpr body          `thenLne` \(body2, body_fvs, body_escs) ->
598
	  freeVarsToLiveVars body_fvs `thenLne` \ body_lv_info ->
599

600
601
  	  returnLne (bind2, bind_fvs, bind_escs, getLiveVars bind_lv_info,
		     body2, body_fvs, body_escs, getLiveVars body_lv_info)
602
	)
603

604
    ) `thenLne` (\ (bind2, bind_fvs, bind_escs, bind_lvs, 
605
		    body2, body_fvs, body_escs, body_lvs) ->
606
607


608
609
610
611
	-- Compute the new let-expression
    let
	new_let | let_no_escape = StgLetNoEscape live_in_whole_let bind_lvs bind2 body2
		| otherwise	= StgLet bind2 body2
612

613
	free_in_whole_let
614
	  = binders `minusFVBinders` (bind_fvs `unionFVInfo` body_fvs)
615

616
	live_in_whole_let
617
	  = bind_lvs `unionVarSet` (body_lvs `delVarSetList` binders)
618

619
620
621
622
623
624
	real_bind_escs = if let_no_escape then
			    bind_escs
			 else
			    getFVSet bind_fvs
			    -- Everything escapes which is free in the bindings

625
	let_escs = (real_bind_escs `unionVarSet` body_escs) `delVarSetList` binders
626
627

	all_escs = bind_escs `unionVarSet` body_escs	-- Still includes binders of
628
							-- this let(rec)
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651

	no_binder_escapes = isEmptyVarSet (set_of_binders `intersectVarSet` all_escs)

#ifdef DEBUG
	-- Debugging code as requested by Andrew Kennedy
	checked_no_binder_escapes
		| not no_binder_escapes && any is_join_var binders
		= pprTrace "Interesting!  A join var that isn't let-no-escaped" (ppr binders)
		  False
		| otherwise = no_binder_escapes
#else
	checked_no_binder_escapes = no_binder_escapes
#endif
			    
		-- Mustn't depend on the passed-in let_no_escape flag, since
		-- no_binder_escapes is used by the caller to derive the flag!
    in
    returnLne (
	new_let,
	free_in_whole_let,
	let_escs,
	checked_no_binder_escapes
    ))
652
  where
653
    set_of_binders = mkVarSet binders
654
    binders	   = bindersOf bind
655

656
    mk_binding bind_lv_info binder rhs
657
	= (binder, LetBound (NestedLet live_vars) (manifestArity rhs))
658
	where
659
660
661
	   live_vars | let_no_escape = addLiveVar bind_lv_info binder
		     | otherwise     = unitLiveVar binder
		-- c.f. the invariant on NestedLet
662

663
    vars_bind :: FreeVarsInfo		-- Free var info for body of binding
664
665
	      -> CoreBind
	      -> LneM (StgBinding,
666
667
		       FreeVarsInfo, 
		       EscVarsSet,  	  -- free vars; escapee vars
668
		       LiveInfo,	  -- Vars and CAFs live in binding
669
670
		       [(Id, HowBound)])  -- extension to environment
					 
671

672
    vars_bind body_fvs (NonRec binder rhs)
673
674
      = coreToStgRhs body_fvs [] (binder,rhs)
				`thenLne` \ (rhs2, bind_fvs, bind_lv_info, escs) ->
675
	let
676
	    env_ext_item = mk_binding bind_lv_info binder rhs
677
	in
678
	returnLne (StgNonRec binder rhs2, 
679
		   bind_fvs, escs, bind_lv_info, [env_ext_item])
680
681
682


    vars_bind body_fvs (Rec pairs)
683
      = fixLne (\ ~(_, rec_rhs_fvs, _, bind_lv_info, _) ->
684
685
686
	   let
		rec_scope_fvs = unionFVInfo body_fvs rec_rhs_fvs
	        binders = map fst pairs
687
	        env_ext = [ mk_binding bind_lv_info b rhs 
688
			  | (b,rhs) <- pairs ]
689
690
	   in
	   extendVarEnvLne env_ext (
691
692
	      mapAndUnzip4Lne (coreToStgRhs rec_scope_fvs binders) pairs 
					`thenLne` \ (rhss2, fvss, lv_infos, escss) ->
693
694
	      let
			bind_fvs = unionFVInfos fvss
695
			bind_lv_info = foldr unionLiveInfo emptyLiveInfo lv_infos
696
697
			escs     = unionVarSets escss
	      in
698
	      returnLne (StgRec (binders `zip` rhss2),
699
			 bind_fvs, escs, bind_lv_info, env_ext)
700
701
	   )
	)
702
703
704
705

is_join_var :: Id -> Bool
-- A hack (used only for compiler debuggging) to tell if
-- a variable started life as a join point ($j)
706
is_join_var j = occNameString (getOccName j) == "$j"
707
\end{code}
708

709
710
\begin{code}
coreToStgRhs :: FreeVarsInfo		-- Free var info for the scope of the binding
711
	     -> [Id]
712
	     -> (Id,CoreExpr)
713
  	     -> LneM (StgRhs, FreeVarsInfo, LiveInfo, EscVarsSet)
714

715
coreToStgRhs scope_fv_info binders (bndr, rhs)
716
717
  = coreToStgExpr rhs 		`thenLne` \ (new_rhs, rhs_fvs, rhs_escs) ->
    getEnvLne			`thenLne` \ env ->    
718
719
720
    freeVarsToLiveVars (binders `minusFVBinders` rhs_fvs) `thenLne` \ lv_info ->
    returnLne (mkStgRhs rhs_fvs (mkSRT lv_info) bndr_info new_rhs,
	       rhs_fvs, lv_info, rhs_escs)
721
722
723
  where
    bndr_info = lookupFVInfo scope_fv_info bndr

724
mkStgRhs :: FreeVarsInfo -> SRT -> StgBinderInfo -> StgExpr -> StgRhs
725

726
mkStgRhs rhs_fvs srt binder_info (StgConApp con args)
727
728
  = StgRhsCon noCCS con args

729
mkStgRhs rhs_fvs srt binder_info (StgLam _ bndrs body)
730
731
732
  = StgRhsClosure noCCS binder_info
		  (getFVs rhs_fvs)		 
		  ReEntrant
733
		  srt bndrs body
734
	
735
mkStgRhs rhs_fvs srt binder_info rhs
736
737
  = StgRhsClosure noCCS binder_info
		  (getFVs rhs_fvs)		 
738
	          upd_flag srt [] rhs
739
  where
740
741
742
743
744
745
   upd_flag = Updatable
  {-
    SDM: disabled.  Eval/Apply can't handle functions with arity zero very
    well; and making these into simple non-updatable thunks breaks other
    assumptions (namely that they will be entered only once).

746
747
    upd_flag | isPAP env rhs  = ReEntrant
	     | otherwise      = Updatable
748
749
  -}

750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
{- ToDo:
          upd = if isOnceDem dem
      		    then (if isNotTop toplev 
                	    then SingleEntry    -- HA!  Paydirt for "dem"
                	    else 
#ifdef DEBUG
                     trace "WARNING: SE CAFs unsupported, forcing UPD instead" $
#endif
                     Updatable)
          	else Updatable
        -- For now we forbid SingleEntry CAFs; they tickle the
        -- ASSERT in rts/Storage.c line 215 at newCAF() re mut_link,
        -- and I don't understand why.  There's only one SE_CAF (well,
        -- only one that tickled a great gaping bug in an earlier attempt
        -- at ClosureInfo.getEntryConvention) in the whole of nofib, 
        -- specifically Main.lvl6 in spectral/cryptarithm2.
        -- So no great loss.  KSW 2000-07.
-}
\end{code}

Detect thunks which will reduce immediately to PAPs, and make them
non-updatable.  This has several advantages:

        - the non-updatable thunk behaves exactly like the PAP,

	- the thunk is more efficient to enter, because it is
	  specialised to the task.

        - we save one update frame, one stg_update_PAP, one update
	  and lots of PAP_enters.

	- in the case where the thunk is top-level, we save building
	  a black hole and futhermore the thunk isn't considered to
	  be a CAF any more, so it doesn't appear in any SRTs.

We do it here, because the arity information is accurate, and we need
to do it before the SRT pass to save the SRT entries associated with
any top-level PAPs.

isPAP env (StgApp f args) = listLengthCmp args arity == LT -- idArity f > length args
			  where
			    arity = stgArity f (lookupBinding env f)
isPAP env _ 	          = False

794

795
796
%************************************************************************
%*									*
797
\subsection[LNE-monad]{A little monad for this let-no-escaping pass}
798
799
800
%*									*
%************************************************************************

801
There's a lot of stuff to pass around, so we use this @LneM@ monad to
802
help.  All the stuff here is only passed *down*.
803

804
\begin{code}
805
type LneM a =  IdEnv HowBound
806
	    -> LiveInfo		-- Vars and CAFs live in continuation
807
808
	    -> a

809
810
811
812
813
814
815
816
type LiveInfo = (StgLiveVars, 	-- Dynamic live variables; 
				-- i.e. ones with a nested (non-top-level) binding
		 CafSet)	-- Static live variables;
				-- i.e. top-level variables that are CAFs or refer to them

type EscVarsSet = IdSet
type CafSet     = IdSet

817
data HowBound
818
819
  = ImportBound		-- Used only as a response to lookupBinding; never
			-- exists in the range of the (IdEnv HowBound)
820
821
822
823
824
825
826

  | LetBound		-- A let(rec) in this module
	LetInfo		-- Whether top level or nested
 	Arity		-- Its arity (local Ids don't have arity info at this point)

  | LambdaBound		-- Used for both lambda and case

827
828
829
830
831
832
data LetInfo
  = TopLet		-- top level things
  | NestedLet LiveInfo	-- For nested things, what is live if this
			-- thing is live?  Invariant: the binder
			-- itself is always a member of
			-- the dynamic set of its own LiveInfo
833
834
835
836

isLetBound (LetBound _ _) = True
isLetBound other 	  = False

837
838
839
topLevelBound ImportBound	  = True
topLevelBound (LetBound TopLet _) = True
topLevelBound other		  = False
840
841
\end{code}

842
843
844
845
For a let(rec)-bound variable, x, we record LiveInfo, the set of
variables that are live if x is live.  This LiveInfo comprises
	(a) dynamic live variables (ones with a non-top-level binding)
	(b) static live variabes (CAFs or things that refer to CAFs)
846

847
848
849
850
851
852
853
For "normal" variables (a) is just x alone.  If x is a let-no-escaped
variable then x is represented by a code pointer and a stack pointer
(well, one for each stack).  So all of the variables needed in the
execution of x are live if x is, and are therefore recorded in the
LetBound constructor; x itself *is* included.

The set of dynamic live variables is guaranteed ot have no further let-no-escaped
854
variables in it.
855

856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
\begin{code}
emptyLiveInfo :: LiveInfo
emptyLiveInfo = (emptyVarSet,emptyVarSet)

unitLiveVar :: Id -> LiveInfo
unitLiveVar lv = (unitVarSet lv, emptyVarSet)

unitLiveCaf :: Id -> LiveInfo
unitLiveCaf caf = (emptyVarSet, unitVarSet caf)

addLiveVar :: LiveInfo -> Id -> LiveInfo
addLiveVar (lvs, cafs) id = (lvs `extendVarSet` id, cafs)

unionLiveInfo :: LiveInfo -> LiveInfo -> LiveInfo
unionLiveInfo (lv1,caf1) (lv2,caf2) = (lv1 `unionVarSet` lv2, caf1 `unionVarSet` caf2)

mkSRT :: LiveInfo -> SRT
mkSRT (_, cafs) = SRTEntries cafs

getLiveVars :: LiveInfo -> StgLiveVars
getLiveVars (lvs, _) = lvs
\end{code}


880
881
The std monad functions:
\begin{code}
882
initLne :: IdEnv HowBound -> LneM a -> a
883
884
initLne env m = m env emptyLiveInfo

885

886
887
888
889
890
891
892
893

{-# INLINE thenLne #-}
{-# INLINE returnLne #-}

returnLne :: a -> LneM a
returnLne e env lvs_cont = e

thenLne :: LneM a -> (a -> LneM b) -> LneM b
894
thenLne m k env lvs_cont 
895
  = k (m env lvs_cont) env lvs_cont
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910

mapAndUnzipLne  :: (a -> LneM (b,c))   -> [a] -> LneM ([b],[c])
mapAndUnzipLne f [] = returnLne ([],[])
mapAndUnzipLne f (x:xs)
  = f x		    	`thenLne` \ (r1,  r2)  ->
    mapAndUnzipLne f xs	`thenLne` \ (rs1, rs2) ->
    returnLne (r1:rs1, r2:rs2)

mapAndUnzip3Lne :: (a -> LneM (b,c,d)) -> [a] -> LneM ([b],[c],[d])
mapAndUnzip3Lne f []	= returnLne ([],[],[])
mapAndUnzip3Lne f (x:xs)
  = f x		    	 `thenLne` \ (r1,  r2,  r3)  ->
    mapAndUnzip3Lne f xs `thenLne` \ (rs1, rs2, rs3) ->
    returnLne (r1:rs1, r2:rs2, r3:rs3)

911
912
913
914
915
916
917
mapAndUnzip4Lne :: (a -> LneM (b,c,d,e)) -> [a] -> LneM ([b],[c],[d],[e])
mapAndUnzip4Lne f []	= returnLne ([],[],[],[])
mapAndUnzip4Lne f (x:xs)
  = f x		    	 `thenLne` \ (r1,  r2,  r3, r4)  ->
    mapAndUnzip4Lne f xs `thenLne` \ (rs1, rs2, rs3, rs4) ->
    returnLne (r1:rs1, r2:rs2, r3:rs3, r4:rs4)

918
fixLne :: (a -> LneM a) -> LneM a
919
920
fixLne expr env lvs_cont
  = result
921
922
923
  where
    result = expr result env lvs_cont
\end{code}
924

925
Functions specific to this monad:
926

927
\begin{code}
928
getVarsLiveInCont :: LneM LiveInfo
929
930
getVarsLiveInCont env lvs_cont = lvs_cont

931
setVarsLiveInCont :: LiveInfo -> LneM a -> LneM a
932
933
934
935
936
937
938
939
setVarsLiveInCont new_lvs_cont expr env lvs_cont
  = expr env new_lvs_cont

extendVarEnvLne :: [(Id, HowBound)] -> LneM a -> LneM a
extendVarEnvLne ids_w_howbound expr env lvs_cont
  = expr (extendVarEnvList env ids_w_howbound) lvs_cont

lookupVarLne :: Id -> LneM HowBound
940
941
lookupVarLne v env lvs_cont = returnLne (lookupBinding env v) env lvs_cont

942
943
944
getEnvLne :: LneM (IdEnv HowBound)
getEnvLne env lvs_cont = returnLne env env lvs_cont

945
946
947
lookupBinding :: IdEnv HowBound -> Id -> HowBound
lookupBinding env v = case lookupVarEnv env v of
			Just xx -> xx
948
			Nothing -> ASSERT2( isGlobalId v, ppr v ) ImportBound
949

950
951
952
953
954

-- The result of lookupLiveVarsForSet, a set of live variables, is
-- only ever tacked onto a decorated expression. It is never used as
-- the basis of a control decision, which might give a black hole.

955
freeVarsToLiveVars :: FreeVarsInfo -> LneM LiveInfo
956
freeVarsToLiveVars fvs env live_in_cont
957
  = returnLne live_info env live_in_cont
958
  where
959
960
    live_info    = foldr unionLiveInfo live_in_cont lvs_from_fvs
    lvs_from_fvs = map do_one (allFreeIds fvs)
961

962
963
964
965
    do_one (v, how_bound)
      = case how_bound of
	  ImportBound 		          -> unitLiveCaf v	-- Only CAF imports are 
								-- recorded in fvs
966
967
968
	  LetBound TopLet _ 		 
		| mayHaveCafRefs (idCafInfo v) -> unitLiveCaf v
		| otherwise		       -> emptyLiveInfo
969

970
971
	  LetBound (NestedLet lvs) _      -> lvs	-- lvs already contains v
							-- (see the invariant on NestedLet)
972

973
	  _lambda_or_case_binding	  -> unitLiveVar v	-- Bound by lambda or case
974
\end{code}
sof's avatar
sof committed
975

976
977
%************************************************************************
%*									*
978
\subsection[Free-var info]{Free variable information}
979
980
981
982
%*									*
%************************************************************************

\begin{code}
983
984
985
986
987
988
989
990
type FreeVarsInfo = VarEnv (Var, HowBound, StgBinderInfo)
	-- The Var is so we can gather up the free variables
	-- as a set.
	--
	-- The HowBound info just saves repeated lookups;
	-- we look up just once when we encounter the occurrence.
	-- INVARIANT: Any ImportBound Ids are HaveCafRef Ids
	--	      Imported Ids without CAF refs are simply
991
992
	--	      not put in the FreeVarsInfo for an expression.
	--	      See singletonFVInfo and freeVarsToLiveVars
993
	--
994
995
996
997
	-- StgBinderInfo records how it occurs; notably, we
	-- are interested in whether it only occurs in saturated 
	-- applications, because then we don't need to build a
	-- curried version.
998
999
	-- If f is mapped to noBinderInfo, that means
	-- that f *is* mentioned (else it wouldn't be in the
1000
	-- IdEnv at all), but perhaps in an unsaturated applications.
1001
1002
1003
1004
1005
1006
1007
	--
	-- All case/lambda-bound things are also mapped to
	-- noBinderInfo, since we aren't interested in their
	-- occurence info.
	--
	-- For ILX we track free var info for type variables too;
	-- hence VarEnv not IdEnv
1008
1009
\end{code}

1010
\begin{code}
1011
1012
emptyFVInfo :: FreeVarsInfo
emptyFVInfo = emptyVarEnv
1013

1014
singletonFVInfo :: Id -> HowBound -> StgBinderInfo -> FreeVarsInfo
1015
-- Don't record non-CAF imports at all, to keep free-var sets small
1016
singletonFVInfo id ImportBound info
1017
   | mayHaveCafRefs (idCafInfo id) = unitVarEnv id (id, ImportBound, info)
1018
   | otherwise         		   = emptyVarEnv
1019
singletonFVInfo id how_bound info  = unitVarEnv id (id, how_bound, info)
1020

1021
1022
tyvarFVInfo :: TyVarSet -> FreeVarsInfo
tyvarFVInfo tvs = foldVarSet add emptyFVInfo tvs
1023
        where
1024
1025
	  add tv fvs = extendVarEnv fvs tv (tv, LambdaBound, noBinderInfo)
		-- Type variables must be lambda-bound
1026

1027
1028
unionFVInfo :: FreeVarsInfo -> FreeVarsInfo -> FreeVarsInfo
unionFVInfo fv1 fv2 = plusVarEnv_C plusFVInfo fv1 fv2
1029

1030
1031
unionFVInfos :: [FreeVarsInfo] -> FreeVarsInfo
unionFVInfos fvs = foldr unionFVInfo emptyFVInfo fvs
1032

1033
1034
1035
1036
minusFVBinders :: [Id] -> FreeVarsInfo -> FreeVarsInfo
minusFVBinders vs fv = foldr minusFVBinder fv vs

minusFVBinder :: Id -> FreeVarsInfo -> FreeVarsInfo
1037
minusFVBinder v fv | isId v && opt_RuntimeTypes
1038
		   = (fv `delVarEnv` v) `unionFVInfo` 
1039
1040
		     tyvarFVInfo (tyVarsOfType (idType v))
		   | otherwise = fv `delVarEnv` v
1041
1042
	-- When removing a binder, remember to add its type variables
	-- c.f. CoreFVs.delBinderFV
1043

1044
1045
elementOfFVInfo :: Id -> FreeVarsInfo -> Bool
elementOfFVInfo id fvs = maybeToBool (lookupVarEnv fvs id)
1046

1047
lookupFVInfo :: FreeVarsInfo -> Id -> StgBinderInfo
1048
1049
1050
-- Find how the given Id is used.
-- Externally visible things may be used any old how
lookupFVInfo fvs id 
1051
  | isExternalName (idName id) = noBinderInfo
1052
1053
  | otherwise = case lookupVarEnv fvs id of
			Nothing         -> noBinderInfo
1054
			Just (_,_,info) -> info
1055

1056
allFreeIds :: FreeVarsInfo -> [(Id,HowBound)]	-- Both top level and non-top-level Ids
1057
allFreeIds fvs = [(id,how_bound) | (id,how_bound,_) <- varEnvElts fvs, isId id]
1058

1059
1060
-- Non-top-level things only, both type variables and ids
-- (type variables only if opt_RuntimeTypes)
1061
getFVs :: FreeVarsInfo -> [Var]	
1062
getFVs fvs = [id | (id, how_bound, _) <- varEnvElts fvs, 
1063
		    not (topLevelBound how_bound) ]
1064

1065
getFVSet :: FreeVarsInfo -> VarSet
1066
getFVSet fvs = mkVarSet (getFVs fvs)
1067

1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
plusFVInfo (id1,hb1,info1) (id2,hb2,info2)
  = ASSERT (id1 == id2 && hb1 `check_eq_how_bound` hb2)
    (id1, hb1, combineStgBinderInfo info1 info2)

#ifdef DEBUG
-- The HowBound info for a variable in the FVInfo should be consistent
check_eq_how_bound ImportBound 	      ImportBound 	 = True
check_eq_how_bound LambdaBound 	      LambdaBound 	 = True
check_eq_how_bound (LetBound li1 ar1) (LetBound li2 ar2) = ar1 == ar2 && check_eq_li li1 li2
check_eq_how_bound hb1		      hb2		 = False

check_eq_li (NestedLet _) (NestedLet _) = True
1080
check_eq_li TopLet        TopLet        = True
1081
1082
check_eq_li li1 	  li2		= False
#endif
1083
1084
\end{code}

1085
Misc.
1086
\begin{code}
1087
1088
filterStgBinders :: [Var] -> [Var]
filterStgBinders bndrs
1089
  | opt_RuntimeTypes = bndrs
1090
1091
  | otherwise	     = filter isId bndrs
\end{code}
1092

1093
1094
1095

\begin{code}
	-- Ignore all notes except SCC
1096
1097
1098
1099
1100
myCollectBinders expr
  = go [] expr
  where
    go bs (Lam b e)          = go (b:bs) e
    go bs e@(Note (SCC _) _) = (reverse bs, e) 
andy@galois.com's avatar
andy@galois.com committed
1101
1102
    go bs e@(Note (TickBox {}) _) = (reverse bs, e)
    go bs e@(Note (BinaryTickBox {}) _)  = (reverse bs, e)
1103
    go bs (Cast e co)        = go bs e
1104
1105
1106
    go bs (Note _ e)         = go bs e
    go bs e	             = (reverse bs, e)

1107
1108
1109
myCollectArgs :: CoreExpr -> (Id, [CoreArg])
	-- We assume that we only have variables
	-- in the function position by now
1110
1111
myCollectArgs expr
  = go expr []
1112
  where
1113
    go (Var v)          as = (v, as)
1114
    go (App f a) as        = go f (a:as)
1115
    go (Note (SCC _) e) as = pprPanic "CoreToStg.myCollectArgs" (ppr expr)
andy@galois.com's avatar
andy@galois.com committed
1116
1117
    go (Note (TickBox {}) e) as = pprPanic "CoreToStg.myCollectArgs" (ppr expr)
    go (Note (BinaryTickBox {}) e) as = pprPanic "CoreToStg.myCollectArgs" (ppr expr)
1118
    go (Cast e co)      as = go e as
1119
1120
    go (Note n e)       as = go e as
    go _		as = pprPanic "CoreToStg.myCollectArgs" (ppr expr)
1121
\end{code}
1122
1123

\begin{code}
1124
1125
1126
1127
stgArity :: Id -> HowBound -> Arity
stgArity f (LetBound _ arity) = arity
stgArity f ImportBound	      = idArity f
stgArity f LambdaBound        = 0
1128
\end{code}