b5ce23185647ac266dce807f32b381766d143744
[ghc.git] / compiler / codeGen / CgClosure.lhs
1 %
2 % (c) The University of Glasgow 2006
3 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4 %
5 \section[CgClosure]{Code generation for closures}
6
7 This module provides the support code for @StgToAbstractC@ to deal
8 with {\em closures} on the RHSs of let(rec)s.  See also
9 @CgCon@, which deals with constructors.
10
11 \begin{code}
12 {-# OPTIONS -fno-warn-tabs #-}
13 -- The above warning supression flag is a temporary kludge.
14 -- While working on this module you are encouraged to remove it and
15 -- detab the module (please do the detabbing in a separate patch). See
16 --     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces
17 -- for details
18
19 module CgClosure ( cgTopRhsClosure, 
20                    cgStdRhsClosure, 
21                    cgRhsClosure,
22                    emitBlackHoleCode,
23                    ) where
24
25 #include "HsVersions.h"
26
27 import {-# SOURCE #-} CgExpr ( cgExpr )
28
29 import CgMonad
30 import CgBindery
31 import CgHeapery
32 import CgStackery
33 import CgProf
34 import CgTicky
35 import CgParallel
36 import CgInfoTbls
37 import CgCallConv
38 import CgUtils
39 import ClosureInfo
40 import SMRep
41 import OldCmm
42 import OldCmmUtils
43 import CLabel
44 import StgSyn
45 import CostCentre       
46 import Id
47 import Name
48 import Module
49 import ListSetOps
50 import Util
51 import BasicTypes
52 import DynFlags
53 import Outputable
54 import FastString
55
56 import Data.List
57 \end{code}
58
59 %********************************************************
60 %*                                                      *
61 \subsection[closures-no-free-vars]{Top-level closures}
62 %*                                                      *
63 %********************************************************
64
65 For closures bound at top level, allocate in static space.
66 They should have no free variables.
67
68 \begin{code}
69 cgTopRhsClosure :: Id
70                 -> CostCentreStack      -- Optional cost centre annotation
71                 -> StgBinderInfo
72                 -> UpdateFlag
73                 -> [Id]         -- Args
74                 -> StgExpr
75                 -> FCode (Id, CgIdInfo)
76
77 cgTopRhsClosure id ccs binder_info upd_flag args body = do
78   {     -- LAY OUT THE OBJECT
79     let name = idName id
80   ; lf_info  <- mkClosureLFInfo id TopLevel [] upd_flag args
81   ; srt_info <- getSRTInfo
82   ; mod_name <- getModuleName
83   ; dflags   <- getDynFlags
84   ; 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 dflags id (mkLblExpr closure_label) lf_info
88         closure_rep   = mkStaticClosureFields dflags closure_info ccs True []
89
90          -- BUILD THE OBJECT, AND GENERATE INFO TABLE (IF NECESSARY)
91   ; emitDataLits closure_label closure_rep
92   ; forkClosureBody (closureCodeBody binder_info closure_info
93                                      ccs args body)
94
95   ; returnFC (id, cg_id_info) }
96 \end{code}
97
98 %********************************************************
99 %*                                                      *
100 \subsection[non-top-level-closures]{Non top-level closures}
101 %*                                                      *
102 %********************************************************
103
104 For closures with free vars, allocate in heap.
105
106 \begin{code}
107 cgStdRhsClosure
108         :: Id
109         -> CostCentreStack      -- Optional cost centre annotation
110         -> StgBinderInfo
111         -> [Id]                 -- Free vars
112         -> [Id]                 -- Args
113         -> StgExpr
114         -> LambdaFormInfo
115         -> [StgArg]             -- payload
116         -> FCode (Id, CgIdInfo)
117
118 cgStdRhsClosure bndr _cc _bndr_info _fvs _args _body lf_info payload
119   = do  -- AHA!  A STANDARD-FORM THUNK
120   {     -- LAY OUT THE OBJECT
121     amodes <- getArgAmodes payload
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                                      bndr lf_info tot_wds ptr_wds 
130                                      NoC_SRT    -- No SRT for a std-form closure
131                                      descr
132                 
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 dflags bndr heap_offset lf_info) }
140 \end{code}
141
142 Here's the general case.
143
144 \begin{code}
145 cgRhsClosure    :: Id
146                 -> CostCentreStack      -- Optional cost centre annotation
147                 -> StgBinderInfo
148                 -> [Id]                 -- Free vars
149                 -> UpdateFlag
150                 -> [Id]                 -- Args
151                 -> StgExpr
152                 -> FCode (Id, CgIdInfo)
153
154 cgRhsClosure bndr cc bndr_info fvs upd_flag args body = do
155   {     -- LAY OUT THE OBJECT
156         -- If the binder is itself a free variable, then don't store
157         -- it in the closure.  Instead, just bind it to Node on entry.
158         -- NB we can be sure that Node will point to it, because we
159         -- havn't told mkClosureLFInfo about this; so if the binder
160         -- _was_ a free var of its RHS, mkClosureLFInfo thinks it *is*
161         -- stored in the closure itself, so it will make sure that
162         -- Node points to it...
163     let
164         name         = idName bndr
165         bndr_is_a_fv = bndr `elem` fvs
166         reduced_fvs | bndr_is_a_fv = fvs `minusList` [bndr]
167                     | otherwise    = fvs
168
169   ; lf_info <- mkClosureLFInfo bndr NotTopLevel fvs upd_flag args
170   ; fv_infos <- mapFCs getCgIdInfo reduced_fvs
171   ; srt_info <- getSRTInfo
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         add_rep info = (cgIdInfoArgRep info, info)
179
180         descr        = closureDescription dflags mod_name name
181         closure_info = mkClosureInfo dflags False       -- Not static
182                                      bndr lf_info tot_wds ptr_wds
183                                      srt_info descr
184
185         -- BUILD ITS INFO TABLE AND CODE
186   ; forkClosureBody (do
187         {       -- Bind the fvs
188           let 
189               -- A function closure pointer may be tagged, so we
190               -- must take it into account when accessing the free variables.
191               mbtag       = tagForArity dflags (length args)
192               bind_fv (info, offset)
193                 | Just tag <- mbtag
194                 = bindNewToUntagNode (cgIdInfoId info) offset (cgIdInfoLF info) tag
195                 | otherwise
196                 = bindNewToNode (cgIdInfoId info) offset (cgIdInfoLF info)
197         ; mapCs bind_fv bind_details
198
199                 -- Bind the binder itself, if it is a free var
200         ; whenC bndr_is_a_fv (bindNewToReg bndr nodeReg lf_info)
201         
202                 -- Compile the body
203         ; closureCodeBody bndr_info closure_info cc args body })
204
205         -- BUILD THE OBJECT
206   ; let
207         to_amode (info, offset) = do { amode <- idInfoToAmode info
208                                      ; 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   ; returnFC (bndr, heapIdInfo dflags bndr heap_offset lf_info) }
215
216
217 mkClosureLFInfo :: Id           -- The binder
218                 -> TopLevelFlag -- True of top level
219                 -> [Id]         -- Free vars
220                 -> UpdateFlag   -- Update flag
221                 -> [Id]         -- Args
222                 -> FCode LambdaFormInfo
223 mkClosureLFInfo bndr top fvs upd_flag args
224   | null args = return (mkLFThunk (idType bndr) top fvs upd_flag)
225   | otherwise = do { arg_descr <- mkArgDescr (idName bndr) args
226                    ; return (mkLFReEntrant top fvs args arg_descr) }
227 \end{code}
228
229
230 %************************************************************************
231 %*                                                                      *
232 \subsection[code-for-closures]{The code for closures}
233 %*                                                                      *
234 %************************************************************************
235
236 \begin{code}
237 closureCodeBody :: StgBinderInfo
238                 -> ClosureInfo     -- Lots of information about this closure
239                 -> CostCentreStack -- Optional cost centre attached to closure
240                 -> [Id]
241                 -> StgExpr
242                 -> Code
243 \end{code}
244
245 There are two main cases for the code for closures.  If there are {\em
246 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   { body_absC <- getCgStmts $ do
253         { tickyEnterThunk cl_info
254         ; ldvEnterClosure cl_info  -- NB: Node always points when profiling
255         ; thunkWrapper cl_info $ do
256                 -- We only enter cc after setting up update so
257                 -- that cc of enclosing scope will be recorded
258                 -- in the update frame
259             { enterCostCentreThunk (CmmReg nodeReg)
260             ; cgExpr body }
261         }
262     
263   ; emitClosureCodeAndInfoTable cl_info [] body_absC }
264 \end{code}
265
266 If there is /at least one argument/, then this closure is in
267 normal form, so there is no need to set up an update frame.
268
269 The Macros for GrAnSim are produced at the beginning of the
270 argSatisfactionCheck (by calling fetchAndReschedule).  There info if
271 Node points to closure is available. -- HWL
272
273 \begin{code}
274 closureCodeBody _binder_info cl_info cc args body 
275   = ASSERT( length args > 0 )
276   do {
277     dflags <- getDynFlags
278         -- Get the current virtual Sp (it might not be zero, 
279         -- eg. if we're compiling a let-no-escape).
280   ; vSp <- getVirtSp
281   ; let (reg_args, other_args) = assignCallRegs dflags (addIdReps args)
282         (sp_top, stk_args)     = mkVirtStkOffsets dflags vSp other_args
283
284         -- Allocate the global ticky counter
285   ; let ticky_ctr_lbl = mkRednCountsLabel (closureName cl_info) (clHasCafRefs cl_info)
286   ; emitTickyCounter cl_info args sp_top
287
288         -- ...and establish the ticky-counter 
289         -- label for this block
290   ; setTickyCtrLabel ticky_ctr_lbl $ do
291
292         -- Emit the slow-entry code
293   { dflags <- getDynFlags
294   ; reg_save_code <- mkSlowEntryCode dflags cl_info reg_args
295
296         -- Emit the main entry code
297   ; blks <- forkProc $
298             mkFunEntryCode cl_info cc reg_args stk_args
299                            sp_top reg_save_code body
300   ; emitClosureCodeAndInfoTable cl_info [] blks
301   }}
302
303
304
305 mkFunEntryCode :: ClosureInfo
306                -> CostCentreStack
307                -> [(Id,GlobalReg)]        -- Args in regs
308                -> [(Id,VirtualSpOffset)]  -- Args on stack
309                -> VirtualSpOffset         -- Last allocated word on stack
310                -> CmmStmts                -- Register-save code in case of GC
311                -> StgExpr
312                -> Code
313 -- The main entry code for the closure
314 mkFunEntryCode cl_info cc reg_args stk_args sp_top reg_save_code body = do
315   {     -- Bind args to regs/stack as appropriate,
316         -- and record expected position of sps
317   ; bindArgsToRegs  reg_args
318   ; bindArgsToStack stk_args
319   ; setRealAndVirtualSp sp_top
320
321         -- Do the business
322   ; funWrapper cl_info reg_args reg_save_code $ do
323         { dflags <- getDynFlags
324         ; tickyEnterFun cl_info
325         ; enterCostCentreFun cc
326               (CmmMachOp (mo_wordSub dflags) [ CmmReg nodeReg
327                                              , mkIntExpr dflags (funTag dflags cl_info) ])
328               (node : map snd reg_args) -- live regs
329
330         ; cgExpr body }
331   }
332 \end{code}
333
334 The "slow entry" code for a function.  This entry point takes its
335 arguments on the stack.  It loads the arguments into registers
336 according to the calling convention, and jumps to the function's
337 normal entry point.  The function's closure is assumed to be in
338 R1/node.
339
340 The slow entry point is used in two places:
341
342  (a) unknown calls: eg. stg_PAP_entry 
343  (b) returning from a heap-check failure
344
345 \begin{code}
346 mkSlowEntryCode :: DynFlags -> ClosureInfo -> [(Id,GlobalReg)] -> FCode CmmStmts
347 -- If this function doesn't have a specialised ArgDescr, we need
348 -- to generate the function's arg bitmap, slow-entry code, and
349 -- register-save code for the heap-check failure
350 -- Here, we emit the slow-entry code, and 
351 -- return the register-save assignments
352 mkSlowEntryCode dflags cl_info reg_args
353   | Just (_, ArgGen _) <- closureFunInfo cl_info
354   = do  { emitSimpleProc slow_lbl (emitStmts load_stmts)
355         ; return save_stmts }
356   | otherwise = return noStmts
357   where
358      name = closureName cl_info
359      has_caf_refs = clHasCafRefs cl_info
360      slow_lbl = mkSlowEntryLabel name has_caf_refs
361
362      load_stmts = mkStmts load_assts `plusStmts` mkStmts [stk_adj_pop, jump_to_entry]
363      save_stmts = oneStmt stk_adj_push `plusStmts`  mkStmts save_assts
364
365      reps_w_regs :: [(CgRep,GlobalReg)]
366      reps_w_regs = [(idCgRep id, reg) | (id,reg) <- reverse reg_args]
367      (final_stk_offset, stk_offsets)
368         = mapAccumL (\off (rep,_) -> (off + cgRepSizeW dflags rep, off))
369                     0 reps_w_regs
370
371
372      load_assts = zipWithEqual "mk_load" mk_load reps_w_regs stk_offsets
373      mk_load (rep,reg) offset = CmmAssign (CmmGlobal reg) 
374                                           (CmmLoad (cmmRegOffW dflags spReg offset)
375                                                    (argMachRep dflags rep))
376
377      save_assts = zipWithEqual "mk_save" mk_save reps_w_regs stk_offsets
378      mk_save (rep,reg) offset = ASSERT( argMachRep dflags rep `cmmEqType` globalRegType dflags reg )
379                                 CmmStore (cmmRegOffW dflags spReg offset)
380                                          (CmmReg (CmmGlobal reg))
381
382      stk_adj_pop   = CmmAssign spReg (cmmRegOffW dflags spReg final_stk_offset)
383      stk_adj_push  = CmmAssign spReg (cmmRegOffW dflags spReg (- final_stk_offset))
384      live_regs     = Just $ map snd reps_w_regs
385      jump_to_entry = CmmJump (mkLblExpr (entryLabelFromCI dflags cl_info)) live_regs
386 \end{code}
387
388
389 %************************************************************************
390 %*                                                                      *
391 \subsubsection[closure-code-wrappers]{Wrappers around closure code}
392 %*                                                                      *
393 %************************************************************************
394
395 \begin{code}
396 thunkWrapper:: ClosureInfo -> Code -> Code
397 thunkWrapper closure_info thunk_code = do
398   { dflags <- getDynFlags
399   ; let node_points = nodeMustPointToIt dflags (closureLFInfo closure_info)
400
401     -- HWL: insert macros for GrAnSim; 2 versions depending on liveness of node
402     -- (we prefer fetchAndReschedule-style context switches to yield ones)
403   ; if node_points 
404     then granFetchAndReschedule [] node_points 
405     else granYield              [] node_points
406
407         -- Stack and/or heap checks
408   ; thunkEntryChecks closure_info $ do
409         {
410           -- Overwrite with black hole if necessary
411         ; whenC (blackHoleOnEntry closure_info && node_points)
412                 (blackHoleIt closure_info)
413         ; setupUpdate closure_info thunk_code }
414                 -- setupUpdate *encloses* the thunk_code
415   }
416
417 funWrapper :: ClosureInfo       -- Closure whose code body this is
418            -> [(Id,GlobalReg)]  -- List of argument registers (if any)
419            -> CmmStmts          -- reg saves for the heap check failure
420            -> Code              -- Body of function being compiled
421            -> Code
422 funWrapper closure_info arg_regs reg_save_code fun_body = do
423   { dflags <- getDynFlags
424   ; let node_points = nodeMustPointToIt dflags (closureLFInfo closure_info)
425         live        = Just $ map snd arg_regs
426
427   {-
428         -- Debugging: check that R1 has the correct tag
429   ; let tag = funTag closure_info
430   ; whenC (tag /= 0 && node_points) $ do
431         l <- newLabelC
432         stmtC (CmmCondBranch (CmmMachOp mo_wordEq [cmmGetTag (CmmReg nodeReg),
433                                                    mkIntExpr dflags tag)]) l)
434         stmtC (CmmStore (CmmLit (mkWordCLit 0)) (mkWordExpr 0))
435         labelC l
436   -}
437
438         -- Enter for Ldv profiling
439   ; whenC node_points (ldvEnterClosure closure_info)
440
441         -- GranSim yeild poin
442   ; granYield arg_regs node_points
443
444         -- Heap and/or stack checks wrap the function body
445   ; funEntryChecks closure_info reg_save_code live fun_body
446   }
447 \end{code}
448
449
450 %************************************************************************
451 %*                                                                      *
452 \subsubsubsection[update-and-BHs]{Update and black-hole wrappers}
453 %*                                                                      *
454 %************************************************************************
455
456
457 \begin{code}
458 blackHoleIt :: ClosureInfo -> Code
459 -- Only called for closures with no args
460 -- Node points to the closure
461 blackHoleIt closure_info = emitBlackHoleCode (closureSingleEntry closure_info)
462
463 emitBlackHoleCode :: Bool -> Code
464 emitBlackHoleCode is_single_entry = do
465   dflags <- getDynFlags
466
467   -- Eager blackholing is normally disabled, but can be turned on with
468   -- -feager-blackholing.  When it is on, we replace the info pointer
469   -- of the thunk with stg_EAGER_BLACKHOLE_info on entry.
470   
471   -- If we wanted to do eager blackholing with slop filling, we'd need
472   -- to do it at the *end* of a basic block, otherwise we overwrite
473   -- the free variables in the thunk that we still need.  We have a
474   -- patch for this from Andy Cheadle, but not incorporated yet. --SDM
475   -- [6/2004]
476   --
477   -- Previously, eager blackholing was enabled when ticky-ticky was
478   -- on. But it didn't work, and it wasn't strictly necessary to bring
479   -- back minimal ticky-ticky, so now EAGER_BLACKHOLING is
480   -- unconditionally disabled. -- krc 1/2007
481   
482   -- Note the eager-blackholing check is here rather than in blackHoleOnEntry,
483   -- because emitBlackHoleCode is called from CmmParse.
484
485   let  eager_blackholing =  not (gopt Opt_SccProfilingOn dflags)
486                          && gopt Opt_EagerBlackHoling dflags
487              -- Profiling needs slop filling (to support LDV
488              -- profiling), so currently eager blackholing doesn't
489              -- work with profiling.
490
491   whenC eager_blackholing $ do
492     tickyBlackHole (not is_single_entry)
493     stmtsC [
494        CmmStore (cmmOffsetW dflags (CmmReg nodeReg) (fixedHdrSize dflags))
495                 (CmmReg (CmmGlobal CurrentTSO)),
496        CmmCall (CmmPrim MO_WriteBarrier Nothing) [] [] CmmMayReturn,
497        CmmStore (CmmReg nodeReg) (CmmReg (CmmGlobal EagerBlackholeInfo))
498      ]
499 \end{code}
500
501 \begin{code}
502 setupUpdate :: ClosureInfo -> Code -> Code      -- Only called for closures with no args
503         -- Nota Bene: this function does not change Node (even if it's a CAF),
504         -- so that the cost centre in the original closure can still be
505         -- extracted by a subsequent enterCostCentre
506 setupUpdate closure_info code
507   | closureReEntrant closure_info
508   = code
509
510   | not (isStaticClosure closure_info)
511   = do
512    if not (closureUpdReqd closure_info)
513       then do tickyUpdateFrameOmitted; code
514       else do
515           tickyPushUpdateFrame
516           dflags <- getDynFlags
517           if blackHoleOnEntry closure_info &&
518              not (gopt Opt_SccProfilingOn dflags) &&
519              gopt Opt_EagerBlackHoling dflags
520                then pushBHUpdateFrame (CmmReg nodeReg) code
521                else pushUpdateFrame   (CmmReg nodeReg) code
522   
523   | otherwise   -- A static closure
524   = do  { tickyUpdateBhCaf closure_info
525
526         ; if closureUpdReqd closure_info
527           then do       -- Blackhole the (updatable) CAF:
528                 { upd_closure <- link_caf closure_info True
529                 ; pushBHUpdateFrame upd_closure code }
530           else do
531                 { -- krc: removed some ticky-related code here.
532                 ; tickyUpdateFrameOmitted
533                 ; code }
534     }
535
536
537 -----------------------------------------------------------------------------
538 -- Entering a CAF
539 --
540 -- When a CAF is first entered, it creates a black hole in the heap,
541 -- and updates itself with an indirection to this new black hole.
542 --
543 -- We update the CAF with an indirection to a newly-allocated black
544 -- hole in the heap.  We also set the blocking queue on the newly
545 -- allocated black hole to be empty.
546 --
547 -- Why do we make a black hole in the heap when we enter a CAF?
548 --    
549 --     - for a  generational garbage collector, which needs a fast
550 --       test for whether an updatee is in an old generation or not
551 --
552 --     - for the parallel system, which can implement updates more
553 --       easily if the updatee is always in the heap. (allegedly).
554 --
555 -- When debugging, we maintain a separate CAF list so we can tell when
556 -- a CAF has been garbage collected.
557
558 -- newCAF must be called before the itbl ptr is overwritten, since
559 -- newCAF records the old itbl ptr in order to do CAF reverting
560 -- (which Hugs needs to do in order that combined mode works right.)
561 --
562
563 -- ToDo [Feb 04]  This entire link_caf nonsense could all be moved
564 -- into the "newCAF" RTS procedure, which we call anyway, including
565 -- the allocation of the black-hole indirection closure.
566 -- That way, code size would fall, the CAF-handling code would 
567 -- be closer together, and the compiler wouldn't need to know
568 -- about off_indirectee etc.
569
570 link_caf :: ClosureInfo
571          -> Bool                -- True <=> updatable, False <=> single-entry
572          -> FCode CmmExpr       -- Returns amode for closure to be updated
573 -- To update a CAF we must allocate a black hole, link the CAF onto the
574 -- CAF list, then update the CAF to point to the fresh black hole.
575 -- This function returns the address of the black hole, so it can be
576 -- updated with the new value when available.  The reason for all of this
577 -- is that we only want to update dynamic heap objects, not static ones,
578 -- so that generational GC is easier.
579 link_caf cl_info _is_upd = do
580   { dflags    <- getDynFlags
581     -- Alloc black hole specifying CC_HDR(Node) as the cost centre
582   ; let use_cc   = costCentreFrom dflags (CmmReg nodeReg)
583         blame_cc = use_cc
584         tso      = CmmReg (CmmGlobal CurrentTSO)
585   ; hp_offset <- allocDynClosure bh_cl_info use_cc blame_cc
586                                  [(tso, fixedHdrSize dflags)]
587   ; hp_rel    <- getHpRelOffset hp_offset
588
589         -- Call the RTS function newCAF to add the CAF to the CafList
590         -- so that the garbage collector can find them
591         -- This must be done *before* the info table pointer is overwritten, 
592         -- because the old info table ptr is needed for reversion
593   ; ret <- newTemp (bWord dflags)
594   ; emitRtsCallGen [CmmHinted ret NoHint] rtsPackageId (fsLit "newCAF")
595       [ CmmHinted (CmmReg (CmmGlobal BaseReg)) AddrHint,
596         CmmHinted (CmmReg nodeReg) AddrHint,
597         CmmHinted hp_rel AddrHint ]
598       (Just [node])
599         -- node is live, so save it.
600
601   -- see Note [atomic CAF entry] in rts/sm/Storage.c
602   ; emitIf (CmmMachOp (mo_wordEq dflags) [ CmmReg (CmmLocal ret), zeroExpr dflags]) $
603         -- re-enter R1.  Doing this directly is slightly dodgy; we're
604         -- assuming lots of things, like the stack pointer hasn't
605         -- moved since we entered the CAF.
606         let target = entryCode dflags (closureInfoPtr dflags (CmmReg nodeReg)) in
607         stmtC (CmmJump target $ Just [node])
608
609   ; returnFC hp_rel }
610   where
611     bh_cl_info :: ClosureInfo
612     bh_cl_info = cafBlackHoleClosureInfo cl_info
613 \end{code}
614
615
616 %************************************************************************
617 %*                                                                      *
618 \subsection[CgClosure-Description]{Profiling Closure Description.}
619 %*                                                                      *
620 %************************************************************************
621
622 For "global" data constructors the description is simply occurrence
623 name of the data constructor itself.  Otherwise it is determined by
624 @closureDescription@ from the let binding information.
625
626 \begin{code}
627 closureDescription :: DynFlags
628                    -> Module    -- Module
629                    -> Name      -- Id of closure binding
630                    -> String
631         -- Not called for StgRhsCon which have global info tables built in
632         -- CgConTbls.lhs with a description generated from the data constructor
633 closureDescription dflags mod_name name
634   = showSDocDumpOneLine dflags (char '<' <>
635                     (if isExternalName name
636                       then ppr name -- ppr will include the module name prefix
637                       else pprModule mod_name <> char '.' <> ppr name) <>
638                     char '>')
639    -- showSDocDumpOneLine, because we want to see the unique on the Name.
640 \end{code}
641