CgClosure.lhs 22 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}
Ian Lynagh's avatar
Ian Lynagh committed
12
13
14
15
16
17
18
{-# OPTIONS -fno-warn-tabs #-}
-- The above warning supression flag is a temporary kludge.
-- While working on this module you are encouraged to remove it and
-- detab the module (please do the detabbing in a separate patch). See
--     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces
-- for details

19
20
module CgClosure ( cgTopRhsClosure, 
		   cgStdRhsClosure, 
21
		   cgRhsClosure,
22
		   emitBlackHoleCode,
23
		   ) where
24

25
26
#include "HsVersions.h"

sof's avatar
sof committed
27
import {-# SOURCE #-} CgExpr ( cgExpr )
28

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

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

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

90
91
92
93
  	 -- BUILD THE OBJECT, AND GENERATE INFO TABLE (IF NECESSARY)
  ; emitDataLits closure_label closure_rep
  ; forkClosureBody (closureCodeBody binder_info closure_info
				     ccs args body)
94

95
  ; returnFC (id, cg_id_info) }
96
97
98
99
100
101
102
103
104
105
106
\end{code}

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

For closures with free vars, allocate in heap.

\begin{code}
107
108
109
110
111
112
113
114
115
116
117
cgStdRhsClosure
	:: Id
	-> CostCentreStack	-- Optional cost centre annotation
	-> StgBinderInfo
	-> [Id]			-- Free vars
	-> [Id]			-- Args
	-> StgExpr
	-> LambdaFormInfo
	-> [StgArg]		-- payload
	-> FCode (Id, CgIdInfo)

118
cgStdRhsClosure bndr _cc _bndr_info _fvs _args _body lf_info payload
119
120
121
  = do	-- AHA!  A STANDARD-FORM THUNK
  {	-- LAY OUT THE OBJECT
    amodes <- getArgAmodes payload
Simon Marlow's avatar
Simon Marlow committed
122
  ; mod_name <- getModuleName
123
  ; dflags <- getDynFlags
124
  ; let (tot_wds, ptr_wds, amodes_w_offsets) 
125
	    = mkVirtHeapOffsets dflags (isLFThunk lf_info) amodes
126

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

135
	-- BUILD THE OBJECT
136
  ; heap_offset <- allocDynClosure closure_info curCCS curCCS amodes_w_offsets
137
138

	-- RETURN
139
  ; returnFC (bndr, heapIdInfo bndr heap_offset lf_info) }
140
141
142
\end{code}

Here's the general case.
143

144
\begin{code}
145
146
147
148
cgRhsClosure	:: Id
		-> CostCentreStack	-- Optional cost centre annotation
		-> StgBinderInfo
		-> [Id]			-- Free vars
149
		-> UpdateFlag
150
151
152
153
		-> [Id]			-- Args
		-> StgExpr
		-> FCode (Id, CgIdInfo)

154
cgRhsClosure bndr cc bndr_info fvs upd_flag args body = do
155
  { 	-- LAY OUT THE OBJECT
156
157
158
159
	-- 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
160
	-- _was_ a free var of its RHS, mkClosureLFInfo thinks it *is*
161
162
163
	-- stored in the closure itself, so it will make sure that
	-- Node points to it...
    let
164
	name 	     = idName bndr
165
	bndr_is_a_fv = bndr `elem` fvs
166
167
168
169
170
	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
171
  ; srt_info <- getSRTInfo
Simon Marlow's avatar
Simon Marlow committed
172
  ; mod_name <- getModuleName
173
  ; dflags <- getDynFlags
174
  ; let	bind_details :: [(CgIdInfo, VirtualHpOffset)]
175
	(tot_wds, ptr_wds, bind_details) 
176
	   = mkVirtHeapOffsets dflags (isLFThunk lf_info) (map add_rep fv_infos)
177

178
179
	add_rep info = (cgIdInfoArgRep info, info)

180
	descr	     = closureDescription dflags mod_name name
181
	closure_info = mkClosureInfo dflags False	-- Not static
182
183
				     bndr lf_info tot_wds ptr_wds
				     srt_info descr
184

185
	-- BUILD ITS INFO TABLE AND CODE
186
187
  ; forkClosureBody (do
	{	-- Bind the fvs
Simon Marlow's avatar
Simon Marlow committed
188
189
190
191
192
193
194
195
	  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
196
197
		= bindNewToNode (cgIdInfoId info) offset (cgIdInfoLF info)
	; mapCs bind_fv bind_details
198
199

	  	-- Bind the binder itself, if it is a free var
200
201
	; whenC bndr_is_a_fv (bindNewToReg bndr nodeReg lf_info)
	
202
		-- Compile the body
203
	; closureCodeBody bndr_info closure_info cc args body })
204
205

	-- BUILD THE OBJECT
206
207
208
  ; let
	to_amode (info, offset) = do { amode <- idInfoToAmode info
				     ; return (amode, offset) }
209
--  ; (use_cc, blame_cc) <- chooseDynCostCentres cc args body
210
  ; amodes_w_offsets <- mapFCs to_amode bind_details
211
  ; heap_offset <- allocDynClosure closure_info curCCS curCCS amodes_w_offsets
212
213

	-- RETURN
214
215
216
217
218
219
220
221
222
223
224
225
226
  ; 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) }
227
228
\end{code}

229

230
231
232
233
234
235
236
237
%************************************************************************
%*									*
\subsection[code-for-closures]{The code for closures}
%*									*
%************************************************************************

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

\begin{code}
251
closureCodeBody _binder_info cl_info _cc [{- No args i.e. thunk -}] body = do
252
253
  { body_absC <- getCgStmts $ do
	{ tickyEnterThunk cl_info
Simon Marlow's avatar
Simon Marlow committed
254
	; ldvEnterClosure cl_info  -- NB: Node always points when profiling
255
256
257
	; thunkWrapper cl_info $ do
		-- We only enter cc after setting up update so
		-- that cc of enclosing scope will be recorded
258
259
                -- in the update frame
            { enterCostCentreThunk (CmmReg nodeReg)
260
261
262
263
	    ; cgExpr body }
	}
    
  ; emitClosureCodeAndInfoTable cl_info [] body_absC }
264
265
\end{code}

266
267
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.
268
269
270
271
272
273

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
274
closureCodeBody _binder_info cl_info cc args body 
275
  = ASSERT( length args > 0 )
276
277
278
  do {
    dflags <- getDynFlags
        -- Get the current virtual Sp (it might not be zero, 
279
	-- eg. if we're compiling a let-no-escape).
280
281
  ; vSp <- getVirtSp
  ; let (reg_args, other_args) = assignCallRegs dflags (addIdReps args)
282
283
284
	(sp_top, stk_args)     = mkVirtStkOffsets vSp other_args

	-- Allocate the global ticky counter
285
  ; let ticky_ctr_lbl = mkRednCountsLabel (closureName cl_info) (clHasCafRefs cl_info)
286
287
288
289
290
291
292
  ; 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
293
294
  { dflags <- getDynFlags
  ; reg_save_code <- mkSlowEntryCode dflags cl_info reg_args
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

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

321
        -- Do the business
322
323
  ; funWrapper cl_info reg_args reg_save_code $ do
	{ tickyEnterFun cl_info
324
325
326
327
        ; enterCostCentreFun cc
              (CmmMachOp mo_wordSub [ CmmReg nodeReg
                                    , CmmLit (mkIntCLit (funTag cl_info)) ])
              (node : map snd reg_args) -- live regs
328
329

        ; cgExpr body }
330
  }
331
332
\end{code}

333
334
335
336
337
338
339
340
341
342
343
344
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}
345
mkSlowEntryCode :: DynFlags -> ClosureInfo -> [(Id,GlobalReg)] -> FCode CmmStmts
346
347
348
349
350
-- 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
351
mkSlowEntryCode dflags cl_info reg_args
352
353
354
355
  | Just (_, ArgGen _) <- closureFunInfo cl_info
  = do 	{ emitSimpleProc slow_lbl (emitStmts load_stmts)
	; return save_stmts }
  | otherwise = return noStmts
356
  where
357
     name = closureName cl_info
358
359
     has_caf_refs = clHasCafRefs cl_info
     slow_lbl = mkSlowEntryLabel name has_caf_refs
360
361
362
363
364
365
366
367
368
369

     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

370

371
372
373
374
375
376
     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
377
     mk_save (rep,reg) offset = ASSERT( argMachRep rep `cmmEqType` globalRegType reg )
378
379
380
381
382
				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))
383
     live_regs     = Just $ map snd reps_w_regs
384
     jump_to_entry = CmmJump (mkLblExpr (entryLabelFromCI dflags cl_info)) live_regs
385
386
\end{code}

387
388
389
390
391
392
393
394

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

\begin{code}
395
thunkWrapper:: ClosureInfo -> Code -> Code
396
thunkWrapper closure_info thunk_code = do
397
398
  { dflags <- getDynFlags
  ; let node_points = nodeMustPointToIt dflags (closureLFInfo closure_info)
399

400
401
    -- HWL: insert macros for GrAnSim; 2 versions depending on liveness of node
    -- (we prefer fetchAndReschedule-style context switches to yield ones)
402
403
404
405
406
407
  ; if node_points 
    then granFetchAndReschedule [] node_points 
    else granYield 		[] node_points

        -- Stack and/or heap checks
  ; thunkEntryChecks closure_info $ do
408
409
      	{
          -- Overwrite with black hole if necessary
410
        ; whenC (blackHoleOnEntry closure_info && node_points)
411
412
413
414
 	        (blackHoleIt closure_info)
	; setupUpdate closure_info thunk_code }
		-- setupUpdate *encloses* the thunk_code
  }
415
416

funWrapper :: ClosureInfo 	-- Closure whose code body this is
417
418
	   -> [(Id,GlobalReg)] 	-- List of argument registers (if any)
	   -> CmmStmts		-- reg saves for the heap check failure
419
420
	   -> Code		-- Body of function being compiled
	   -> Code
421
funWrapper closure_info arg_regs reg_save_code fun_body = do
422
423
  { dflags <- getDynFlags
  ; let node_points = nodeMustPointToIt dflags (closureLFInfo closure_info)
424
        live        = Just $ map snd arg_regs
425

Simon Marlow's avatar
Simon Marlow committed
426
427
428
429
430
431
432
433
434
435
436
  {-
        -- 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
  -}

437
   	-- Enter for Ldv profiling
Simon Marlow's avatar
Simon Marlow committed
438
  ; whenC node_points (ldvEnterClosure closure_info)
439

440
441
	-- GranSim yeild poin
  ; granYield arg_regs node_points
442

443
        -- Heap and/or stack checks wrap the function body
444
  ; funEntryChecks closure_info reg_save_code live fun_body
445
  }
446
447
\end{code}

448

449
450
451
452
453
454
455
456
%************************************************************************
%*									*
\subsubsubsection[update-and-BHs]{Update and black-hole wrappers}
%*									*
%************************************************************************


\begin{code}
457
458
459
460
461
462
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
463
emitBlackHoleCode is_single_entry = do
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
  dflags <- getDynFlags

  -- Eager blackholing is normally disabled, but can be turned on with
  -- -feager-blackholing.  When it is on, we replace the info pointer
  -- of the thunk with stg_EAGER_BLACKHOLE_info on entry.
  
  -- 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]
  --
  -- 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
  
  -- Note the eager-blackholing check is here rather than in blackHoleOnEntry,
  -- because emitBlackHoleCode is called from CmmParse.

484
  let  eager_blackholing =  not (dopt Opt_SccProfilingOn dflags)
485
486
487
488
489
490
                         && dopt Opt_EagerBlackHoling dflags
             -- Profiling needs slop filling (to support LDV
             -- profiling), so currently eager blackholing doesn't
             -- work with profiling.

  whenC eager_blackholing $ do
491
492
    tickyBlackHole (not is_single_entry)
    stmtsC [
493
       CmmStore (cmmOffsetW (CmmReg nodeReg) (fixedHdrSize dflags))
494
                (CmmReg (CmmGlobal CurrentTSO)),
Ian Lynagh's avatar
Ian Lynagh committed
495
       CmmCall (CmmPrim MO_WriteBarrier Nothing) [] [] CmmMayReturn,
496
       CmmStore (CmmReg nodeReg) (CmmReg (CmmGlobal EagerBlackholeInfo))
497
     ]
498
499
500
\end{code}

\begin{code}
501
setupUpdate :: ClosureInfo -> Code -> Code	-- Only called for closures with no args
502
503
	-- 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
504
	-- extracted by a subsequent enterCostCentre
505
setupUpdate closure_info code
506
507
508
509
  | closureReEntrant closure_info
  = code

  | not (isStaticClosure closure_info)
510
511
512
513
514
515
  = do
   if not (closureUpdReqd closure_info)
      then do tickyUpdateFrameOmitted; code
      else do
          tickyPushUpdateFrame
          dflags <- getDynFlags
516
          if blackHoleOnEntry closure_info &&
517
518
             not (dopt Opt_SccProfilingOn dflags) &&
             dopt Opt_EagerBlackHoling dflags
519
520
               then pushBHUpdateFrame (CmmReg nodeReg) code
               else pushUpdateFrame   (CmmReg nodeReg) code
521
  
522
523
524
525
526
  | otherwise	-- A static closure
  = do 	{ tickyUpdateBhCaf closure_info

	; if closureUpdReqd closure_info
	  then do	-- Blackhole the (updatable) CAF:
527
		{ upd_closure <- link_caf closure_info True
528
		; pushBHUpdateFrame upd_closure code }
529
	  else do
530
		{ -- krc: removed some ticky-related code here.
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
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
		; 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
578
link_caf cl_info _is_upd = do
579
580
581
  { 	-- Alloc black hole specifying CC_HDR(Node) as the cost centre
  ; let	use_cc   = costCentreFrom (CmmReg nodeReg)
        blame_cc = use_cc
582
        tso      = CmmReg (CmmGlobal CurrentTSO)
583
584
585
  ; dflags    <- getDynFlags
  ; hp_offset <- allocDynClosure bh_cl_info use_cc blame_cc
                                 [(tso, fixedHdrSize dflags)]
586
587
588
589
590
591
  ; 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
Simon Marlow's avatar
Simon Marlow committed
592
593
  ; ret <- newTemp bWord
  ; emitRtsCallGen [CmmHinted ret NoHint] rtsPackageId (fsLit "newCAF")
594
      [ CmmHinted (CmmReg (CmmGlobal BaseReg)) AddrHint,
Simon Marlow's avatar
Simon Marlow committed
595
596
        CmmHinted (CmmReg nodeReg) AddrHint,
        CmmHinted hp_rel AddrHint ]
597
      (Just [node])
598
599
	-- node is live, so save it.

Simon Marlow's avatar
Simon Marlow committed
600
601
602
603
604
  -- see Note [atomic CAF entry] in rts/sm/Storage.c
  ; emitIf (CmmMachOp mo_wordEq [ CmmReg (CmmLocal ret), CmmLit zeroCLit]) $
        -- re-enter R1.  Doing this directly is slightly dodgy; we're
        -- assuming lots of things, like the stack pointer hasn't
        -- moved since we entered the CAF.
605
        let target = entryCode dflags (closureInfoPtr (CmmReg nodeReg)) in
606
        stmtC (CmmJump target $ Just [node])
607
608
609
610

  ; returnFC hp_rel }
  where
    bh_cl_info :: ClosureInfo
611
    bh_cl_info = cafBlackHoleClosureInfo cl_info
612
613
\end{code}

614

615
616
617
618
619
620
621
%************************************************************************
%*									*
\subsection[CgClosure-Description]{Profiling Closure Description.}
%*									*
%************************************************************************

For "global" data constructors the description is simply occurrence
622
623
name of the data constructor itself.  Otherwise it is determined by
@closureDescription@ from the let binding information.
624
625

\begin{code}
626
627
628
629
closureDescription :: DynFlags
                   -> Module    -- Module
                   -> Name      -- Id of closure binding
                   -> String
630
631
	-- Not called for StgRhsCon which have global info tables built in
	-- CgConTbls.lhs with a description generated from the data constructor
632
633
closureDescription dflags mod_name name
  = showSDocDumpOneLine dflags (char '<' <>
634
635
636
637
		    (if isExternalName name
		      then ppr name -- ppr will include the module name prefix
		      else pprModule mod_name <> char '.' <> ppr name) <>
		    char '>')
638
   -- showSDocDumpOneLine, because we want to see the unique on the Name.
639
\end{code}
640