CgClosure.lhs 20.7 KB
Newer Older
1
%
Simon Marlow's avatar
Simon Marlow committed
2
% (c) The University of Glasgow 2006
3
4
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
5
6
7
8
9
10
11
\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}
12
13
module CgClosure ( cgTopRhsClosure, 
		   cgStdRhsClosure, 
14
		   cgRhsClosure,
15
		   emitBlackHoleCode,
16
		   ) where
17

18
19
#include "HsVersions.h"

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

22
import CgMonad
23
24
import CgBindery
import CgHeapery
Simon Marlow's avatar
Simon Marlow committed
25
26
import CgStackery
import CgProf
27
import CgTicky
Simon Marlow's avatar
Simon Marlow committed
28
29
30
31
32
33
import CgParallel
import CgInfoTbls
import CgCallConv
import CgUtils
import ClosureInfo
import SMRep
34
35
import OldCmm
import OldCmmUtils
36
import CLabel
37
import StgSyn
38
import CostCentre	
Simon Marlow's avatar
Simon Marlow committed
39
40
41
42
43
44
import Id
import Name
import Module
import ListSetOps
import Util
import BasicTypes
45
46
import StaticFlags
import DynFlags
Simon Marlow's avatar
Simon Marlow committed
47
import Constants
48
import Outputable
49
import FastString
50
51

import Data.List
52
53
54
55
56
57
58
59
60
61
62
63
64
\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
65
		-> CostCentreStack	-- Optional cost centre annotation
66
		-> StgBinderInfo
67
		-> UpdateFlag
68
		-> [Id]		-- Args
69
		-> StgExpr
70
71
		-> FCode (Id, CgIdInfo)

72
cgTopRhsClosure id ccs binder_info upd_flag args body = do
73
74
75
  {	-- LAY OUT THE OBJECT
    let name = idName id
  ; lf_info  <- mkClosureLFInfo id TopLevel [] upd_flag args
76
  ; srt_info <- getSRTInfo
Simon Marlow's avatar
Simon Marlow committed
77
  ; mod_name <- getModuleName
78
79
  ; let descr         = closureDescription mod_name name
	closure_info  = mkClosureInfo True id lf_info 0 0 srt_info descr
80
	closure_label = mkLocalClosureLabel name $ idCafInfo id
81
    	cg_id_info    = stableIdInfo id (mkLblExpr closure_label) lf_info
82
83
	closure_rep   = mkStaticClosureFields closure_info ccs True []

84
85
86
87
  	 -- BUILD THE OBJECT, AND GENERATE INFO TABLE (IF NECESSARY)
  ; emitDataLits closure_label closure_rep
  ; forkClosureBody (closureCodeBody binder_info closure_info
				     ccs args body)
88

89
  ; returnFC (id, cg_id_info) }
90
91
92
93
94
95
96
97
98
99
100
\end{code}

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

For closures with free vars, allocate in heap.

\begin{code}
101
102
103
104
105
106
107
108
109
110
111
cgStdRhsClosure
	:: Id
	-> CostCentreStack	-- Optional cost centre annotation
	-> StgBinderInfo
	-> [Id]			-- Free vars
	-> [Id]			-- Args
	-> StgExpr
	-> LambdaFormInfo
	-> [StgArg]		-- payload
	-> FCode (Id, CgIdInfo)

Ian Lynagh's avatar
Ian Lynagh committed
112
cgStdRhsClosure bndr cc _bndr_info _fvs args body lf_info payload 
113
114
115
  = do	-- AHA!  A STANDARD-FORM THUNK
  {	-- LAY OUT THE OBJECT
    amodes <- getArgAmodes payload
Simon Marlow's avatar
Simon Marlow committed
116
  ; mod_name <- getModuleName
117
118
  ; let (tot_wds, ptr_wds, amodes_w_offsets) 
	    = mkVirtHeapOffsets (isLFThunk lf_info) amodes
119
120
121
122
123
124
125
126

	descr	     = closureDescription mod_name (idName bndr)
	closure_info = mkClosureInfo False 	-- Not static
				     bndr lf_info tot_wds ptr_wds 
				     NoC_SRT	-- No SRT for a std-form closure
				     descr
		
  ; (use_cc, blame_cc) <- chooseDynCostCentres cc args body
127

128
	-- BUILD THE OBJECT
129
  ; heap_offset <- allocDynClosure closure_info use_cc blame_cc amodes_w_offsets
130
131

	-- RETURN
132
  ; returnFC (bndr, heapIdInfo bndr heap_offset lf_info) }
133
134
135
\end{code}

Here's the general case.
136

137
\begin{code}
138
139
140
141
cgRhsClosure	:: Id
		-> CostCentreStack	-- Optional cost centre annotation
		-> StgBinderInfo
		-> [Id]			-- Free vars
142
		-> UpdateFlag
143
144
145
146
		-> [Id]			-- Args
		-> StgExpr
		-> FCode (Id, CgIdInfo)

147
cgRhsClosure bndr cc bndr_info fvs upd_flag args body = do
148
  { 	-- LAY OUT THE OBJECT
149
150
151
152
	-- 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
153
	-- _was_ a free var of its RHS, mkClosureLFInfo thinks it *is*
154
155
156
	-- stored in the closure itself, so it will make sure that
	-- Node points to it...
    let
157
	name 	     = idName bndr
158
	bndr_is_a_fv = bndr `elem` fvs
159
160
161
162
163
	reduced_fvs | bndr_is_a_fv = fvs `minusList` [bndr]
		    | otherwise	   = fvs

  ; lf_info <- mkClosureLFInfo bndr NotTopLevel fvs upd_flag args
  ; fv_infos <- mapFCs getCgIdInfo reduced_fvs
164
  ; srt_info <- getSRTInfo
Simon Marlow's avatar
Simon Marlow committed
165
  ; mod_name <- getModuleName
166
  ; let	bind_details :: [(CgIdInfo, VirtualHpOffset)]
167
168
169
	(tot_wds, ptr_wds, bind_details) 
	   = mkVirtHeapOffsets (isLFThunk lf_info) (map add_rep fv_infos)

170
171
172
173
174
175
	add_rep info = (cgIdInfoArgRep info, info)

	descr	     = closureDescription mod_name name
	closure_info = mkClosureInfo False	-- Not static
				     bndr lf_info tot_wds ptr_wds
				     srt_info descr
176

177
	-- BUILD ITS INFO TABLE AND CODE
178
179
  ; forkClosureBody (do
	{	-- Bind the fvs
Simon Marlow's avatar
Simon Marlow committed
180
181
182
183
184
185
186
187
	  let 
              -- A function closure pointer may be tagged, so we
              -- must take it into account when accessing the free variables.
              mbtag       = tagForArity (length args)
              bind_fv (info, offset)
                | Just tag <- mbtag
                = bindNewToUntagNode (cgIdInfoId info) offset (cgIdInfoLF info) tag
                | otherwise
188
189
		= bindNewToNode (cgIdInfoId info) offset (cgIdInfoLF info)
	; mapCs bind_fv bind_details
190
191

	  	-- Bind the binder itself, if it is a free var
192
193
	; whenC bndr_is_a_fv (bindNewToReg bndr nodeReg lf_info)
	
194
		-- Compile the body
195
	; closureCodeBody bndr_info closure_info cc args body })
196
197

	-- BUILD THE OBJECT
198
199
200
201
202
203
  ; let
	to_amode (info, offset) = do { amode <- idInfoToAmode info
				     ; return (amode, offset) }
  ; (use_cc, blame_cc) <- chooseDynCostCentres cc args body
  ; amodes_w_offsets <- mapFCs to_amode bind_details
  ; heap_offset <- allocDynClosure closure_info use_cc blame_cc amodes_w_offsets
204
205

	-- RETURN
206
207
208
209
210
211
212
213
214
215
216
217
218
  ; returnFC (bndr, heapIdInfo bndr heap_offset lf_info) }


mkClosureLFInfo :: Id		-- The binder
		-> TopLevelFlag	-- True of top level
		-> [Id]		-- Free vars
		-> UpdateFlag 	-- Update flag
		-> [Id] 	-- Args
		-> FCode LambdaFormInfo
mkClosureLFInfo bndr top fvs upd_flag args
  | null args = return (mkLFThunk (idType bndr) top fvs upd_flag)
  | otherwise = do { arg_descr <- mkArgDescr (idName bndr) args
		   ; return (mkLFReEntrant top fvs args arg_descr) }
219
220
\end{code}

221

222
223
224
225
226
227
228
229
%************************************************************************
%*									*
\subsection[code-for-closures]{The code for closures}
%*									*
%************************************************************************

\begin{code}
closureCodeBody :: StgBinderInfo
230
231
		-> ClosureInfo	   -- Lots of information about this closure
		-> CostCentreStack -- Optional cost centre attached to closure
232
		-> [Id]
233
		-> StgExpr
234
235
236
237
238
		-> 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.
239
So it should set up an update frame (if it is shared).
240
NB: Thunks cannot have a primitive type!
241
242

\begin{code}
Ian Lynagh's avatar
Ian Lynagh committed
243
closureCodeBody _binder_info cl_info cc [{- No args i.e. thunk -}] body = do
244
245
  { body_absC <- getCgStmts $ do
	{ tickyEnterThunk cl_info
Simon Marlow's avatar
Simon Marlow committed
246
	; ldvEnterClosure cl_info  -- NB: Node always points when profiling
247
248
249
250
251
252
253
254
255
256
	; thunkWrapper cl_info $ do
		-- 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
	    { enterCostCentre cl_info cc body
	    ; cgExpr body }
	}
    
  ; emitClosureCodeAndInfoTable cl_info [] body_absC }
257
258
\end{code}

259
260
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.
261
262
263
264
265
266

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}
Ian Lynagh's avatar
Ian Lynagh committed
267
closureCodeBody _binder_info cl_info cc args body 
268
269
  = ASSERT( length args > 0 )
  do { 	-- Get the current virtual Sp (it might not be zero, 
270
271
272
273
274
275
	-- eg. if we're compiling a let-no-escape).
    vSp <- getVirtSp
  ; let (reg_args, other_args) = assignCallRegs (addIdReps args)
	(sp_top, stk_args)     = mkVirtStkOffsets vSp other_args

	-- Allocate the global ticky counter
276
  ; let ticky_ctr_lbl = mkRednCountsLabel (closureName cl_info) (clHasCafRefs cl_info)
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
314
315
316
317
318
319
320
321
  ; emitTickyCounter cl_info args sp_top

   	-- ...and establish the ticky-counter 
	-- label for this block
  ; setTickyCtrLabel ticky_ctr_lbl $ do

    	-- Emit the slow-entry code
  { reg_save_code <- mkSlowEntryCode cl_info reg_args

	-- Emit the main entry code
  ; blks <- forkProc $
	    mkFunEntryCode cl_info cc reg_args stk_args
			   sp_top reg_save_code body
  ; emitClosureCodeAndInfoTable cl_info [] blks
  }}



mkFunEntryCode :: ClosureInfo
	       -> CostCentreStack
	       -> [(Id,GlobalReg)] 	  -- Args in regs
	       -> [(Id,VirtualSpOffset)]  -- Args on stack
	       -> VirtualSpOffset	  -- Last allocated word on stack
	       -> CmmStmts 		  -- Register-save code in case of GC
	       -> StgExpr
	       -> Code
-- The main entry code for the closure
mkFunEntryCode cl_info cc reg_args stk_args sp_top reg_save_code body = do
  { 	-- Bind args to regs/stack as appropriate,
	-- and record expected position of sps
  ; bindArgsToRegs  reg_args
  ; bindArgsToStack stk_args
  ; setRealAndVirtualSp sp_top

	-- Enter the cost-centre, if required
	-- ToDo: It's not clear why this is outside the funWrapper,
	--	 but the tickyEnterFun is inside. Perhaps we can put
	--	 them together?
  ; enterCostCentre cl_info cc body

	-- Do the business
  ; funWrapper cl_info reg_args reg_save_code $ do
	{ tickyEnterFun cl_info
	; cgExpr body }
  }
322
323
\end{code}

324
325
326
327
328
329
330
331
332
333
334
335
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}
336
337
338
339
340
341
342
343
344
345
346
mkSlowEntryCode :: ClosureInfo -> [(Id,GlobalReg)] -> FCode CmmStmts
-- 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
-- Here, we emit the slow-entry code, and 
-- return the register-save assignments
mkSlowEntryCode cl_info reg_args
  | Just (_, ArgGen _) <- closureFunInfo cl_info
  = do 	{ emitSimpleProc slow_lbl (emitStmts load_stmts)
	; return save_stmts }
  | otherwise = return noStmts
347
  where
348
     name = closureName cl_info
349
350
     has_caf_refs = clHasCafRefs cl_info
     slow_lbl = mkSlowEntryLabel name has_caf_refs
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366

     load_stmts = mkStmts load_assts `plusStmts` mkStmts [stk_adj_pop, jump_to_entry]
     save_stmts = oneStmt stk_adj_push `plusStmts`  mkStmts save_assts

     reps_w_regs :: [(CgRep,GlobalReg)]
     reps_w_regs = [(idCgRep id, reg) | (id,reg) <- reverse reg_args]
     (final_stk_offset, stk_offsets)
	= mapAccumL (\off (rep,_) -> (off + cgRepSizeW rep, off))
		    0 reps_w_regs

     load_assts = zipWithEqual "mk_load" mk_load reps_w_regs stk_offsets
     mk_load (rep,reg) offset = CmmAssign (CmmGlobal reg) 
					  (CmmLoad (cmmRegOffW spReg offset)
						   (argMachRep rep))

     save_assts = zipWithEqual "mk_save" mk_save reps_w_regs stk_offsets
367
     mk_save (rep,reg) offset = ASSERT( argMachRep rep `cmmEqType` globalRegType reg )
368
369
370
371
372
				CmmStore (cmmRegOffW spReg offset) 
					 (CmmReg (CmmGlobal reg))

     stk_adj_pop   = CmmAssign spReg (cmmRegOffW spReg final_stk_offset)
     stk_adj_push  = CmmAssign spReg (cmmRegOffW spReg (- final_stk_offset))
373
     jump_to_entry = CmmJump (mkLblExpr (enterLocalIdLabel name has_caf_refs)) []
374
375
\end{code}

376
377
378
379
380
381
382
383

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

\begin{code}
384
thunkWrapper:: ClosureInfo -> Code -> Code
385
386
thunkWrapper closure_info thunk_code = do
  { let node_points = nodeMustPointToIt (closureLFInfo closure_info)
387

388
389
    -- HWL: insert macros for GrAnSim; 2 versions depending on liveness of node
    -- (we prefer fetchAndReschedule-style context switches to yield ones)
390
391
392
393
394
395
  ; if node_points 
    then granFetchAndReschedule [] node_points 
    else granYield 		[] node_points

        -- Stack and/or heap checks
  ; thunkEntryChecks closure_info $ do
396
397
398
399
      	{
          dflags <- getDynFlags
          -- Overwrite with black hole if necessary
	; whenC (blackHoleOnEntry dflags closure_info && node_points)
400
401
402
403
 	        (blackHoleIt closure_info)
	; setupUpdate closure_info thunk_code }
		-- setupUpdate *encloses* the thunk_code
  }
404
405

funWrapper :: ClosureInfo 	-- Closure whose code body this is
406
407
	   -> [(Id,GlobalReg)] 	-- List of argument registers (if any)
	   -> CmmStmts		-- reg saves for the heap check failure
408
409
	   -> Code		-- Body of function being compiled
	   -> Code
410
411
funWrapper closure_info arg_regs reg_save_code fun_body = do
  { let node_points = nodeMustPointToIt (closureLFInfo closure_info)
412

Simon Marlow's avatar
Simon Marlow committed
413
414
415
416
417
418
419
420
421
422
423
  {-
        -- Debugging: check that R1 has the correct tag
  ; let tag = funTag closure_info
  ; whenC (tag /= 0 && node_points) $ do
        l <- newLabelC
        stmtC (CmmCondBranch (CmmMachOp mo_wordEq [cmmGetTag (CmmReg nodeReg),
                                                   CmmLit (mkIntCLit tag)]) l)
        stmtC (CmmStore (CmmLit (mkWordCLit 0)) (CmmLit (mkWordCLit 0)))
        labelC l
  -}

424
   	-- Enter for Ldv profiling
Simon Marlow's avatar
Simon Marlow committed
425
  ; whenC node_points (ldvEnterClosure closure_info)
426

427
428
	-- GranSim yeild poin
  ; granYield arg_regs node_points
429

430
431
432
433
        -- Heap and/or stack checks wrap the function body
  ; funEntryChecks closure_info reg_save_code 
		   fun_body
  }
434
435
\end{code}

436

437
438
439
440
441
442
443
444
%************************************************************************
%*									*
\subsubsubsection[update-and-BHs]{Update and black-hole wrappers}
%*									*
%************************************************************************


\begin{code}
445
446
447
448
449
450
blackHoleIt :: ClosureInfo -> Code
-- Only called for closures with no args
-- Node points to the closure
blackHoleIt closure_info = emitBlackHoleCode (closureSingleEntry closure_info)

emitBlackHoleCode :: Bool -> Code
451
452
453
emitBlackHoleCode is_single_entry = do

  dflags <- getDynFlags
454
455
456
457
458
459
460
461
462
463

	-- If we wanted to do eager blackholing with slop filling,
	-- we'd need to do it at the *end* of a basic block, otherwise
	-- we overwrite the free variables in the thunk that we still
	-- need.  We have a patch for this from Andy Cheadle, but not
	-- incorporated yet. --SDM [6/2004]
	--
	-- Profiling needs slop filling (to support LDV profiling), so
	-- currently eager blackholing doesn't work with profiling.
	--
464
465
466
467
        -- Previously, eager blackholing was enabled when ticky-ticky
        -- was on. But it didn't work, and it wasn't strictly necessary 
        -- to bring back minimal ticky-ticky, so now EAGER_BLACKHOLING 
        -- is unconditionally disabled. -- krc 1/2007
468

469
470
471
472
473
474
475
  let eager_blackholing =  not opt_SccProfilingOn
                        && dopt Opt_EagerBlackHoling dflags

  if eager_blackholing
     then do
          tickyBlackHole (not is_single_entry)
          let bh_info = CmmReg (CmmGlobal EagerBlackholeInfo)
476
477
478
479
480
481
	  stmtsC [
              CmmStore (cmmOffsetW (CmmReg nodeReg) fixedHdrSize)
                       (CmmReg (CmmGlobal CurrentTSO)),
              CmmCall (CmmPrim MO_WriteBarrier) [] [] CmmUnsafe CmmMayReturn,
	      CmmStore (CmmReg nodeReg) bh_info
            ]
482
483
     else
          nopC
484
485
486
\end{code}

\begin{code}
487
setupUpdate :: ClosureInfo -> Code -> Code	-- Only called for closures with no args
488
489
	-- 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
490
	-- extracted by a subsequent enterCostCentre
491
setupUpdate closure_info code
492
493
494
495
  | closureReEntrant closure_info
  = code

  | not (isStaticClosure closure_info)
496
497
498
499
500
501
502
503
504
505
  = do
   if not (closureUpdReqd closure_info)
      then do tickyUpdateFrameOmitted; code
      else do
          tickyPushUpdateFrame
          dflags <- getDynFlags
          if not opt_SccProfilingOn && dopt Opt_EagerBlackHoling dflags
              then pushBHUpdateFrame (CmmReg nodeReg) code
              else pushUpdateFrame   (CmmReg nodeReg) code
  
506
507
508
509
510
  | otherwise	-- A static closure
  = do 	{ tickyUpdateBhCaf closure_info

	; if closureUpdReqd closure_info
	  then do	-- Blackhole the (updatable) CAF:
511
		{ upd_closure <- link_caf closure_info True
512
		; pushBHUpdateFrame upd_closure code }
513
	  else do
514
		{ -- krc: removed some ticky-related code here.
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
		; tickyUpdateFrameOmitted
		; code }
    }


-----------------------------------------------------------------------------
-- Entering a CAF
--
-- When a CAF is first entered, it creates a black hole in the heap,
-- and updates itself with an indirection to this new black hole.
--
-- We update the CAF with an indirection to a newly-allocated black
-- hole in the heap.  We also set the blocking queue on the newly
-- allocated black hole to be empty.
--
-- Why do we make a black hole in the heap when we enter a CAF?
--    
--     - for a  generational garbage collector, which needs a fast
--       test for whether an updatee is in an old generation or not
--
--     - for the parallel system, which can implement updates more
--       easily if the updatee is always in the heap. (allegedly).
--
-- When debugging, we maintain a separate CAF list so we can tell when
-- a CAF has been garbage collected.

-- newCAF must be called before the itbl ptr is overwritten, since
-- newCAF records the old itbl ptr in order to do CAF reverting
-- (which Hugs needs to do in order that combined mode works right.)
--

-- ToDo [Feb 04]  This entire link_caf nonsense could all be moved
-- into the "newCAF" RTS procedure, which we call anyway, including
-- the allocation of the black-hole indirection closure.
-- That way, code size would fall, the CAF-handling code would 
-- be closer together, and the compiler wouldn't need to know
-- about off_indirectee etc.

link_caf :: ClosureInfo
	 -> Bool		-- True <=> updatable, False <=> single-entry
         -> FCode CmmExpr       -- Returns amode for closure to be updated
-- 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.  The reason for all of this
-- is that we only want to update dynamic heap objects, not static ones,
-- so that generational GC is easier.
Ian Lynagh's avatar
Ian Lynagh committed
562
link_caf cl_info _is_upd = do
563
564
565
  { 	-- Alloc black hole specifying CC_HDR(Node) as the cost centre
  ; let	use_cc   = costCentreFrom (CmmReg nodeReg)
        blame_cc = use_cc
566
567
        tso      = CmmReg (CmmGlobal CurrentTSO)
  ; hp_offset <- allocDynClosure bh_cl_info use_cc blame_cc [(tso,fixedHdrSize)]
568
569
570
571
572
573
  ; hp_rel    <- getHpRelOffset hp_offset

	-- Call the RTS function newCAF to add the CAF to the CafList
	-- so that the garbage collector can find them
	-- This must be done *before* the info table pointer is overwritten, 
	-- because the old info table ptr is needed for reversion
574
575
576
577
  ; emitRtsCallWithVols rtsPackageId (fsLit "newCAF")
      [ CmmHinted (CmmReg (CmmGlobal BaseReg)) AddrHint,
        CmmHinted (CmmReg nodeReg) AddrHint ]
      [node] False
578
579
580
581
582
583
584
585
586
587
	-- node is live, so save it.

	-- Overwrite the closure with a (static) indirection 
	-- to the newly-allocated black hole
  ; stmtsC [ CmmStore (cmmRegOffW nodeReg off_indirectee) hp_rel
	   , CmmStore (CmmReg nodeReg) ind_static_info ]

  ; returnFC hp_rel }
  where
    bh_cl_info :: ClosureInfo
588
    bh_cl_info = cafBlackHoleClosureInfo cl_info
589
590
591
592
593
594

    ind_static_info :: CmmExpr
    ind_static_info = mkLblExpr mkIndStaticInfoLabel

    off_indirectee :: WordOff
    off_indirectee = fixedHdrSize + oFFSET_StgInd_indirectee*wORD_SIZE
595
596
\end{code}

597

598
599
600
601
602
603
604
%************************************************************************
%*									*
\subsection[CgClosure-Description]{Profiling Closure Description.}
%*									*
%************************************************************************

For "global" data constructors the description is simply occurrence
605
606
name of the data constructor itself.  Otherwise it is determined by
@closureDescription@ from the let binding information.
607
608

\begin{code}
609
closureDescription :: Module		-- Module
610
		   -> Name		-- Id of closure binding
611
612
613
		   -> String
	-- Not called for StgRhsCon which have global info tables built in
	-- CgConTbls.lhs with a description generated from the data constructor
614
closureDescription mod_name name
615
  = showSDocDumpOneLine (char '<' <>
616
617
618
619
		    (if isExternalName name
		      then ppr name -- ppr will include the module name prefix
		      else pprModule mod_name <> char '.' <> ppr name) <>
		    char '>')
620
   -- showSDocDumpOneLine, because we want to see the unique on the Name.
621
\end{code}
622