CgClosure.lhs 20.5 KB
Newer Older
1
%
2 3
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
4
% $Id: CgClosure.lhs,v 1.59 2002/12/11 15:36:25 simonmar Exp $
5 6 7 8 9 10 11 12
%
\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}
13 14 15 16
module CgClosure ( cgTopRhsClosure, 
		   cgStdRhsClosure, 
		   cgRhsClosure, 
		   closureCodeBody ) where
17

18 19
#include "HsVersions.h"

sof's avatar
sof committed
20
import {-# SOURCE #-} CgExpr ( cgExpr )
21

22
import CgMonad
23
import CgBindery
24
import CgUpdate		( pushUpdateFrame )
25 26 27
import CgHeapery
import CgStackery
import CgUsages
28
import ClosureInfo	-- lots and lots of stuff
29 30 31 32 33 34

import AbsCUtils	( getAmodeRep, mkAbstractCs )
import AbsCSyn
import CLabel

import StgSyn
35
import CmdLineOpts	( opt_GranMacros, opt_SccProfilingOn, opt_DoTickyProfiling )
36
import CostCentre	
37
import Id		( Id, idName, idType, idPrimRep )
38
import Name		( Name, isInternalName )
sof's avatar
sof committed
39
import Module		( Module, pprModule )
40
import ListSetOps	( minusList )
41
import PrimRep		( PrimRep(..), getPrimRepSize )
42
import PprType          ( showTypeCategory )
sof's avatar
sof committed
43
import Util		( isIn, splitAtList )
44
import CmdLineOpts	( opt_SccProfilingOn )
45
import Outputable
46
import FastString
47

48 49
import Name             ( nameOccName )
import OccName          ( occNameFS )
50 51 52 53 54 55 56 57 58 59 60 61 62
\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
63
		-> CostCentreStack	-- Optional cost centre annotation
64
		-> StgBinderInfo
65
		-> SRT
66
		-> [Id]		-- Args
67
		-> StgExpr
68 69 70
		-> LambdaFormInfo
		-> FCode (Id, CgIdInfo)

71
cgTopRhsClosure id ccs binder_info srt args body lf_info
72 73
  = 
    -- LAY OUT THE OBJECT
74
    getSRTInfo srt		`thenFC` \ srt_info ->
75
    moduleName			`thenFC` \ mod_name ->
76
    let
77
    	name          = idName id
78 79
	descr         = closureDescription mod_name name
	closure_info  = layOutStaticNoFVClosure id lf_info srt_info descr
80
	closure_label = mkClosureLabel name
81
    	cg_id_info    = stableAmodeIdInfo id (CLbl closure_label PtrRep) lf_info
82
    in
83

84
	-- BUILD THE OBJECT (IF NECESSARY)
85 86 87
    (
     ({- if staticClosureRequired name binder_info lf_info
      then -}
88
	absC (mkStaticClosure closure_label closure_info ccs [] True)
89
      {- else
90
	nopC -}
91
     )
92 93 94
    							`thenC`

	-- GENERATE THE INFO TABLE (IF NECESSARY)
95
    forkClosureBody (closureCodeBody binder_info closure_info
96 97
					 ccs args body)

98 99
    ) `thenC`

100
    returnFC (id, cg_id_info)
101

102 103 104 105 106 107 108 109 110 111 112
\end{code}

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

For closures with free vars, allocate in heap.

\begin{code}
113 114 115 116 117 118 119 120 121 122 123
cgStdRhsClosure
	:: Id
	-> CostCentreStack	-- Optional cost centre annotation
	-> StgBinderInfo
	-> [Id]			-- Free vars
	-> [Id]			-- Args
	-> StgExpr
	-> LambdaFormInfo
	-> [StgArg]		-- payload
	-> FCode (Id, CgIdInfo)

124
cgStdRhsClosure binder cc binder_info fvs args body lf_info payload
125
		-- AHA!  A STANDARD-FORM THUNK
126 127
  = (
	-- LAY OUT THE OBJECT
128 129
    getArgAmodes payload		`thenFC` \ amodes ->
    moduleName				`thenFC` \ mod_name ->
130
    let
131 132
	descr = closureDescription mod_name (idName binder)

133
	(closure_info, amodes_w_offsets)
134
	  = layOutDynClosure binder getAmodeRep amodes lf_info NoC_SRT descr
135
		-- No SRT for a standard-form closure
136 137 138

	(use_cc, blame_cc) = chooseDynCostCentres cc args fvs body
    in
139

140 141
	-- BUILD THE OBJECT
    allocDynClosure closure_info use_cc blame_cc amodes_w_offsets
142
    )
143 144 145 146 147 148 149
		`thenFC` \ heap_offset ->

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

Here's the general case.
150

151
\begin{code}
152 153 154
cgRhsClosure	:: Id
		-> CostCentreStack	-- Optional cost centre annotation
		-> StgBinderInfo
155
		-> SRT
156 157 158 159 160 161
		-> [Id]			-- Free vars
		-> [Id]			-- Args
		-> StgExpr
		-> LambdaFormInfo
		-> FCode (Id, CgIdInfo)

162
cgRhsClosure binder cc binder_info srt fvs args body lf_info
163 164 165 166 167 168 169 170 171 172 173 174 175
  = (
  	-- 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"

176 177 178 179
	binder_is_a_fv = binder `is_elem` fvs
	reduced_fvs    = if binder_is_a_fv
			 then fvs `minusList` [binder]
			 else fvs
180
    in
181

182
    mapFCs getCAddrModeAndInfo reduced_fvs	`thenFC` \ fvs_w_amodes_and_info ->
183
    getSRTInfo srt				`thenFC` \ srt_info ->
184
    moduleName					`thenFC` \ mod_name ->
185
    let
186 187
	descr = closureDescription mod_name (idName binder)

188
	closure_info :: ClosureInfo
189
	bind_details :: [((Id, CAddrMode, LambdaFormInfo), VirtualHeapOffset)]
190 191

	(closure_info, bind_details)
192 193
	  = layOutDynClosure binder get_kind
			     fvs_w_amodes_and_info lf_info srt_info descr
194

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

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

199
	get_kind (id, _, _) = idPrimRep id
200
    in
201

202 203 204 205 206 207 208 209 210 211 212 213
	-- 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
214
	    closureCodeBody binder_info closure_info cc args body
215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235
    )	`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}

%************************************************************************
%*									*
\subsection[code-for-closures]{The code for closures}
%*									*
%************************************************************************

\begin{code}
closureCodeBody :: StgBinderInfo
236 237
		-> ClosureInfo	   -- Lots of information about this closure
		-> CostCentreStack -- Optional cost centre attached to closure
238
		-> [Id]
239
		-> StgExpr
240 241 242 243 244
		-> 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.
245
So it should set up an update frame (if it is shared).
246 247

\begin{code}
248
closureCodeBody binder_info closure_info cc [] body
249
  = -- thunks cannot have a primitive type!
250 251
    getAbsC body_code 	`thenFC` \ body_absC ->

252
    absC (CClosureInfoAndCode closure_info body_absC)
253
  where
254 255
    is_box  = case body of { StgApp fun [] -> True; _ -> False }

njn's avatar
njn committed
256
    ticky_ent_lit = if (isStaticClosure closure_info)
257 258
                    then FSLIT("TICK_ENT_STATIC_THK")
                    else FSLIT("TICK_ENT_DYN_THK")
njn's avatar
njn committed
259 260

    body_code   = profCtrC ticky_ent_lit []			`thenC`
261 262
		  -- node always points when profiling, so this is ok:
		  ldvEnter					`thenC`
263
		  thunkWrapper closure_info (
264 265 266 267
			-- We only enter cc after setting up update so
			-- that cc of enclosing scope will be recorded
			-- in update frame CAF/DICT functions will be
			-- subsumed by this enclosing cc
268
		    enterCostCentreCode closure_info cc IsThunk	is_box `thenC`
269 270
		    cgExpr body
		  )
njn's avatar
njn committed
271

272 273
\end{code}

274 275
If there is /at least one argument/, then this closure is in
normal form, so there is no need to set up an update frame.
276 277 278 279 280 281

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}
282
closureCodeBody binder_info closure_info cc all_args body
283
  = let arg_reps = map idPrimRep all_args in
284

285
    getEntryConvention name lf_info arg_reps  `thenFC` \ entry_conv ->
286

287
    let
288
	-- Arg mapping for the entry point; as many args as poss in
289 290 291 292
	-- 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
	--
293
	-- Args passed on the stack are not tagged.
294
	--
295 296
    	arg_regs = case entry_conv of
		DirectEntry lbl arity regs -> regs
297 298
		_ -> panic "closureCodeBody"
    in
299

300 301 302 303 304 305 306 307 308
    -- If this function doesn't have a specialised ArgDescr, we need
    -- to generate the function's arg bitmap, slow-entry code, and
    -- register-save code for the heap-check failure
    --
    (case closureFunInfo closure_info of
	Just (_, ArgGen slow_lbl liveness) -> 
		absC (CBitmap liveness) `thenC`
		absC (mkSlowEntryCode name slow_lbl arg_regs arg_reps) `thenC`
		returnFC (mkRegSaveCode arg_regs arg_reps)
309

310 311 312
	other -> returnFC AbsCNop
     )		
	`thenFC` \ reg_save_code ->
313

314 315 316
    -- get the current virtual Sp (it might not be zero, eg. if we're
    -- compiling a let-no-escape).
    getVirtSp `thenFC` \vSp ->
317

318 319
    let
    	(reg_args, stk_args) = splitAtList arg_regs all_args
320

321 322
    	(sp_stk_args, stk_offsets)
	  = mkVirtStkOffsets vSp idPrimRep stk_args
323

324
	entry_code = do
rje's avatar
rje committed
325
		mod_name <- moduleName
326
		profCtrC FSLIT("TICK_CTR") [ 
rje's avatar
rje committed
327
			CLbl ticky_ctr_label DataPtrRep,
328
			mkCString (mkFastString (ppr_for_ticky_name mod_name name)),
rje's avatar
rje committed
329 330
			mkIntCLit stg_arity,	-- total # of args
			mkIntCLit sp_stk_args,	-- # passed on stk
331
			mkCString (mkFastString (map (showTypeCategory . idType) all_args))
rje's avatar
rje committed
332 333
			] 
		let prof = 
334
			profCtrC ticky_ent_lit [
rje's avatar
rje committed
335 336
				CLbl ticky_ctr_label DataPtrRep
			] 
337

338
		-- Bind args to regs/stack as appropriate, and
339
		-- record expected position of sps.
rje's avatar
rje committed
340 341 342
		bindArgsToRegs reg_args arg_regs		    
		mapCs bindNewToStack stk_offsets		    
		setRealAndVirtualSp sp_stk_args		    
343

344
		-- Enter the closures cc, if required
rje's avatar
rje committed
345
		enterCostCentreCode closure_info cc IsFunction False
346 347

		-- Do the business
348
		funWrapper closure_info arg_regs reg_save_code
rje's avatar
rje committed
349
			(prof >> cgExpr body)
350
    in
351 352 353

    setTickyCtrLabel ticky_ctr_label (

354
      forkAbsC entry_code	`thenFC` \ entry_abs_c ->
355
      moduleName		`thenFC` \ mod_name ->
356

357 358
      -- Now construct the info table
      absC (CClosureInfoAndCode closure_info entry_abs_c)
359 360
    )
  where
361 362
    ticky_ctr_label = mkRednCountsLabel name

363
    ticky_ent_lit = 
njn's avatar
njn committed
364
        if (isStaticClosure closure_info)
365 366
        then FSLIT("TICK_ENT_STATIC_FUN_DIRECT")
        else FSLIT("TICK_ENT_DYN_FUN_DIRECT")
njn's avatar
njn committed
367
        
368
    stg_arity = length all_args
369 370 371
    lf_info = closureLFInfo closure_info

	-- Manufacture labels
372
    name       = closureName closure_info
373 374 375 376 377 378


-- When printing the name of a thing in a ticky file, we want to
-- give the module name even for *local* things.   We print
-- just "x (M)" rather that "M.x" to distinguish them from the global kind.
ppr_for_ticky_name mod_name name
379
  | isInternalName name = showSDocDebug (ppr name <+> (parens (ppr mod_name)))
380
  | otherwise	     = showSDocDebug (ppr name)
381 382
\end{code}

383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423
The "slow entry" code for a function.  This entry point takes its
arguments on the stack.  It loads the arguments into registers
according to the calling convention, and jumps to the function's
normal entry point.  The function's closure is assumed to be in
R1/node.

The slow entry point is used in two places:

 (a) unknown calls: eg. stg_PAP_entry 
 (b) returning from a heap-check failure

\begin{code}
mkSlowEntryCode :: Name -> CLabel -> [MagicId] -> [PrimRep] -> AbstractC
mkSlowEntryCode name lbl regs reps
   = CCodeBlock lbl (
	mkAbstractCs [assts, stk_adj, jump]
      )
  where
     stk_offsets = scanl (\off rep -> off - getPrimRepSize rep) 0 reps

     assts = mkAbstractCs (zipWith3 mk_asst reps regs stk_offsets)
     mk_asst rep reg offset = CAssign (CReg reg) (CVal (spRel 0 offset) rep)

     stk_adj = CAssign (CReg Sp) (CAddr (spRel 0 stk_final_offset))
     stk_final_offset = head (drop (length regs) stk_offsets)

     jump = CJump (CLbl (mkEntryLabel name) CodePtrRep)

mkRegSaveCode :: [MagicId] -> [PrimRep] -> AbstractC
mkRegSaveCode regs reps 
  = mkAbstractCs [stk_adj, assts]
  where
     stk_adj = CAssign (CReg Sp) (CAddr (spRel 0 (negate stk_final_offset)))

     stk_final_offset = head (drop (length regs) stk_offsets)
     stk_offsets = scanl (\off rep -> off - getPrimRepSize rep) 0 reps

     assts = mkAbstractCs (zipWith3 mk_asst reps regs stk_offsets)
     mk_asst rep reg offset = CAssign (CVal (spRel 0 offset) rep) (CReg reg) 
\end{code}

424 425 426 427 428 429 430 431 432
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
433
-- #ifdef DEBUG
434
	deriving Eq
435
-- #endif
436

437 438 439 440 441
enterCostCentreCode 
   :: ClosureInfo -> CostCentreStack
   -> IsThunk
   -> Bool	-- is_box: this closure is a special box introduced by SCCfinal
   -> Code
442

443
enterCostCentreCode closure_info ccs is_thunk is_box
444
  = if not opt_SccProfilingOn then
445
	nopC
446
    else
447
	ASSERT2(not (noCCSAttached ccs), ppr (closureName closure_info) <+> ppr ccs)
448

449
	if isSubsumedCCS ccs then
450 451
	    ASSERT(isToplevClosure closure_info)
	    ASSERT(is_thunk == IsFunction)
452
	    costCentresC FSLIT("ENTER_CCS_FSUB") []
453
 
454
	else if isDerivedFromCurrentCCS ccs then 
455
	    if re_entrant && not is_box
456 457
		then costCentresC FSLIT("ENTER_CCS_FCL") [CReg node]
		else costCentresC FSLIT("ENTER_CCS_TCL") [CReg node]
458

459 460
	else if isCafCCS ccs then
	    ASSERT(isToplevClosure closure_info)
461
	    ASSERT(is_thunk == IsThunk)
462 463
		-- might be a PAP, in which case we want to subsume costs
	    if re_entrant
464 465
		then costCentresC FSLIT("ENTER_CCS_FSUB") []
		else costCentresC FSLIT("ENTER_CCS_CAF") c_ccs
466

467 468
	else panic "enterCostCentreCode"

469 470
   where
	c_ccs = [mkCCostCentreStack ccs]
471
	re_entrant = closureReEntrant closure_info
472 473 474 475 476 477 478 479 480
\end{code}

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

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

486 487 488 489 490 491 492
    -- HWL: insert macros for GrAnSim; 2 versions depending on liveness of node
    -- (we prefer fetchAndReschedule-style context switches to yield ones)
    (if opt_GranMacros
       then if node_points 
              then fetchAndReschedule [] node_points 
              else yield [] node_points
       else absC AbsCNop)                       `thenC`
493

494 495 496 497 498
    let closure_lbl
		| node_points = Nothing
		| otherwise   = Just (closureLabelFromCI closure_info)
    in

499
        -- stack and/or heap checks
500
    thunkChecks closure_lbl (
501 502

	-- Overwrite with black hole if necessary
503
    blackHoleIt closure_info node_points  `thenC`
504

505 506 507 508
    setupUpdate closure_info (			-- setupUpdate *encloses* the rest

	-- Finally, do the business
    thunk_code
509
    ))
510 511 512

funWrapper :: ClosureInfo 	-- Closure whose code body this is
	   -> [MagicId] 	-- List of argument registers (if any)
513
	   -> AbstractC		-- reg saves for the heap check failure
514 515
	   -> Code		-- Body of function being compiled
	   -> Code
516
funWrapper closure_info arg_regs reg_save_code fun_body
517
  = 	-- Stack overflow check
518 519 520 521 522
    nodeMustPointToIt (closureLFInfo closure_info)  `thenFC` \ node_points ->

    -- enter for Ldv profiling
    (if node_points then ldvEnter else nopC)	    `thenC`

523 524
    (if opt_GranMacros
       then yield arg_regs node_points
525
       else absC AbsCNop)                           `thenC`
526

527 528 529 530 531
    let closure_lbl
		| node_points = Nothing
		| otherwise   = Just (closureLabelFromCI closure_info)
    in

532
        -- heap and/or stack checks
533
    funEntryChecks closure_lbl reg_save_code (
534 535 536 537 538 539

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

540

541 542 543 544 545 546 547 548
%************************************************************************
%*									*
\subsubsubsection[update-and-BHs]{Update and black-hole wrappers}
%*									*
%************************************************************************


\begin{code}
549 550
blackHoleIt :: ClosureInfo -> Bool -> Code	-- Only called for closures with no args

551 552
blackHoleIt closure_info node_points
  = if blackHoleOnEntry closure_info && node_points
553
    then
554 555 556 557
	let
	  info_label = infoTableLabelFromCI closure_info
	  args = [ CLbl info_label DataPtrRep ]
	in
558
	absC (if closureSingleEntry(closure_info) then
559
		CMacroStmt UPD_BH_SINGLE_ENTRY args
560
	      else
561
		CMacroStmt UPD_BH_UPDATABLE args)
562 563 564 565 566
    else
	nopC
\end{code}

\begin{code}
567
setupUpdate :: ClosureInfo -> Code -> Code	-- Only called for closures with no args
568 569 570 571
	-- 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

572 573
-- I've tidied up the code for this function, but it should still do the same as
-- it did before (modulo ticky stuff).  KSW 1999-04.
574
setupUpdate closure_info code
575 576 577
 = if closureReEntrant closure_info
   then
     code
578
   else
579
     case (closureUpdReqd closure_info, isStaticClosure closure_info) of
580
       (False,False) -> profCtrC FSLIT("TICK_UPDF_OMITTED") [] `thenC`
581 582 583 584 585 586 587
	                code
       (False,True ) -> (if opt_DoTickyProfiling
                         then
                         -- blackhole the SE CAF
                           link_caf seCafBlackHoleClosureInfo `thenFC` \ _ -> nopC
                         else
                           nopC)                                                       `thenC`
588 589
                        profCtrC FSLIT("TICK_UPD_CAF_BH_SINGLE_ENTRY") [mkCString cl_name] `thenC`
                        profCtrC FSLIT("TICK_UPDF_OMITTED") []                           `thenC`
590 591 592 593
	                code
       (True ,False) -> pushUpdateFrame (CReg node) code
       (True ,True ) -> -- blackhole the (updatable) CAF:
                        link_caf cafBlackHoleClosureInfo           `thenFC` \ update_closure ->
594
                        profCtrC FSLIT("TICK_UPD_CAF_BH_UPDATABLE") [mkCString cl_name]    `thenC`
595
                        pushUpdateFrame update_closure code
596
 where
597
   cl_name :: FastString
598 599 600 601 602 603 604 605 606 607 608 609
   cl_name  = (occNameFS . nameOccName . closureName) closure_info

   link_caf :: (ClosureInfo -> ClosureInfo)  -- function yielding BH closure_info
            -> FCode CAddrMode	             -- Returns amode for closure to be updated
   link_caf bhCI
     = -- To update a CAF we must allocate a black hole, link the CAF onto the
       -- CAF list, then update the CAF to point to the fresh black hole.
       -- This function returns the address of the black hole, so it can be
       -- updated with the new value when available.

             -- Alloc black hole specifying CC_HDR(Node) as the cost centre
       let
610
           use_cc   = CMacroExpr PtrRep CCS_HDR [nodeReg]
611 612 613 614 615 616 617 618
           blame_cc = use_cc
       in
       allocDynClosure (bhCI closure_info) use_cc blame_cc []  `thenFC` \ heap_offset ->
       getHpRelOffset heap_offset                              `thenFC` \ hp_rel ->
       let  amode = CAddr hp_rel
       in
       absC (CMacroStmt UPD_CAF [CReg node, amode])            `thenC`
       returnFC amode
619 620 621 622 623 624 625 626 627 628 629 630 631 632 633
\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}
634
closureDescription :: Module		-- Module
635
		   -> Name		-- Id of closure binding
636 637 638 639 640
		   -> String

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

641
closureDescription mod_name name
642
  = showSDoc (
sof's avatar
sof committed
643
	hcat [char '<',
644
		   pprModule mod_name,
sof's avatar
sof committed
645
		   char '.',
646
		   ppr name,
sof's avatar
sof committed
647
		   char '>'])
648
\end{code}
649
  
650
\begin{code}
651
chooseDynCostCentres ccs args fvs body
652 653
  = let
	use_cc -- cost-centre we record in the object
654
	  = if currentOrSubsumedCCS ccs
655
	    then CReg CurCostCentre
656
	    else mkCCostCentreStack ccs
657 658 659

	blame_cc -- cost-centre on whom we blame the allocation
	  = case (args, fvs, body) of
660
	      ([], _, StgApp fun [{-no args-}])
661
		-> mkCCostCentreStack overheadCCS
662
	      _ -> use_cc
663

664 665 666
	    -- if it's an utterly trivial RHS, then it must be
	    -- one introduced by boxHigherOrderArgs for profiling,
	    -- so we charge it to "OVERHEAD".
667 668

	    -- This looks like a HACK to me --SDM
669 670 671
    in
    (use_cc, blame_cc)
\end{code}