CoreToStg.lhs 36.5 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 Coercion         ( mkUnsafeCoercion )
20
import TyCon		( isAlgTyCon )
21
import Id
22
import Var		( Var, globalIdDetails, idType )
23
import TyCon		( isUnboxedTupleTyCon, isPrimTyCon, isFunTyCon, isHiBootTyCon )
24
25
26
#ifdef ILX
import MkId		( unsafeCoerceId )
#endif
27
28
29
30
import IdInfo
import DataCon
import CostCentre	( noCCS )
import VarSet
31
import VarEnv
32
import Maybes		( maybeToBool )
33
import Name		( getOccName, isExternalName, nameOccName )
34
import OccName		( occNameString, occNameFS )
35
import BasicTypes       ( Arity )
36
import StaticFlags	( opt_RuntimeTypes )
Simon Marlow's avatar
Simon Marlow committed
37
import PackageConfig	( PackageId )
38
import Outputable
39

40
infixr 9 `thenLne`
41
42
\end{code}

43
44
%************************************************************************
%*									*
45
\subsection[live-vs-free-doc]{Documentation}
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
87
88
89
90
(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.
91

92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
%************************************************************************
%*									*
\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

107
The CafInfo has already been calculated during the CoreTidy pass.
108
109
110
111
112
113
114
115
116
117

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.

118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136

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.


137
138
%************************************************************************
%*									*
139
\subsection[binds-StgVarInfo]{Setting variable info: top-level, binds, RHSs}
140
141
142
143
%*									*
%************************************************************************

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

coreExprToStg :: CoreExpr -> StgExpr
coreExprToStg expr 
151
152
153
154
  = new_expr where (new_expr,_,_) = initLne emptyVarEnv (coreToStgExpr expr)


coreTopBindsToStg
Simon Marlow's avatar
Simon Marlow committed
155
    :: PackageId
156
    -> IdEnv HowBound		-- environment for the bindings
157
158
159
    -> [CoreBind]
    -> (IdEnv HowBound, FreeVarsInfo, [StgBinding])

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


coreTopBindToStg
Simon Marlow's avatar
Simon Marlow committed
170
	:: PackageId
171
	-> IdEnv HowBound
172
173
	-> FreeVarsInfo		-- Info about the body
	-> CoreBind
174
	-> (IdEnv HowBound, FreeVarsInfo, StgBinding)
175

Simon Marlow's avatar
Simon Marlow committed
176
coreTopBindToStg this_pkg env body_fvs (NonRec id rhs)
177
  = let 
178
	env' 	  = extendVarEnv env id how_bound
179
	how_bound = LetBound TopLet $! manifestArity rhs
180

181
        (stg_rhs, fvs') = 
182
	    initLne env (
Simon Marlow's avatar
Simon Marlow committed
183
              coreToTopStgRhs this_pkg body_fvs (id,rhs)	`thenLne` \ (stg_rhs, fvs') ->
184
	      returnLne (stg_rhs, fvs')
185
186
           )
	
187
	bind = StgNonRec id stg_rhs
188
    in
189
    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) )
190
    ASSERT2(consistentCafInfo id bind, ppr id)
191
192
193
--    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
194
coreTopBindToStg this_pkg env body_fvs (Rec pairs)
195
196
197
  = let 
	(binders, rhss) = unzip pairs

198
	extra_env' = [ (b, LetBound TopLet $! manifestArity rhs)
199
		     | (b, rhs) <- pairs ]
200
	env' = extendVarEnvList env extra_env'
201

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

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

216
217
218
219
220
221
222
#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")
223
  = safe
224
  | otherwise
225
  = WARN (not exact, ppr id) safe
226
  where
227
228
	safe  = id_marked_caffy || not binding_is_caffy
	exact = id_marked_caffy == binding_is_caffy
229
230
231
	id_marked_caffy  = mayHaveCafRefs (idCafInfo id)
	binding_is_caffy = stgBindHasCafRefs bind
#endif
232
233
234
\end{code}

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

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

249
mkTopStgRhs :: Bool -> FreeVarsInfo -> SRT -> StgBinderInfo -> StgExpr
250
	-> StgRhs
251

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

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


-- ---------------------------------------------------------------------------
-- Expressions
-- ---------------------------------------------------------------------------
277

278
\begin{code}
279
280
281
282
283
284
285
286
287
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.
288
289
\end{code}

290
291
292
293
294
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.
295
296

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

300
coreToStgExpr expr@(App _ _)
301
302
303
  = coreToStgApp Nothing f args
  where
    (f, args) = myCollectArgs expr
304

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

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

324
#ifdef ILX
325
326
-- For ILX, convert (__coerce__ to_ty from_ty e)
--         into    (coerce to_ty from_ty e)
327
-- where coerce is real function
328
329
330
331
coreToStgExpr (Cast expr co)
  = let (from_ty, ty_ty) = coercionKind co in
    coreToStgExpr (mkApps (Var unsafeCoerceId)
                         [Type from_ty, Type to_ty, expr])
332
333
#endif

334
335
coreToStgExpr (Note other_note expr)
  = coreToStgExpr expr
336

337
338
339
coreToStgExpr (Cast expr co)
  = coreToStgExpr expr

340
341
-- Cases require a little more real work.

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

	-- 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.
359
360
	alts_fvs_wo_bndr  = bndr `minusFVBinder` alts_fvs
	alts_escs_wo_bndr = alts_escs `delVarSet` bndr
361
    in
362
363
364
365
366
367

    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 (
368
	coreToStgExpr scrut	  `thenLne` \ (scrut2, scrut_fvs, scrut_escs) ->
369
370
        freeVarsToLiveVars scrut_fvs `thenLne` \ scrut_lv_info ->
	returnLne (scrut2, scrut_fvs, scrut_escs, scrut_lv_info)
371
      )    
372
		`thenLne` \ (scrut2, scrut_fvs, scrut_escs, scrut_lv_info) ->
373

374
    returnLne (
375
376
377
378
      StgCase scrut2 (getLiveVars scrut_lv_info)
		     (getLiveVars alts_lv_info)
		     bndr'
		     (mkSRT alts_lv_info)
379
		     (mkStgAltType (idType bndr) alts)
380
381
382
		     alts2,
      scrut_fvs `unionFVInfo` alts_fvs_wo_bndr,
      alts_escs_wo_bndr `unionVarSet` getFVSet scrut_fvs
383
384
385
		-- 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.
386
387
      )
  where
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
    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
403
404
\end{code}

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

408
(Meanwhile, we don't expect to see let-no-escapes...)
409
\begin{code}
410
411
412
413
coreToStgExpr (Let bind body)
  = fixLne (\ ~(_, _, _, no_binder_escapes) ->
	coreToStgLet no_binder_escapes bind body
    )				`thenLne` \ (new_let, fvs, escs, _) ->
414

415
    returnLne (new_let, fvs, escs)
416
417
\end{code}

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

  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
441
		(data_alts, _deflt) = findDefault alts
442
443
\end{code}

444

445
446
447
448
-- ---------------------------------------------------------------------------
-- Applications
-- ---------------------------------------------------------------------------

449
\begin{code}
450
451
452
453
454
455
456
457
458
459
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
460
  = coreToStgArgs args		`thenLne` \ (args', args_fvs) ->
461
462
463
    lookupVarLne f		`thenLne` \ how_bound ->

    let
464
	n_val_args	 = valArgCount args
465
	not_letrec_bound = not (isLetBound how_bound)
466
467
468
469
470
	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
471
            if opt_RuntimeTypes then
472
	      fvs `unionFVInfo` tyvarFVInfo (tyVarsOfType (idType f))
473
474
475
476
477
478
479
480
	    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.
481
	-- NB: f_arity is only consulted for LetBound things
482
	f_arity   = stgArity f how_bound
483
	saturated = f_arity <= n_val_args
484

485
	fun_occ 
486
487
488
	 | not_letrec_bound	    = noBinderInfo	-- Uninteresting variable
	 | f_arity > 0 && saturated = stgSatOcc	-- Saturated or over-saturated function call
	 | otherwise		    = stgUnsatOcc	-- Unsaturated function or thunk
489
490

	fun_escs
491
492
	 | not_letrec_bound      = emptyVarSet	-- Only letrec-bound escapees are interesting
	 | f_arity == n_val_args = emptyVarSet	-- A function *or thunk* with an exactly
493
494
495
496
						-- saturated call doesn't escape
						-- (let-no-escape applies to 'thunks' too)

	 | otherwise 	     = unitVarSet f	-- Inexact application; it does escape
497
498
499
500
501
502
503
504
505
506
507
508

	-- 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.

509
	res_ty = exprType (mkApps (Var f) args)
510
	app = case globalIdDetails f of
511
512
513
514
515
516
      		DataConWorkId dc | saturated -> StgConApp dc args'
	        PrimOpId op  		     -> ASSERT( saturated )
					        StgOpApp (StgPrimOp op) args' res_ty
		FCallId call	 -> ASSERT( saturated )
				    StgOpApp (StgFCallOp call (idUnique f)) args' res_ty
		_other      	 -> StgApp f args'
517

518
    in
519
520
521
522
523
524
525
526
527
    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.
    )


528
529
530
531
532
533
534
535
536
537
538
539

-- ---------------------------------------------------------------------------
-- 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) ->
540
    if opt_RuntimeTypes then
541
542
543
544
545
546
547
548
549
550
551
 	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
552
		       StgConApp con [] -> StgVarArg (dataConWorkId con)
553
554
555
556
557
558
		       StgLit lit       -> StgLitArg lit
		       _ 		-> pprPanic "coreToStgArgs" (ppr arg)
    in
    returnLne (stg_arg : stg_args, fvs)


559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
-- ---------------------------------------------------------------------------
-- 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
574
  = fixLne (\ ~(_, _, _, _, _, rec_body_fvs, _, _) ->
575
576
577
578

	-- Do the bindings, setting live_in_cont to empty if
	-- we ain't in a let-no-escape world
	getVarsLiveInCont		`thenLne` \ live_in_cont ->
579
580
	setVarsLiveInCont (if let_no_escape 
				then live_in_cont 
581
				else emptyLiveInfo)
582
			  (vars_bind rec_body_fvs bind)
583
	    `thenLne` \ ( bind2, bind_fvs, bind_escs, bind_lv_info, env_ext) ->
584

585
586
  	-- Do the body
	extendVarEnvLne env_ext (
587
	  coreToStgExpr body          `thenLne` \(body2, body_fvs, body_escs) ->
588
	  freeVarsToLiveVars body_fvs `thenLne` \ body_lv_info ->
589

590
591
  	  returnLne (bind2, bind_fvs, bind_escs, getLiveVars bind_lv_info,
		     body2, body_fvs, body_escs, getLiveVars body_lv_info)
592
	)
593

594
    ) `thenLne` (\ (bind2, bind_fvs, bind_escs, bind_lvs, 
595
		    body2, body_fvs, body_escs, body_lvs) ->
596
597


598
599
600
601
	-- Compute the new let-expression
    let
	new_let | let_no_escape = StgLetNoEscape live_in_whole_let bind_lvs bind2 body2
		| otherwise	= StgLet bind2 body2
602

603
	free_in_whole_let
604
	  = binders `minusFVBinders` (bind_fvs `unionFVInfo` body_fvs)
605

606
	live_in_whole_let
607
	  = bind_lvs `unionVarSet` (body_lvs `delVarSetList` binders)
608

609
610
611
612
613
614
	real_bind_escs = if let_no_escape then
			    bind_escs
			 else
			    getFVSet bind_fvs
			    -- Everything escapes which is free in the bindings

615
	let_escs = (real_bind_escs `unionVarSet` body_escs) `delVarSetList` binders
616
617

	all_escs = bind_escs `unionVarSet` body_escs	-- Still includes binders of
618
							-- this let(rec)
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641

	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
    ))
642
  where
643
    set_of_binders = mkVarSet binders
644
    binders	   = bindersOf bind
645

646
    mk_binding bind_lv_info binder rhs
647
	= (binder, LetBound (NestedLet live_vars) (manifestArity rhs))
648
	where
649
650
651
	   live_vars | let_no_escape = addLiveVar bind_lv_info binder
		     | otherwise     = unitLiveVar binder
		-- c.f. the invariant on NestedLet
652

653
    vars_bind :: FreeVarsInfo		-- Free var info for body of binding
654
655
	      -> CoreBind
	      -> LneM (StgBinding,
656
657
		       FreeVarsInfo, 
		       EscVarsSet,  	  -- free vars; escapee vars
658
		       LiveInfo,	  -- Vars and CAFs live in binding
659
660
		       [(Id, HowBound)])  -- extension to environment
					 
661

662
    vars_bind body_fvs (NonRec binder rhs)
663
664
      = coreToStgRhs body_fvs [] (binder,rhs)
				`thenLne` \ (rhs2, bind_fvs, bind_lv_info, escs) ->
665
	let
666
	    env_ext_item = mk_binding bind_lv_info binder rhs
667
	in
668
	returnLne (StgNonRec binder rhs2, 
669
		   bind_fvs, escs, bind_lv_info, [env_ext_item])
670
671
672


    vars_bind body_fvs (Rec pairs)
673
      = fixLne (\ ~(_, rec_rhs_fvs, _, bind_lv_info, _) ->
674
675
676
	   let
		rec_scope_fvs = unionFVInfo body_fvs rec_rhs_fvs
	        binders = map fst pairs
677
	        env_ext = [ mk_binding bind_lv_info b rhs 
678
			  | (b,rhs) <- pairs ]
679
680
	   in
	   extendVarEnvLne env_ext (
681
682
	      mapAndUnzip4Lne (coreToStgRhs rec_scope_fvs binders) pairs 
					`thenLne` \ (rhss2, fvss, lv_infos, escss) ->
683
684
	      let
			bind_fvs = unionFVInfos fvss
685
			bind_lv_info = foldr unionLiveInfo emptyLiveInfo lv_infos
686
687
			escs     = unionVarSets escss
	      in
688
	      returnLne (StgRec (binders `zip` rhss2),
689
			 bind_fvs, escs, bind_lv_info, env_ext)
690
691
	   )
	)
692
693
694
695

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

699
700
\begin{code}
coreToStgRhs :: FreeVarsInfo		-- Free var info for the scope of the binding
701
	     -> [Id]
702
	     -> (Id,CoreExpr)
703
  	     -> LneM (StgRhs, FreeVarsInfo, LiveInfo, EscVarsSet)
704

705
coreToStgRhs scope_fv_info binders (bndr, rhs)
706
707
  = coreToStgExpr rhs 		`thenLne` \ (new_rhs, rhs_fvs, rhs_escs) ->
    getEnvLne			`thenLne` \ env ->    
708
709
710
    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)
711
712
713
  where
    bndr_info = lookupFVInfo scope_fv_info bndr

714
mkStgRhs :: FreeVarsInfo -> SRT -> StgBinderInfo -> StgExpr -> StgRhs
715

716
mkStgRhs rhs_fvs srt binder_info (StgConApp con args)
717
718
  = StgRhsCon noCCS con args

719
mkStgRhs rhs_fvs srt binder_info (StgLam _ bndrs body)
720
721
722
  = StgRhsClosure noCCS binder_info
		  (getFVs rhs_fvs)		 
		  ReEntrant
723
		  srt bndrs body
724
	
725
mkStgRhs rhs_fvs srt binder_info rhs
726
727
  = StgRhsClosure noCCS binder_info
		  (getFVs rhs_fvs)		 
728
	          upd_flag srt [] rhs
729
  where
730
731
732
733
734
735
   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).

736
737
    upd_flag | isPAP env rhs  = ReEntrant
	     | otherwise      = Updatable
738
739
  -}

740
741
742
743
744
745
746
747
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
{- 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

784

785
786
%************************************************************************
%*									*
787
\subsection[LNE-monad]{A little monad for this let-no-escaping pass}
788
789
790
%*									*
%************************************************************************

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

794
\begin{code}
795
type LneM a =  IdEnv HowBound
796
	    -> LiveInfo		-- Vars and CAFs live in continuation
797
798
	    -> a

799
800
801
802
803
804
805
806
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

807
data HowBound
808
809
  = ImportBound		-- Used only as a response to lookupBinding; never
			-- exists in the range of the (IdEnv HowBound)
810
811
812
813
814
815
816

  | 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

817
818
819
820
821
822
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
823
824
825
826

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

827
828
829
topLevelBound ImportBound	  = True
topLevelBound (LetBound TopLet _) = True
topLevelBound other		  = False
830
831
\end{code}

832
833
834
835
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)
836

837
838
839
840
841
842
843
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
844
variables in it.
845

846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
\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}


870
871
The std monad functions:
\begin{code}
872
initLne :: IdEnv HowBound -> LneM a -> a
873
874
initLne env m = m env emptyLiveInfo

875

876
877
878
879
880
881
882
883

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

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

thenLne :: LneM a -> (a -> LneM b) -> LneM b
884
thenLne m k env lvs_cont 
885
  = k (m env lvs_cont) env lvs_cont
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900

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)

901
902
903
904
905
906
907
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)

908
fixLne :: (a -> LneM a) -> LneM a
909
910
fixLne expr env lvs_cont
  = result
911
912
913
  where
    result = expr result env lvs_cont
\end{code}
914

915
Functions specific to this monad:
916

917
\begin{code}
918
getVarsLiveInCont :: LneM LiveInfo
919
920
getVarsLiveInCont env lvs_cont = lvs_cont

921
setVarsLiveInCont :: LiveInfo -> LneM a -> LneM a
922
923
924
925
926
927
928
929
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
930
931
lookupVarLne v env lvs_cont = returnLne (lookupBinding env v) env lvs_cont

932
933
934
getEnvLne :: LneM (IdEnv HowBound)
getEnvLne env lvs_cont = returnLne env env lvs_cont

935
936
937
lookupBinding :: IdEnv HowBound -> Id -> HowBound
lookupBinding env v = case lookupVarEnv env v of
			Just xx -> xx
938
			Nothing -> ASSERT2( isGlobalId v, ppr v ) ImportBound
939

940
941
942
943
944

-- 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.

945
freeVarsToLiveVars :: FreeVarsInfo -> LneM LiveInfo
946
freeVarsToLiveVars fvs env live_in_cont
947
  = returnLne live_info env live_in_cont
948
  where
949
950
    live_info    = foldr unionLiveInfo live_in_cont lvs_from_fvs
    lvs_from_fvs = map do_one (allFreeIds fvs)
951

952
953
954
955
    do_one (v, how_bound)
      = case how_bound of
	  ImportBound 		          -> unitLiveCaf v	-- Only CAF imports are 
								-- recorded in fvs
956
957
958
	  LetBound TopLet _ 		 
		| mayHaveCafRefs (idCafInfo v) -> unitLiveCaf v
		| otherwise		       -> emptyLiveInfo
959

960
961
	  LetBound (NestedLet lvs) _      -> lvs	-- lvs already contains v
							-- (see the invariant on NestedLet)
962

963
	  _lambda_or_case_binding	  -> unitLiveVar v	-- Bound by lambda or case
964
\end{code}
sof's avatar
sof committed
965

966
967
%************************************************************************
%*									*
968
\subsection[Free-var info]{Free variable information}
969
970
971
972
%*									*
%************************************************************************

\begin{code}
973
974
975
976
977
978
979
980
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
981
982
	--	      not put in the FreeVarsInfo for an expression.
	--	      See singletonFVInfo and freeVarsToLiveVars
983
	--
984
985
986
987
	-- 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.
988
989
	-- If f is mapped to noBinderInfo, that means
	-- that f *is* mentioned (else it wouldn't be in the
990
	-- IdEnv at all), but perhaps in an unsaturated applications.
991
992
993
994
995
996
997
	--
	-- 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
998
999
\end{code}

1000
\begin{code}
1001
1002
emptyFVInfo :: FreeVarsInfo
emptyFVInfo = emptyVarEnv
1003

1004
singletonFVInfo :: Id -> HowBound -> StgBinderInfo -> FreeVarsInfo
1005
-- Don't record non-CAF imports at all, to keep free-var sets small
1006
singletonFVInfo id ImportBound info
1007
   | mayHaveCafRefs (idCafInfo id) = unitVarEnv id (id, ImportBound, info)
1008
   | otherwise         		   = emptyVarEnv
1009
singletonFVInfo id how_bound info  = unitVarEnv id (id, how_bound, info)
1010

1011
1012
tyvarFVInfo :: TyVarSet -> FreeVarsInfo
tyvarFVInfo tvs = foldVarSet add emptyFVInfo tvs
1013
        where
1014
1015
	  add tv fvs = extendVarEnv fvs tv (tv, LambdaBound, noBinderInfo)
		-- Type variables must be lambda-bound
1016

1017
1018
unionFVInfo :: FreeVarsInfo -> FreeVarsInfo -> FreeVarsInfo
unionFVInfo fv1 fv2 = plusVarEnv_C plusFVInfo fv1 fv2
1019

1020
1021
unionFVInfos :: [FreeVarsInfo] -> FreeVarsInfo
unionFVInfos fvs = foldr unionFVInfo emptyFVInfo fvs
1022

1023
1024
1025
1026
minusFVBinders :: [Id] -> FreeVarsInfo -> FreeVarsInfo
minusFVBinders vs fv = foldr minusFVBinder fv vs

minusFVBinder :: Id -> FreeVarsInfo -> FreeVarsInfo
1027
minusFVBinder v fv | isId v && opt_RuntimeTypes
1028
		   = (fv `delVarEnv` v) `unionFVInfo` 
1029
1030
		     tyvarFVInfo (tyVarsOfType (idType v))
		   | otherwise = fv `delVarEnv` v
1031
1032
	-- When removing a binder, remember to add its type variables
	-- c.f. CoreFVs.delBinderFV
1033

1034
1035
elementOfFVInfo :: Id -> FreeVarsInfo -> Bool
elementOfFVInfo id fvs = maybeToBool (lookupVarEnv fvs id)
1036

1037
lookupFVInfo :: FreeVarsInfo -> Id -> StgBinderInfo
1038
1039
1040
-- Find how the given Id is used.
-- Externally visible things may be used any old how
lookupFVInfo fvs id 
1041
  | isExternalName (idName id) = noBinderInfo
1042
1043
  | otherwise = case lookupVarEnv fvs id of
			Nothing         -> noBinderInfo
1044
			Just (_,_,info) -> info
1045

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

1049
1050
-- Non-top-level things only, both type variables and ids
-- (type variables only if opt_RuntimeTypes)
1051
getFVs :: FreeVarsInfo -> [Var]	
1052
getFVs fvs = [id | (id, how_bound, _) <- varEnvElts fvs, 
1053
		    not (topLevelBound how_bound) ]
1054

1055
getFVSet :: FreeVarsInfo -> VarSet
1056
getFVSet fvs = mkVarSet (getFVs fvs)
1057

1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
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
1070
check_eq_li TopLet        TopLet        = True
1071
1072
check_eq_li li1 	  li2		= False
#endif
1073
1074
\end{code}

1075
Misc.
1076
\begin{code}
1077
1078
filterStgBinders :: [Var] -> [Var]
filterStgBinders bndrs
1079
  | opt_RuntimeTypes = bndrs
1080
1081
  | otherwise	     = filter isId bndrs
\end{code}
1082

1083
1084
1085

\begin{code}
	-- Ignore all notes except SCC
1086
1087
1088
1089
1090
myCollectBinders expr
  = go [] expr
  where
    go bs (Lam b e)          = go (b:bs) e
    go bs e@(Note (SCC _) _) = (reverse bs, e) 
1091
    go bs (Cast e co)        = go bs e
1092
1093
1094
    go bs (Note _ e)         = go bs e
    go bs e	             = (reverse bs, e)

1095
1096
1097
myCollectArgs :: CoreExpr -> (Id, [CoreArg])
	-- We assume that we only have variables
	-- in the function position by now
1098
1099
myCollectArgs expr
  = go expr []
1100
  where
1101
    go (Var v)          as = (v, as)
1102
    go (App f a) as        = go f (a:as)
1103
    go (Note (SCC _) e) as = pprPanic "CoreToStg.myCollectArgs" (ppr expr)
1104
    go (Cast e co)      as = go e as
1105
1106
    go (Note n e)       as = go e as
    go _		as = pprPanic "CoreToStg.myCollectArgs" (ppr expr)
1107
\end{code}
1108
1109

\begin{code}
1110
1111
1112
1113
stgArity :: Id -> HowBound -> Arity
stgArity f (LetBound _ arity) = arity
stgArity f ImportBound	      = idArity f
stgArity f LambdaBound        = 0
1114
\end{code}