CgClosure.lhs 30.2 KB
Newer Older
1
2
3
4
5
6
7
8
9
10
11
12
%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
%
\section[CgClosure]{Code generation for closures}

This module provides the support code for @StgToAbstractC@ to deal
with {\em closures} on the RHSs of let(rec)s.  See also
@CgCon@, which deals with constructors.

\begin{code}
#include "HsVersions.h"

13
module CgClosure ( cgTopRhsClosure, cgRhsClosure ) where
14

15
IMP_Ubiq(){-uitous-}
16
IMPORT_DELOOPER(CgLoop2)	( cgExpr )
17

18
19
import CgMonad
import AbsCSyn
20
import StgSyn
21

22
23
24
25
26
import AbsCUtils	( mkAbstractCs, getAmodeRep )
import CgBindery	( getCAddrMode, getArgAmodes,
			  getCAddrModeAndInfo, bindNewToNode,
			  bindNewToAStack, bindNewToBStack,
			  bindNewToReg, bindArgsToRegs,
27
			  stableAmodeIdInfo, heapIdInfo, CgIdInfo
28
29
30
31
			)
import CgCompInfo	( spARelToInt, spBRelToInt )
import CgUpdate		( pushUpdateFrame )
import CgHeapery	( allocDynClosure, heapCheck
32
			  , heapCheckOnly, fetchAndReschedule, yield  -- HWL
33
			)
34
import CgRetConv	( ctrlReturnConvAlg, dataReturnConvAlg, 
35
36
37
38
39
40
41
42
43
			  CtrlReturnConvention(..), DataReturnConvention(..)
			)
import CgStackery	( getFinalStackHW, mkVirtStkOffsets,
			  adjustRealSps
			)
import CgUsages		( getVirtSps, setRealAndVirtualSps,
			  getSpARelOffset, getSpBRelOffset,
			  getHpRelOffset
			)
44
45
46
47
import CLabel		( mkClosureLabel, mkConUpdCodePtrVecLabel,
			  mkStdUpdCodePtrVecLabel, mkStdUpdVecTblLabel,
			  mkErrorStdEntryLabel, mkRednCountsLabel
			)
48
import ClosureInfo	-- lots and lots of stuff
49
import CmdLineOpts	( opt_ForConcurrent, opt_GranMacros )
50
51
import CostCentre	( useCurrentCostCentre, currentOrSubsumedCosts,
			  noCostCentreAttached, costsAreSubsumed,
52
			  isCafCC, isDictCC, overheadCostCentre
53
			)
54
import HeapOffs		( SYN_IE(VirtualHeapOffset) )
55
56
57
58
import Id		( idType, idPrimRep, 
			  showId, getIdStrictness, dataConTag,
			  emptyIdSet,
			  GenId{-instance Outputable-}
59
60
			)
import ListSetOps	( minusList )
61
62
63
64
65
66
67
68
69
70
71
72
import Maybes		( maybeToBool )
import PprStyle		( PprStyle(..) )
import PprType		( GenType{-instance Outputable-}, TyCon{-ditto-} )
import Pretty		( prettyToUn, ppBesides, ppChar, ppPStr )
import PrimRep		( isFollowableRep, PrimRep(..) )
import TyCon		( isPrimTyCon, tyConDataCons )
import Unpretty		( uppShow )
import Util		( isIn, panic, pprPanic, assertPanic )

myWrapperMaybe = panic "CgClosure.myWrapperMaybe (ToDo)"
showTypeCategory = panic "CgClosure.showTypeCategory (ToDo)"
getWrapperArgTypeCategories = panic "CgClosure.getWrapperArgTypeCategories (ToDo)"
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
\end{code}

%********************************************************
%*							*
\subsection[closures-no-free-vars]{Top-level closures}
%*							*
%********************************************************

For closures bound at top level, allocate in static space.
They should have no free variables.

\begin{code}
cgTopRhsClosure :: Id
		-> CostCentre	-- Optional cost centre annotation
		-> StgBinderInfo
		-> [Id]		-- Args
89
		-> StgExpr
90
91
92
93
94
95
96
97
		-> LambdaFormInfo
		-> FCode (Id, CgIdInfo)

cgTopRhsClosure name cc binder_info args body lf_info
  = 	-- LAY OUT THE OBJECT
    let
	closure_info = layOutStaticNoFVClosure name lf_info
    in
98

99
	-- GENERATE THE INFO TABLE (IF NECESSARY)
100
    forkClosureBody (closureCodeBody binder_info closure_info
101
102
103
104
105
106
107
108
109
110
111
112
					 cc args body)
    							`thenC`

	-- BUILD VAP INFO TABLES IF NECESSARY
	-- Don't build Vap info tables etc for
	-- a function whose result is an unboxed type,
	-- because we can never have thunks with such a type.
    (if closureReturnsUnboxedType closure_info then
	nopC
    else
	let
	    bind_the_fun = addBindC name cg_id_info	-- It's global!
113
	in
114
115
116
117
118
119
120
121
122
	cgVapInfoTables True {- Top level -} bind_the_fun binder_info name args lf_info
    ) `thenC`

	-- BUILD THE OBJECT (IF NECESSARY)
    (if staticClosureRequired name binder_info lf_info
     then
	let
	    cost_centre = mkCCostCentre cc
	in
123
	absC (CStaticClosure
124
125
		closure_label	-- Labelled with the name on lhs of defn
		closure_info
126
	    	cost_centre
127
128
129
130
131
132
133
134
		[])		-- No fields
     else
	nopC
    ) `thenC`

    returnFC (name, cg_id_info)
  where
    closure_label = mkClosureLabel name
135
    cg_id_info    = stableAmodeIdInfo name (CLbl closure_label PtrRep) lf_info
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
\end{code}

%********************************************************
%*							*
\subsection[non-top-level-closures]{Non top-level closures}
%*							*
%********************************************************

For closures with free vars, allocate in heap.

===================== OLD PROBABLY OUT OF DATE COMMENTS =============

-- Closures which (a) have no fvs and (b) have some args (i.e.
-- combinator functions), are allocated statically, just as if they
-- were top-level closures.  We can't get a space leak that way
151
-- (because they are HNFs) and it saves allocation.
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174

-- Lexical Scoping: Problem
-- These top level function closures will be inherited, possibly
-- to a different cost centre scope set before entering.

-- Evaluation Scoping: ok as already in HNF

-- Should rely on floating mechanism to achieve this floating to top level.
-- As let floating will avoid floating which breaks cost centre attribution
-- everything will be OK.

-- Disabled: because it breaks lexical-scoped cost centre semantics.
-- cgRhsClosure binder cc bi [] upd_flag args@(_:_) body
--  = cgTopRhsClosure binder cc bi upd_flag args body

===================== END OF OLD PROBABLY OUT OF DATE COMMENTS =============

\begin{code}
cgRhsClosure	:: Id
		-> CostCentre	-- Optional cost centre annotation
		-> StgBinderInfo
		-> [Id]		-- Free vars
		-> [Id]		-- Args
175
		-> StgExpr
176
177
178
179
180
181
182
183
		-> LambdaFormInfo
		-> FCode (Id, CgIdInfo)

cgRhsClosure binder cc binder_info fvs args body lf_info
  | maybeToBool maybe_std_thunk		-- AHA!  A STANDARD-FORM THUNK
  -- ToDo: check non-primitiveness (ASSERT)
  = (
	-- LAY OUT THE OBJECT
184
    getArgAmodes std_thunk_payload		`thenFC` \ amodes ->
185
186
    let
	(closure_info, amodes_w_offsets)
187
	  = layOutDynClosure binder getAmodeRep amodes lf_info
188
189
190
191
192

	(use_cc, blame_cc) = chooseDynCostCentres cc args fvs body
    in
	-- BUILD THE OBJECT
    allocDynClosure closure_info use_cc blame_cc amodes_w_offsets
193
    )
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
		`thenFC` \ heap_offset ->

	-- RETURN
    returnFC (binder, heapIdInfo binder heap_offset lf_info)

  where
    maybe_std_thunk	   = getStandardFormThunkInfo lf_info
    Just std_thunk_payload = maybe_std_thunk
\end{code}

Here's the general case.
\begin{code}
cgRhsClosure binder cc binder_info fvs args body lf_info
  = (
  	-- LAY OUT THE OBJECT
	--
	-- If the binder is itself a free variable, then don't store
	-- it in the closure.  Instead, just bind it to Node on entry.
	-- NB we can be sure that Node will point to it, because we
	-- havn't told mkClosureLFInfo about this; so if the binder
	-- *was* a free var of its RHS, mkClosureLFInfo thinks it *is*
	-- stored in the closure itself, so it will make sure that
	-- Node points to it...
    let
	is_elem	       = isIn "cgRhsClosure"

220
221
222
223
	binder_is_a_fv = binder `is_elem` fvs
	reduced_fvs    = if binder_is_a_fv
			 then fvs `minusList` [binder]
			 else fvs
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
    in
    mapFCs getCAddrModeAndInfo reduced_fvs	`thenFC` \ amodes_and_info ->
    let
	fvs_w_amodes_and_info	      = reduced_fvs `zip` amodes_and_info

	closure_info :: ClosureInfo
	bind_details :: [((Id, (CAddrMode, LambdaFormInfo)), VirtualHeapOffset)]

	(closure_info, bind_details)
	  = layOutDynClosure binder get_kind fvs_w_amodes_and_info lf_info

	bind_fv ((id, (_, lf_info)), offset) = bindNewToNode id offset lf_info

	amodes_w_offsets = [(amode,offset) | ((_, (amode,_)), offset) <- bind_details]

239
	get_kind (id, amode_and_info) = idPrimRep id
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
    in
	-- BUILD ITS INFO TABLE AND CODE
    forkClosureBody (
		-- Bind the fvs
	    mapCs bind_fv bind_details `thenC`

	  	-- Bind the binder itself, if it is a free var
	    (if binder_is_a_fv then
		bindNewToReg binder node lf_info
	    else
		nopC)					`thenC`

		-- Compile the body
	    closureCodeBody binder_info closure_info cc args body
    )	`thenC`

	-- BUILD VAP INFO TABLES IF NECESSARY
	-- Don't build Vap info tables etc for
	-- a function whose result is an unboxed type,
	-- because we can never have thunks with such a type.
    (if closureReturnsUnboxedType closure_info then
	nopC
    else
	cgVapInfoTables False {- Not top level -} nopC binder_info binder args lf_info
    ) `thenC`

	-- BUILD THE OBJECT
    let
	(use_cc, blame_cc) = chooseDynCostCentres cc args fvs body
    in
    allocDynClosure closure_info use_cc blame_cc amodes_w_offsets
    )		`thenFC` \ heap_offset ->

	-- RETURN
    returnFC (binder, heapIdInfo binder heap_offset lf_info)
\end{code}

@cgVapInfoTables@ generates both Vap info tables, if they are required
at all.  It calls @cgVapInfoTable@ to generate each Vap info table,
along with its entry code.

\begin{code}
-- Don't generate Vap info tables for thunks; only for functions
cgVapInfoTables top_level perhaps_bind_the_fun binder_info fun [{- no args; a thunk! -}] lf_info
  = nopC

cgVapInfoTables top_level perhaps_bind_the_fun binder_info fun args lf_info
  = 	-- BUILD THE STANDARD VAP-ENTRY STUFF IF NECESSARY
    (if stdVapRequired binder_info then
	cgVapInfoTable perhaps_bind_the_fun Updatable fun args fun_in_payload lf_info
    else
	nopC
    )		`thenC`

		-- BUILD THE NO-UPDATE VAP-ENTRY STUFF IF NECESSARY
    (if noUpdVapRequired binder_info then
	cgVapInfoTable perhaps_bind_the_fun SingleEntry fun args fun_in_payload lf_info
    else
	nopC
    )

  where
    fun_in_payload = not top_level

cgVapInfoTable perhaps_bind_the_fun upd_flag fun args fun_in_payload fun_lf_info
  = let
	-- The vap_entry_rhs is a manufactured STG expression which
	-- looks like the RHS of any binding which is going to use the vap-entry
	-- point of the function.  Each of these bindings will look like:
	--
	--	x = [a,b,c] \upd [] -> f a b c
	--
	-- If f is not top-level, then f is one of the free variables too,
	-- hence "payload_ids" isn't the same as "arg_ids".
314
	--
315
	vap_entry_rhs = StgApp (StgVarArg fun) (map StgVarArg args) emptyIdSet
316
317
318
319
									-- Empty live vars

	arg_ids_w_info = [(name,mkLFArgument) | name <- args]
	payload_ids_w_info | fun_in_payload = (fun,fun_lf_info) : arg_ids_w_info
320
			   | otherwise	    = arg_ids_w_info
321
322
323
324
325

	payload_ids | fun_in_payload = fun : args		-- Sigh; needed for mkClosureLFInfo
		    | otherwise	     = args

	vap_lf_info   = mkClosureLFInfo False {-not top level-} payload_ids
326
					upd_flag [] vap_entry_rhs
327
		-- It's not top level, even if we're currently compiling a top-level
328
		-- function, because any VAP *use* of this function will be for a
329
330
331
332
		-- local thunk, thus
		--		let x = f p q	-- x isn't top level!
		--		in ...

333
	get_kind (id, info) = idPrimRep id
334
335

	payload_bind_details :: [((Id, LambdaFormInfo), VirtualHeapOffset)]
336
337
338
	(closure_info, payload_bind_details) = layOutDynClosure
							fun
							get_kind payload_ids_w_info
339
							vap_lf_info
340
		-- The dodgy thing is that we use the "fun" as the
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
		-- Id to give to layOutDynClosure.  This Id gets embedded in
		-- the closure_info it returns.  But of course, the function doesn't
		-- have the right type to match the Vap closure.  Never mind,
		-- a hack in closureType spots the special case.  Otherwise that
		-- Id is just used for label construction, which is OK.

	bind_fv ((id,lf_info), offset) = bindNewToNode id offset lf_info
    in

	-- BUILD ITS INFO TABLE AND CODE
    forkClosureBody (

		-- Bind the fvs; if the fun is not in the payload, then bind_the_fun tells
		-- how to bind it.  If it is in payload it'll be bound by payload_bind_details.
	    perhaps_bind_the_fun 		`thenC`
	    mapCs bind_fv payload_bind_details	`thenC`

		-- Generate the info table and code
	    closureCodeBody NoStgBinderInfo
			    closure_info
			    useCurrentCostCentre
			    [] 	-- No args; it's a thunk
			    vap_entry_rhs
    )
\end{code}
%************************************************************************
%*									*
\subsection[code-for-closures]{The code for closures}
%*									*
%************************************************************************

\begin{code}
closureCodeBody :: StgBinderInfo
		-> ClosureInfo	-- Lots of information about this closure
		-> CostCentre	-- Optional cost centre attached to closure
		-> [Id]
377
		-> StgExpr
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
		-> Code
\end{code}

There are two main cases for the code for closures.  If there are {\em
no arguments}, then the closure is a thunk, and not in normal form.
So it should set up an update frame (if it is shared).  Also, it has
no argument satisfaction check, so fast and slow entry-point labels
are the same.

\begin{code}
closureCodeBody binder_info closure_info cc [] body
  = -- thunks cannot have a primitive type!
#ifdef DEBUG
    let
	(has_tycon, tycon)
	  = case (closureType closure_info) of
	      Nothing       -> (False, panic "debug")
	      Just (tc,_,_) -> (True,  tc)
    in
    if has_tycon && isPrimTyCon tycon then
	pprPanic "closureCodeBody:thunk:prim type!" (ppr PprDebug tycon)
    else
#endif
401
402
403
404
405
    getAbsC body_code 	`thenFC` \ body_absC ->
    moduleName		`thenFC` \ mod_name ->

    absC (CClosureInfoAndCode closure_info body_absC Nothing
			      stdUpd (cl_descr mod_name)
406
			      (dataConLiveness closure_info))
407
408
409
  where
    cl_descr mod_name = closureDescription mod_name (closureId closure_info) [] body

410
    body_addr   = CLbl (entryLabelFromCI closure_info) CodePtrRep
411
412
    body_code   = profCtrC SLIT("ENT_THK") [] 			`thenC`
		  enterCostCentreCode closure_info cc IsThunk	`thenC`
413
		  thunkWrapper closure_info (cgExpr body)
414

415
    stdUpd      = CLbl mkErrorStdEntryLabel CodePtrRep
416
417
418
419
420
421
422
423
424
425
426
427
428
429
\end{code}

If there is {\em at least one argument}, then this closure is in
normal form, so there is no need to set up an update frame.  On the
other hand, we do have to check that there are enough args, and
perform an update if not!

The Macros for GrAnSim are produced at the beginning of the
argSatisfactionCheck (by calling fetchAndReschedule).  There info if
Node points to closure is available. -- HWL

\begin{code}
closureCodeBody binder_info closure_info cc all_args body
  = getEntryConvention id lf_info
430
		       (map idPrimRep all_args)		`thenFC` \ entry_conv ->
431
    let
432
433
	is_concurrent = opt_ForConcurrent

434
435
436
437
	stg_arity = length all_args

	-- Arg mapping for standard (slow) entry point; all args on stack
    	(spA_all_args, spB_all_args, all_bxd_w_offsets, all_ubxd_w_offsets)
438
	   = mkVirtStkOffsets
439
		0 0 		-- Initial virtual SpA, SpB
440
		idPrimRep
441
442
		all_args

443
	-- Arg mapping for the fast entry point; as many args as poss in
444
445
446
447
448
449
450
451
452
	-- registers; the rest on the stack
    	-- 	arg_regs are the registers used for arg passing
	-- 	stk_args are the args which are passed on the stack
	--
    	arg_regs = case entry_conv of
		DirectEntry lbl arity regs -> regs
    	    	ViaNode	| is_concurrent	   -> []
		other 		           -> panic "closureCodeBody:arg_regs"

453
454
455
456
	num_arg_regs = length arg_regs
	
    	(reg_args, stk_args) = splitAt num_arg_regs all_args

457
    	(spA_stk_args, spB_stk_args, stk_bxd_w_offsets, stk_ubxd_w_offsets)
458
	  = mkVirtStkOffsets
459
		0 0 		-- Initial virtual SpA, SpB
460
		idPrimRep
461
462
463
464
465
466
		stk_args

	-- HWL; Note: empty list of live regs in slow entry code
	-- Old version (reschedule combined with heap check);
	-- see argSatisfactionCheck for new version
	--slow_entry_code = forceHeapCheck [node] True slow_entry_code'
467
	--		  where node = VanillaReg PtrRep 1
468
469
470
471
	--slow_entry_code = forceHeapCheck [] True slow_entry_code'

    	slow_entry_code
      	  = profCtrC SLIT("ENT_FUN_STD") []		    `thenC`
472

473
474
475
476
477
478
479
		-- Bind args, and record expected position of stk ptrs
	    mapCs bindNewToAStack all_bxd_w_offsets	    `thenC`
	    mapCs bindNewToBStack all_ubxd_w_offsets	    `thenC`
	    setRealAndVirtualSps spA_all_args spB_all_args  `thenC`

	    argSatisfactionCheck closure_info all_args	    `thenC`

480
481
482
483
484
	    -- OK, so there are enough args.  Now we need to stuff as
	    -- many of them in registers as the fast-entry code
	    -- expects Note that the zipWith will give up when it hits
	    -- the end of arg_regs.

485
486
487
488
489
490
	    mapFCs getCAddrMode all_args		    `thenFC` \ stk_amodes ->
	    absC (mkAbstractCs (zipWith assign_to_reg arg_regs stk_amodes)) `thenC`

	    -- Now adjust real stack pointers
	    adjustRealSps spA_stk_args spB_stk_args		`thenC`

491
    	    absC (CFallThrough (CLbl fast_label CodePtrRep))
492
493
494
495
496
497
498
499

	assign_to_reg reg_id amode = CAssign (CReg reg_id) amode

	-- HWL
	-- Old version (reschedule combined with heap check);
	-- see argSatisfactionCheck for new version
	-- fast_entry_code = forceHeapCheck [] True fast_entry_code'

500
501
502
	fast_entry_code
	  = profCtrC SLIT("ENT_FUN_DIRECT") [
		    CLbl (mkRednCountsLabel id) PtrRep,
503
504
505
506
		    CString (_PK_ (showId PprDebug id)),
		    mkIntCLit stg_arity,	-- total # of args
		    mkIntCLit spA_stk_args,	-- # passed on A stk
		    mkIntCLit spB_stk_args,	-- B stk (rest in regs)
507
		    CString (_PK_ (map (showTypeCategory . idType) all_args)),
508
509
510
511
512
513
		    CString (_PK_ (show_wrapper_name wrapper_maybe)),
		    CString (_PK_ (show_wrapper_arg_kinds wrapper_maybe))
		]			`thenC`

		-- Bind args to regs/stack as appropriate, and
		-- record expected position of sps
514
	    bindArgsToRegs reg_args arg_regs		    `thenC`
515
516
517
518
519
520
521
522
523
524
525
	    mapCs bindNewToAStack stk_bxd_w_offsets	    `thenC`
	    mapCs bindNewToBStack stk_ubxd_w_offsets	    `thenC`
	    setRealAndVirtualSps spA_stk_args spB_stk_args  `thenC`

		-- Enter the closures cc, if required
	    enterCostCentreCode closure_info cc IsFunction  `thenC`

		-- Do the business
	    funWrapper closure_info arg_regs (cgExpr body)
    in
 	-- Make a labelled code-block for the slow and fast entry code
526
    forkAbsC (if slow_code_needed then slow_entry_code else absC AbsCNop)
527
528
529
				`thenFC` \ slow_abs_c ->
    forkAbsC fast_entry_code	`thenFC` \ fast_abs_c ->
    moduleName			`thenFC` \ mod_name ->
530

531
532
533
	-- Now either construct the info table, or put the fast code in alone
	-- (We never have slow code without an info table)
    absC (
534
      if info_table_needed then
535
	CClosureInfoAndCode closure_info slow_abs_c (Just fast_abs_c)
536
			stdUpd (cl_descr mod_name)
537
			(dataConLiveness closure_info)
538
      else
539
540
541
542
543
544
545
546
547
548
549
550
551
	CCodeBlock fast_label fast_abs_c
    )
  where
    lf_info = closureLFInfo closure_info

    cl_descr mod_name = closureDescription mod_name id all_args body

    	-- Figure out what is needed and what isn't
    slow_code_needed   = slowFunEntryCodeRequired id binder_info
    info_table_needed  = funInfoTableRequired id binder_info lf_info

	-- Manufacture labels
    id	       = closureId closure_info
552

553
554
    fast_label = fastLabelFromCI closure_info

555
    stdUpd = CLbl mkErrorStdEntryLabel CodePtrRep
556
557
558
559
560
561
562
563
564
565
566
567
568

    wrapper_maybe = get_ultimate_wrapper Nothing id
      where
    	get_ultimate_wrapper deflt x -- walk all the way up a "wrapper chain"
	  = case (myWrapperMaybe x) of
	      Nothing -> deflt
	      Just xx -> get_ultimate_wrapper (Just xx) xx

    show_wrapper_name Nothing   = ""
    show_wrapper_name (Just xx) = showId PprDebug xx

    show_wrapper_arg_kinds Nothing   = ""
    show_wrapper_arg_kinds (Just xx)
569
      = case (getWrapperArgTypeCategories (idType xx) (getIdStrictness xx)) of
570
571
572
573
574
575
576
577
578
579
580
581
582
	  Nothing  -> ""
	  Just str -> str
\end{code}

For lexically scoped profiling we have to load the cost centre from
the closure entered, if the costs are not supposed to be inherited.
This is done immediately on entering the fast entry point.

Load current cost centre from closure, if not inherited.
Node is guaranteed to point to it, if profiling and not inherited.

\begin{code}
data IsThunk = IsThunk | IsFunction -- Bool-like, local
583
584
585
#ifdef DEBUG
	deriving Eq
#endif
586
587
588
589
590
591
592

enterCostCentreCode :: ClosureInfo -> CostCentre -> IsThunk -> Code

enterCostCentreCode closure_info cc is_thunk
  = costCentresFlag	`thenFC` \ profiling_on ->
    if not profiling_on then
	nopC
593
    else
594
595
596
	ASSERT(not (noCostCentreAttached cc))

	if costsAreSubsumed cc then
597
598
599
600
601
602
603
604
605
606
607
608
609
610
	    ASSERT(isToplevClosure closure_info)
	    ASSERT(is_thunk == IsFunction)
	    costCentresC SLIT("ENTER_CC_FSUB") []

	else if currentOrSubsumedCosts cc then 
	    -- i.e. current; subsumed dealt with above
	    -- get CCC out of the closure, where we put it when we alloc'd
	    case is_thunk of 
		IsThunk    -> costCentresC SLIT("ENTER_CC_TCL") [CReg node]
		IsFunction -> costCentresC SLIT("ENTER_CC_FCL") [CReg node]

	else if isCafCC cc && isToplevClosure closure_info then
	    ASSERT(is_thunk == IsThunk)
	    costCentresC SLIT("ENTER_CC_CAF") [mkCCostCentre cc]
611
612

	else -- we've got a "real" cost centre right here in our hands...
613
614
615
616
617
	    case is_thunk of 
		IsThunk    -> costCentresC SLIT("ENTER_CC_T") [mkCCostCentre cc]
		IsFunction -> if isCafCC cc || isDictCC cc
			      then costCentresC SLIT("ENTER_CC_FCAF") [mkCCostCentre cc]
			      else costCentresC SLIT("ENTER_CC_FLOAD") [mkCCostCentre cc]
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
\end{code}

%************************************************************************
%*									*
\subsubsection[pre-closure-code-stuff]{Pre-closure-code code}
%*									*
%************************************************************************

The argument-satisfaction check code is placed after binding
the arguments to their stack locations. Hence, the virtual stack
pointer is pointing after all the args, and virtual offset 1 means
the base of frame and hence most distant arg.  Hence
virtual offset 0 is just beyond the most distant argument; the
relative offset of this word tells how many words of arguments
are expected.

\begin{code}
argSatisfactionCheck :: ClosureInfo -> [Id] -> Code

argSatisfactionCheck closure_info [] = nopC

argSatisfactionCheck closure_info args
  = -- safest way to determine which stack last arg will be on:
    -- look up CAddrMode that last arg is bound to;
642
643
    -- getAmodeRep;
    -- check isFollowableRep.
644
645
646

    nodeMustPointToIt (closureLFInfo closure_info) 	`thenFC` \ node_points ->

647
648
649
650
651
    let
       emit_gran_macros = opt_GranMacros
    in

    -- HWL  ngo' ngoq:
652
    -- absC (CMacroStmt GRAN_FETCH []) 			`thenC`
653
654
655
656
657
658
    -- forceHeapCheck [] node_points (absC AbsCNop)			`thenC`
    (if emit_gran_macros 
      then if node_points 
             then fetchAndReschedule  [] node_points 
             else yield [] node_points
      else absC AbsCNop)                       `thenC`
659
660
661

    getCAddrMode (last args) 				`thenFC` \ last_amode ->

662
663
    if (isFollowableRep (getAmodeRep last_amode)) then
	getSpARelOffset 0 	`thenFC` \ (SpARel spA off) ->
664
	let
665
666
	    a_rel_int = spARelToInt spA off
	    a_rel_arg = mkIntCLit a_rel_int
667
	in
668
	ASSERT(a_rel_int /= 0)
669
	if node_points then
670
	    absC (CMacroStmt ARGS_CHK_A [a_rel_arg])
671
	else
672
	    absC (CMacroStmt ARGS_CHK_A_LOAD_NODE [a_rel_arg, set_Node_to_this])
673
    else
674
675
	getSpBRelOffset 0 	`thenFC` \ (SpBRel spB off) ->
	let
676
677
	    b_rel_int = spBRelToInt spB off
	    b_rel_arg = mkIntCLit b_rel_int
678
	in
679
	ASSERT(b_rel_int /= 0)
680
	if node_points then
681
	    absC (CMacroStmt ARGS_CHK_B [b_rel_arg])
682
	else
683
	    absC (CMacroStmt ARGS_CHK_B_LOAD_NODE [b_rel_arg, set_Node_to_this])
684
685
686
687
688
  where
    -- We must tell the arg-satis macro whether Node is pointing to
    -- the closure or not.  If it isn't so pointing, then we give to
    -- the macro the (static) address of the closure.

689
    set_Node_to_this = CLbl (closureLabelFromCI closure_info) PtrRep
690
691
692
693
694
695
696
697
698
699
700
701
702
703
\end{code}

%************************************************************************
%*									*
\subsubsection[closure-code-wrappers]{Wrappers around closure code}
%*									*
%************************************************************************

\begin{code}
thunkWrapper:: ClosureInfo -> Code -> Code
thunkWrapper closure_info thunk_code
  = 	-- Stack and heap overflow checks
    nodeMustPointToIt (closureLFInfo closure_info)  	`thenFC` \ node_points ->

704
705
706
707
708
709
710
711
712
713
    let
       emit_gran_macros = opt_GranMacros
    in
    -- HWL: insert macros for GrAnSim; 2 versions depending on liveness of node
    -- (we prefer fetchAndReschedule-style context switches to yield ones)
    (if emit_gran_macros 
      then if node_points 
             then fetchAndReschedule  [] node_points 
             else yield [] node_points
      else absC AbsCNop)                       `thenC`
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728

    stackCheck closure_info [] node_points (	-- stackCheck *encloses* the rest

    -- Must be after stackCheck: if stchk fails new stack
    -- space has to be allocated from the heap

    heapCheck [] node_points (
					-- heapCheck *encloses* the rest
	-- The "[]" says there are no live argument registers

	-- Overwrite with black hole if necessary
    blackHoleIt closure_info 				`thenC`

	-- Push update frame if necessary
    setupUpdate closure_info (		-- setupUpdate *encloses* the rest
729
	thunk_code
730
731
732
733
734
735
736
737
738
    )))

funWrapper :: ClosureInfo 	-- Closure whose code body this is
	   -> [MagicId] 	-- List of argument registers (if any)
	   -> Code		-- Body of function being compiled
	   -> Code
funWrapper closure_info arg_regs fun_body
  = 	-- Stack overflow check
    nodeMustPointToIt (closureLFInfo closure_info)  	`thenFC` \ node_points ->
739
740
741
742
743
744
745
746
    let
       emit_gran_macros = opt_GranMacros
    in
    -- HWL   chu' ngoq:
    (if emit_gran_macros
      then yield  arg_regs node_points
      else absC AbsCNop)                                 `thenC`

747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
    stackCheck closure_info arg_regs node_points (	-- stackCheck *encloses* the rest

	-- Heap overflow check
    heapCheck arg_regs node_points (
					-- heapCheck *encloses* the rest

	-- Finally, do the business
    fun_body
    ))
\end{code}

%************************************************************************
%*									*
\subsubsubsection[overflow-checks]{Stack and heap overflow wrappers}
%*									*
%************************************************************************

Assumption: virtual and real stack pointers are currently exactly aligned.

\begin{code}
767
stackCheck :: ClosureInfo
768
769
	   -> [MagicId] 		-- Live registers
	   -> Bool 			-- Node required to point after check?
770
	   -> Code
771
772
773
774
	   -> Code

stackCheck closure_info regs node_reqd code
  = getFinalStackHW (\ aHw -> \ bHw ->	-- Both virtual stack offsets
775

776
777
778
779
780
781
782
783
784
785
786
787
    getVirtSps		`thenFC` \ (vSpA, vSpB) ->

    let a_headroom_reqd = aHw - vSpA	-- Virtual offsets are positive integers
	b_headroom_reqd = bHw - vSpB
    in

    absC (if (a_headroom_reqd == 0 && b_headroom_reqd == 0) then
		AbsCNop
	  else
		CMacroStmt STK_CHK [mkIntCLit liveness_mask,
				    mkIntCLit a_headroom_reqd,
				    mkIntCLit b_headroom_reqd,
788
				    mkIntCLit vSpA,
789
790
791
792
793
794
795
796
797
798
				    mkIntCLit vSpB,
				    mkIntCLit (if returns_prim_type then 1 else 0),
				    mkIntCLit (if node_reqd         then 1 else 0)]
    	 )
	-- The test is *inside* the absC, to avoid black holes!

    `thenC` code
    )
  where
    all_regs = if node_reqd then node:regs else regs
799
    liveness_mask = mkLiveRegsMask all_regs
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834

    returns_prim_type = closureReturnsUnboxedType closure_info
\end{code}

%************************************************************************
%*									*
\subsubsubsection[update-and-BHs]{Update and black-hole wrappers}
%*									*
%************************************************************************


\begin{code}
blackHoleIt :: ClosureInfo -> Code	-- Only called for thunks
blackHoleIt closure_info
  = noBlackHolingFlag	`thenFC` \ no_black_holing ->

    if (blackHoleOnEntry no_black_holing closure_info)
    then
	absC (if closureSingleEntry(closure_info) then
		CMacroStmt UPD_BH_SINGLE_ENTRY [CReg node]
	      else
		CMacroStmt UPD_BH_UPDATABLE [CReg node])
	-- Node always points to it; see stg-details
    else
	nopC
\end{code}

\begin{code}
setupUpdate :: ClosureInfo -> Code -> Code	-- Only called for thunks
	-- Nota Bene: this function does not change Node (even if it's a CAF),
	-- so that the cost centre in the original closure can still be
	-- extracted by a subsequent ENTER_CC_TCL

setupUpdate closure_info code
 = if (closureUpdReqd closure_info) then
835
	link_caf_if_needed	`thenFC` \ update_closure ->
836
    	pushUpdateFrame update_closure vector code
837
   else
838
	profCtrC SLIT("UPDF_OMITTED") [] `thenC`
839
840
841
842
843
844
845
846
847
848
849
850
851
852
	code
 where
   link_caf_if_needed :: FCode CAddrMode	-- Returns amode for closure to be updated
   link_caf_if_needed
     = if not (isStaticClosure closure_info) then
	  returnFC (CReg node)
       else

	  -- First we must allocate a black hole, and link the
	  -- CAF onto the CAF list

		-- Alloc black hole specifying CC_HDR(Node) as the cost centre
		--   Hack Warning: Using a CLitLit to get CAddrMode !
	  let
853
	      use_cc   = CLitLit SLIT("CC_HDR(R1.p)") PtrRep
854
855
856
857
	      blame_cc = use_cc
	  in
	  allocDynClosure (blackHoleClosureInfo closure_info) use_cc blame_cc []
							`thenFC` \ heap_offset ->
858
	  getHpRelOffset heap_offset			`thenFC` \ hp_rel ->
859
860
861
862
863
864
	  let  amode = CAddr hp_rel
	  in
	  absC (CMacroStmt UPD_CAF [CReg node, amode])
						  	`thenC`
	  returnFC amode

865
   vector
866
     = case (closureType closure_info) of
867
868
    	Nothing -> CReg StdUpdRetVecReg
    	Just (spec_tycon, _, spec_datacons) ->
869
	    case (ctrlReturnConvAlg spec_tycon) of
870
    	      UnvectoredReturn 1 ->
871
872
       	    	let
		    spec_data_con = head spec_datacons
873
		    only_tag = dataConTag spec_data_con
874

875
    	    	    direct = case (dataReturnConvAlg spec_data_con) of
876
877
    	    	        ReturnInRegs _ -> mkConUpdCodePtrVecLabel spec_tycon only_tag
    	    	    	ReturnInHeap   -> mkStdUpdCodePtrVecLabel spec_tycon only_tag
878

879
880
881
882
883
    	    	    vectored = mkStdUpdVecTblLabel spec_tycon
    	    	in
    	    	    CUnVecLbl direct vectored

	      UnvectoredReturn _ -> CReg StdUpdRetVecReg
884
	      VectoredReturn _   -> CLbl (mkStdUpdVecTblLabel spec_tycon) DataPtrRep
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
\end{code}

%************************************************************************
%*									*
\subsection[CgClosure-Description]{Profiling Closure Description.}
%*									*
%************************************************************************

For "global" data constructors the description is simply occurrence
name of the data constructor itself (see \ref{CgConTbls-info-tables}).

Otherwise it is determind by @closureDescription@ from the let
binding information.

\begin{code}
closureDescription :: FAST_STRING	-- Module
		   -> Id		-- Id of closure binding
		   -> [Id]		-- Args
903
		   -> StgExpr	-- Body
904
905
906
907
908
		   -> String

	-- Not called for StgRhsCon which have global info tables built in
	-- CgConTbls.lhs with a description generated from the data constructor

909
910
closureDescription mod_name name args body
  = uppShow 0 (prettyToUn (
911
912
913
914
915
	ppBesides [ppChar '<',
		   ppPStr mod_name,
		   ppChar '.',
		   ppr PprDebug name,
		   ppChar '>']))
916
917
918
919
920
921
922
923
924
925
926
927
\end{code}

\begin{code}
chooseDynCostCentres cc args fvs body
  = let
	use_cc -- cost-centre we record in the object
	  = if currentOrSubsumedCosts cc
	    then CReg CurCostCentre
	    else mkCCostCentre cc

	blame_cc -- cost-centre on whom we blame the allocation
	  = case (args, fvs, body) of
928
929
930
	      ([], [just1], StgApp (StgVarArg fun) [{-no args-}] _)
		| just1 == fun
		-> mkCCostCentre overheadCostCentre
931
	      _ -> use_cc
932

933
934
935
936
937
938
	    -- if it's an utterly trivial RHS, then it must be
	    -- one introduced by boxHigherOrderArgs for profiling,
	    -- so we charge it to "OVERHEAD".
    in
    (use_cc, blame_cc)
\end{code}