[project @ 2001-09-10 10:07:21 by rje]
[ghc-hetmet.git] / ghc / compiler / codeGen / CgClosure.lhs
1 %
2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
3 %
4 % $Id: CgClosure.lhs,v 1.48 2001/09/10 10:07:21 rje Exp $
5 %
6 \section[CgClosure]{Code generation for closures}
7
8 This module provides the support code for @StgToAbstractC@ to deal
9 with {\em closures} on the RHSs of let(rec)s.  See also
10 @CgCon@, which deals with constructors.
11
12 \begin{code}
13 module CgClosure ( cgTopRhsClosure, 
14                    cgStdRhsClosure, 
15                    cgRhsClosure, 
16                    closureCodeBody ) where
17
18 #include "HsVersions.h"
19
20 import {-# SOURCE #-} CgExpr ( cgExpr )
21
22 import CgMonad
23 import AbsCSyn
24 import StgSyn
25
26 import AbsCUtils        ( mkAbstractCs, getAmodeRep )
27 import CgBindery        ( getCAddrMode, getArgAmodes,
28                           getCAddrModeAndInfo, bindNewToNode,
29                           bindNewToStack,
30                           bindNewToReg, bindArgsToRegs,
31                           stableAmodeIdInfo, heapIdInfo, CgIdInfo
32                         )
33 import CgUpdate         ( pushUpdateFrame )
34 import CgHeapery        ( allocDynClosure, 
35                           fetchAndReschedule, yield,  -- HWL
36                           fastEntryChecks, thunkChecks
37                         )
38 import CgStackery       ( mkTaggedVirtStkOffsets, freeStackSlots )
39 import CgUsages         ( adjustSpAndHp, setRealAndVirtualSp, getVirtSp,
40                           getSpRelOffset, getHpRelOffset
41                         )
42 import CLabel           ( CLabel, mkClosureLabel, mkFastEntryLabel,
43                           mkRednCountsLabel, mkInfoTableLabel
44                         )
45 import ClosureInfo      -- lots and lots of stuff
46 import CmdLineOpts      ( opt_GranMacros, opt_SccProfilingOn, opt_DoTickyProfiling )
47 import CostCentre       
48 import Id               ( Id, idName, idType, idPrimRep )
49 import Name             ( Name, isLocalName )
50 import Module           ( Module, pprModule )
51 import ListSetOps       ( minusList )
52 import PrimRep          ( PrimRep(..) )
53 import PprType          ( showTypeCategory )
54 import Util             ( isIn )
55 import CmdLineOpts      ( opt_SccProfilingOn )
56 import Outputable
57
58 import Name             ( nameOccName )
59 import OccName          ( occNameFS )
60 import FastTypes        ( iBox )
61 \end{code}
62
63 %********************************************************
64 %*                                                      *
65 \subsection[closures-no-free-vars]{Top-level closures}
66 %*                                                      *
67 %********************************************************
68
69 For closures bound at top level, allocate in static space.
70 They should have no free variables.
71
72 \begin{code}
73 cgTopRhsClosure :: Id
74                 -> CostCentreStack      -- Optional cost centre annotation
75                 -> StgBinderInfo
76                 -> [Id]         -- Args
77                 -> StgExpr
78                 -> LambdaFormInfo
79                 -> FCode (Id, CgIdInfo)
80
81 cgTopRhsClosure id ccs binder_info args body lf_info
82   = 
83     -- LAY OUT THE OBJECT
84     let
85         name          = idName id
86         closure_info  = layOutStaticNoFVClosure name lf_info
87         closure_label = mkClosureLabel name
88         cg_id_info    = stableAmodeIdInfo id (CLbl closure_label PtrRep) lf_info
89     in
90
91         -- BUILD THE OBJECT (IF NECESSARY)
92     ({- if staticClosureRequired name binder_info lf_info
93      then -}
94         (if opt_SccProfilingOn 
95           then
96              absC (CStaticClosure
97                 closure_label   -- Labelled with the name on lhs of defn
98                 closure_info
99                 (mkCCostCentreStack ccs)
100                 [])             -- No fields
101           else
102              absC (CStaticClosure
103                 closure_label   -- Labelled with the name on lhs of defn
104                 closure_info
105                 (panic "absent cc")
106                 [])             -- No fields
107         )
108
109      {- else
110         nopC -}
111                                                         `thenC`
112
113         -- GENERATE THE INFO TABLE (IF NECESSARY)
114     forkClosureBody (closureCodeBody binder_info closure_info
115                                          ccs args body)
116
117     ) `thenC`
118
119     returnFC (id, cg_id_info)
120
121 \end{code}
122
123 %********************************************************
124 %*                                                      *
125 \subsection[non-top-level-closures]{Non top-level closures}
126 %*                                                      *
127 %********************************************************
128
129 For closures with free vars, allocate in heap.
130
131 \begin{code}
132 cgStdRhsClosure
133         :: Id
134         -> CostCentreStack      -- Optional cost centre annotation
135         -> StgBinderInfo
136         -> [Id]                 -- Free vars
137         -> [Id]                 -- Args
138         -> StgExpr
139         -> LambdaFormInfo
140         -> [StgArg]             -- payload
141         -> FCode (Id, CgIdInfo)
142
143 cgStdRhsClosure binder cc binder_info fvs args body lf_info payload
144                 -- AHA!  A STANDARD-FORM THUNK
145   = (
146         -- LAY OUT THE OBJECT
147     getArgAmodes payload                        `thenFC` \ amodes ->
148     let
149         (closure_info, amodes_w_offsets)
150           = layOutDynClosure (idName binder) getAmodeRep amodes lf_info
151
152         (use_cc, blame_cc) = chooseDynCostCentres cc args fvs body
153     in
154         -- BUILD THE OBJECT
155     allocDynClosure closure_info use_cc blame_cc amodes_w_offsets
156     )
157                 `thenFC` \ heap_offset ->
158
159         -- RETURN
160     returnFC (binder, heapIdInfo binder heap_offset lf_info)
161 \end{code}
162
163 Here's the general case.
164
165 \begin{code}
166 cgRhsClosure    :: Id
167                 -> CostCentreStack      -- Optional cost centre annotation
168                 -> StgBinderInfo
169                 -> [Id]                 -- Free vars
170                 -> [Id]                 -- Args
171                 -> StgExpr
172                 -> LambdaFormInfo
173                 -> FCode (Id, CgIdInfo)
174
175 cgRhsClosure binder cc binder_info fvs args body lf_info
176   = (
177         -- LAY OUT THE OBJECT
178         --
179         -- If the binder is itself a free variable, then don't store
180         -- it in the closure.  Instead, just bind it to Node on entry.
181         -- NB we can be sure that Node will point to it, because we
182         -- havn't told mkClosureLFInfo about this; so if the binder
183         -- *was* a free var of its RHS, mkClosureLFInfo thinks it *is*
184         -- stored in the closure itself, so it will make sure that
185         -- Node points to it...
186     let
187         is_elem        = isIn "cgRhsClosure"
188
189         binder_is_a_fv = binder `is_elem` fvs
190         reduced_fvs    = if binder_is_a_fv
191                          then fvs `minusList` [binder]
192                          else fvs
193     in
194     mapFCs getCAddrModeAndInfo reduced_fvs      `thenFC` \ fvs_w_amodes_and_info ->
195     let
196         closure_info :: ClosureInfo
197         bind_details :: [((Id, CAddrMode, LambdaFormInfo), VirtualHeapOffset)]
198
199         (closure_info, bind_details)
200           = layOutDynClosure (idName binder) get_kind fvs_w_amodes_and_info lf_info
201
202         bind_fv ((id, _, lf_info), offset) = bindNewToNode id offset lf_info
203
204         amodes_w_offsets = [(amode,offset) | ((_,amode,_), offset) <- bind_details]
205
206         get_kind (id, _, _) = idPrimRep id
207     in
208         -- BUILD ITS INFO TABLE AND CODE
209     forkClosureBody (
210                 -- Bind the fvs
211             mapCs bind_fv bind_details `thenC`
212
213                 -- Bind the binder itself, if it is a free var
214             (if binder_is_a_fv then
215                 bindNewToReg binder node lf_info
216             else
217                 nopC)                                   `thenC`
218
219                 -- Compile the body
220             closureCodeBody binder_info closure_info cc args body
221     )   `thenC`
222
223         -- BUILD THE OBJECT
224     let
225         (use_cc, blame_cc) = chooseDynCostCentres cc args fvs body
226     in
227     allocDynClosure closure_info use_cc blame_cc amodes_w_offsets
228     )           `thenFC` \ heap_offset ->
229
230         -- RETURN
231     returnFC (binder, heapIdInfo binder heap_offset lf_info)
232 \end{code}
233
234 %************************************************************************
235 %*                                                                      *
236 \subsection[code-for-closures]{The code for closures}
237 %*                                                                      *
238 %************************************************************************
239
240 \begin{code}
241 closureCodeBody :: StgBinderInfo
242                 -> ClosureInfo     -- Lots of information about this closure
243                 -> CostCentreStack -- Optional cost centre attached to closure
244                 -> [Id]
245                 -> StgExpr
246                 -> Code
247 \end{code}
248
249 There are two main cases for the code for closures.  If there are {\em
250 no arguments}, then the closure is a thunk, and not in normal form.
251 So it should set up an update frame (if it is shared).  Also, it has
252 no argument satisfaction check, so fast and slow entry-point labels
253 are the same.
254
255 \begin{code}
256 closureCodeBody binder_info closure_info cc [] body
257   = -- thunks cannot have a primitive type!
258     getAbsC body_code   `thenFC` \ body_absC ->
259     moduleName          `thenFC` \ mod_name ->
260
261     absC (CClosureInfoAndCode closure_info body_absC Nothing
262                               (cl_descr mod_name))
263   where
264     cl_descr mod_name = closureDescription mod_name (closureName closure_info)
265
266     body_label   = entryLabelFromCI closure_info
267     
268     is_box  = case body of { StgApp fun [] -> True; _ -> False }
269
270     body_code   = profCtrC SLIT("TICK_ENT_THK") []              `thenC`
271                   thunkWrapper closure_info body_label (
272                         -- We only enter cc after setting up update so that cc
273                         -- of enclosing scope will be recorded in update frame
274                         -- CAF/DICT functions will be subsumed by this enclosing cc
275                     enterCostCentreCode closure_info cc IsThunk is_box `thenC`
276                     cgExpr body)
277 \end{code}
278
279 If there is {\em at least one argument}, then this closure is in
280 normal form, so there is no need to set up an update frame.  On the
281 other hand, we do have to check that there are enough args, and
282 perform an update if not!
283
284 The Macros for GrAnSim are produced at the beginning of the
285 argSatisfactionCheck (by calling fetchAndReschedule).  There info if
286 Node points to closure is available. -- HWL
287
288 \begin{code}
289 closureCodeBody binder_info closure_info cc all_args body
290   = getEntryConvention name lf_info
291                        (map idPrimRep all_args)         `thenFC` \ entry_conv ->
292
293     -- get the current virtual Sp (it might not be zero, eg. if we're
294     -- compiling a let-no-escape).
295     getVirtSp `thenFC` \vSp ->
296
297     let
298         -- Figure out what is needed and what isn't
299
300         -- SDM: need everything for now in case the heap/stack check refers
301         -- to it. (ToDo)
302         slow_code_needed   = True 
303                    --slowFunEntryCodeRequired name binder_info entry_conv
304         info_table_needed  = True
305                    --funInfoTableRequired name binder_info lf_info
306
307         -- Arg mapping for standard (slow) entry point; all args on stack,
308         -- with tagging.
309         (sp_all_args, arg_offsets, _)
310            = mkTaggedVirtStkOffsets vSp idPrimRep all_args
311
312         -- Arg mapping for the fast entry point; as many args as poss in
313         -- registers; the rest on the stack
314         --      arg_regs are the registers used for arg passing
315         --      stk_args are the args which are passed on the stack
316         --
317         -- Args passed on the stack are tagged, but the tags may not
318         -- actually be present (just gaps) if the function is called 
319         -- by jumping directly to the fast entry point.
320         --
321         arg_regs = case entry_conv of
322                 DirectEntry lbl arity regs -> regs
323                 other                      -> []  -- "(HWL ignored; no args passed in regs)"
324
325         num_arg_regs = length arg_regs
326         
327         (reg_args, stk_args) = splitAt num_arg_regs all_args
328
329         (sp_stk_args, stk_offsets, stk_tags)
330           = mkTaggedVirtStkOffsets vSp idPrimRep stk_args
331
332         -- HWL; Note: empty list of live regs in slow entry code
333         -- Old version (reschedule combined with heap check);
334         -- see argSatisfactionCheck for new version
335         --slow_entry_code = forceHeapCheck [node] True slow_entry_code'
336         --                where node = UnusedReg PtrRep 1
337         --slow_entry_code = forceHeapCheck [] True slow_entry_code'
338
339         slow_entry_code
340           = profCtrC SLIT("TICK_ENT_FUN_STD") [
341                     CLbl ticky_ctr_label DataPtrRep
342             ] `thenC`
343
344             -- Bind args, and record expected position of stk ptrs
345             mapCs bindNewToStack arg_offsets                `thenC`
346             setRealAndVirtualSp sp_all_args                 `thenC`
347
348             argSatisfactionCheck closure_info   arg_regs            `thenC`
349
350             -- OK, so there are enough args.  Now we need to stuff as
351             -- many of them in registers as the fast-entry code
352             -- expects. Note that the zipWith will give up when it hits
353             -- the end of arg_regs.
354
355             mapFCs getCAddrMode all_args            `thenFC` \ stk_amodes ->
356             absC (mkAbstractCs (zipWith assign_to_reg arg_regs stk_amodes)) 
357                                                             `thenC`
358
359             -- Now adjust real stack pointers (no need to adjust Hp,
360             -- but call this function for convenience).
361             adjustSpAndHp sp_stk_args                   `thenC`
362
363             absC (CFallThrough (CLbl fast_label CodePtrRep))
364
365         assign_to_reg reg_id amode = CAssign (CReg reg_id) amode
366
367         -- HWL
368         -- Old version (reschedule combined with heap check);
369         -- see argSatisfactionCheck for new version
370         -- fast_entry_code = forceHeapCheck [] True fast_entry_code'
371
372         fast_entry_code = do
373                 mod_name <- moduleName
374                 profCtrC SLIT("TICK_CTR") [ 
375                         CLbl ticky_ctr_label DataPtrRep,
376                         mkCString (_PK_ (ppr_for_ticky_name mod_name name)),
377                         mkIntCLit stg_arity,    -- total # of args
378                         mkIntCLit sp_stk_args,  -- # passed on stk
379                         mkCString (_PK_ (map (showTypeCategory . idType) all_args))
380                         ] 
381                 let prof = 
382                         profCtrC SLIT("TICK_ENT_FUN_DIRECT") [
383                                 CLbl ticky_ctr_label DataPtrRep
384                         ] 
385
386 -- Nuked for now; see comment at end of file
387 --                  CString (_PK_ (show_wrapper_name wrapper_maybe)),
388 --                  CString (_PK_ (show_wrapper_arg_kinds wrapper_maybe))
389
390
391                 -- Bind args to regs/stack as appropriate, and
392                 -- record expected position of sps.
393                 bindArgsToRegs reg_args arg_regs                    
394                 mapCs bindNewToStack stk_offsets                    
395                 setRealAndVirtualSp sp_stk_args             
396
397                 -- free up the stack slots containing tags
398                 freeStackSlots (map fst stk_tags)
399
400                 -- Enter the closures cc, if required
401                 enterCostCentreCode closure_info cc IsFunction False
402
403                 -- Do the business
404                 funWrapper closure_info arg_regs stk_tags info_label 
405                         (prof >> cgExpr body)
406     in
407
408     setTickyCtrLabel ticky_ctr_label (
409
410         -- Make a labelled code-block for the slow and fast entry code
411       forkAbsC (if slow_code_needed then slow_entry_code else absC AbsCNop)
412                                 `thenFC` \ slow_abs_c ->
413       forkAbsC fast_entry_code  `thenFC` \ fast_abs_c ->
414       moduleName                `thenFC` \ mod_name ->
415
416         -- Now either construct the info table, or put the fast code in alone
417         -- (We never have slow code without an info table)
418         -- XXX probably need the info table and slow entry code in case of
419         -- a heap check failure.
420       absC (
421        if info_table_needed then
422           CClosureInfoAndCode closure_info slow_abs_c (Just fast_abs_c)
423                         (cl_descr mod_name)
424        else
425         CCodeBlock fast_label fast_abs_c
426        )
427     )
428   where
429     ticky_ctr_label = mkRednCountsLabel name
430
431     stg_arity = length all_args
432     lf_info = closureLFInfo closure_info
433
434     cl_descr mod_name = closureDescription mod_name name
435
436         -- Manufacture labels
437     name       = closureName closure_info
438     fast_label = mkFastEntryLabel name stg_arity
439     info_label = mkInfoTableLabel name
440
441
442 -- When printing the name of a thing in a ticky file, we want to
443 -- give the module name even for *local* things.   We print
444 -- just "x (M)" rather that "M.x" to distinguish them from the global kind.
445 ppr_for_ticky_name mod_name name
446   | isLocalName name = showSDocDebug (ppr name <+> (parens (ppr mod_name)))
447   | otherwise        = showSDocDebug (ppr name)
448 \end{code}
449
450 For lexically scoped profiling we have to load the cost centre from
451 the closure entered, if the costs are not supposed to be inherited.
452 This is done immediately on entering the fast entry point.
453
454 Load current cost centre from closure, if not inherited.
455 Node is guaranteed to point to it, if profiling and not inherited.
456
457 \begin{code}
458 data IsThunk = IsThunk | IsFunction -- Bool-like, local
459 -- #ifdef DEBUG
460         deriving Eq
461 -- #endif
462
463 enterCostCentreCode 
464    :: ClosureInfo -> CostCentreStack
465    -> IsThunk
466    -> Bool      -- is_box: this closure is a special box introduced by SCCfinal
467    -> Code
468
469 enterCostCentreCode closure_info ccs is_thunk is_box
470   = if not opt_SccProfilingOn then
471         nopC
472     else
473         ASSERT(not (noCCSAttached ccs))
474
475         if isSubsumedCCS ccs then
476             ASSERT(isToplevClosure closure_info)
477             ASSERT(is_thunk == IsFunction)
478             costCentresC SLIT("ENTER_CCS_FSUB") []
479  
480         else if isCurrentCCS ccs then 
481             if re_entrant && not is_box
482                 then costCentresC SLIT("ENTER_CCS_FCL") [CReg node]
483                 else costCentresC SLIT("ENTER_CCS_TCL") [CReg node]
484
485         else if isCafCCS ccs then
486             ASSERT(isToplevClosure closure_info)
487             ASSERT(is_thunk == IsThunk)
488                 -- might be a PAP, in which case we want to subsume costs
489             if re_entrant
490                 then costCentresC SLIT("ENTER_CCS_FSUB") []
491                 else costCentresC SLIT("ENTER_CCS_CAF") c_ccs
492
493         else panic "enterCostCentreCode"
494
495    where
496         c_ccs = [mkCCostCentreStack ccs]
497         re_entrant = closureReEntrant closure_info
498 \end{code}
499
500 %************************************************************************
501 %*                                                                      *
502 \subsubsection[pre-closure-code-stuff]{Pre-closure-code code}
503 %*                                                                      *
504 %************************************************************************
505
506 The argument-satisfaction check code is placed after binding
507 the arguments to their stack locations. Hence, the virtual stack
508 pointer is pointing after all the args, and virtual offset 1 means
509 the base of frame and hence most distant arg.  Hence
510 virtual offset 0 is just beyond the most distant argument; the
511 relative offset of this word tells how many words of arguments
512 are expected.
513
514 \begin{code}
515 argSatisfactionCheck :: ClosureInfo -> [MagicId] {-GRAN-} -> Code
516
517 argSatisfactionCheck closure_info arg_regs
518
519   = nodeMustPointToIt (closureLFInfo closure_info)   `thenFC` \ node_points ->
520
521 --      let
522 --         emit_gran_macros = opt_GranMacros
523 --      in
524
525     -- HWL  ngo' ngoq:
526     -- absC (CMacroStmt GRAN_FETCH [])                  `thenC`
527     -- forceHeapCheck [] node_points (absC AbsCNop)                     `thenC`
528     --(if opt_GranMacros
529     --  then if node_points 
530     --         then fetchAndReschedule  arg_regs node_points 
531     --         else yield arg_regs node_points
532     --  else absC AbsCNop)                       `thenC`
533
534         getSpRelOffset 0        `thenFC` \ (SpRel sp) ->
535         let
536             off     = iBox sp
537             rel_arg = mkIntCLit off
538         in
539         ASSERT(off /= 0)
540         if node_points then
541             absC (CMacroStmt ARGS_CHK [rel_arg]) -- node already points
542         else
543             absC (CMacroStmt ARGS_CHK_LOAD_NODE [rel_arg, set_Node_to_this])
544   where
545     -- We must tell the arg-satis macro whether Node is pointing to
546     -- the closure or not.  If it isn't so pointing, then we give to
547     -- the macro the (static) address of the closure.
548
549     set_Node_to_this = CLbl (closureLabelFromCI closure_info) PtrRep
550 \end{code}
551
552 %************************************************************************
553 %*                                                                      *
554 \subsubsection[closure-code-wrappers]{Wrappers around closure code}
555 %*                                                                      *
556 %************************************************************************
557
558 \begin{code}
559 thunkWrapper:: ClosureInfo -> CLabel -> Code -> Code
560 thunkWrapper closure_info lbl thunk_code
561   =     -- Stack and heap overflow checks
562     nodeMustPointToIt (closureLFInfo closure_info) `thenFC` \ node_points ->
563
564     -- HWL: insert macros for GrAnSim; 2 versions depending on liveness of node
565     -- (we prefer fetchAndReschedule-style context switches to yield ones)
566     (if opt_GranMacros
567        then if node_points 
568               then fetchAndReschedule [] node_points 
569               else yield [] node_points
570        else absC AbsCNop)                       `thenC`
571
572         -- stack and/or heap checks
573     thunkChecks lbl node_points (
574
575         -- Overwrite with black hole if necessary
576     blackHoleIt closure_info node_points  `thenC`
577
578     setupUpdate closure_info (                  -- setupUpdate *encloses* the rest
579
580         -- Finally, do the business
581     thunk_code
582     ))
583
584 funWrapper :: ClosureInfo       -- Closure whose code body this is
585            -> [MagicId]         -- List of argument registers (if any)
586            -> [(VirtualSpOffset,Int)] -- tagged stack slots
587            -> CLabel            -- info table for heap check ret.
588            -> Code              -- Body of function being compiled
589            -> Code
590 funWrapper closure_info arg_regs stk_tags info_label fun_body
591   =     -- Stack overflow check
592     nodeMustPointToIt (closureLFInfo closure_info)      `thenFC` \ node_points ->
593     -- HWL   chu' ngoq:
594     (if opt_GranMacros
595        then yield arg_regs node_points
596        else absC AbsCNop)                                 `thenC`
597
598         -- heap and/or stack checks
599     fastEntryChecks arg_regs stk_tags info_label node_points (
600
601         -- Finally, do the business
602     fun_body
603     )
604 \end{code}
605
606
607 %************************************************************************
608 %*                                                                      *
609 \subsubsubsection[update-and-BHs]{Update and black-hole wrappers}
610 %*                                                                      *
611 %************************************************************************
612
613
614 \begin{code}
615 blackHoleIt :: ClosureInfo -> Bool -> Code      -- Only called for closures with no args
616
617 blackHoleIt closure_info node_points
618   = if blackHoleOnEntry closure_info && node_points
619     then
620         let
621           info_label = infoTableLabelFromCI closure_info
622           args = [ CLbl info_label DataPtrRep ]
623         in
624         absC (if closureSingleEntry(closure_info) then
625                 CMacroStmt UPD_BH_SINGLE_ENTRY args
626               else
627                 CMacroStmt UPD_BH_UPDATABLE args)
628     else
629         nopC
630 \end{code}
631
632 \begin{code}
633 setupUpdate :: ClosureInfo -> Code -> Code      -- Only called for closures with no args
634         -- Nota Bene: this function does not change Node (even if it's a CAF),
635         -- so that the cost centre in the original closure can still be
636         -- extracted by a subsequent ENTER_CC_TCL
637
638 -- I've tidied up the code for this function, but it should still do the same as
639 -- it did before (modulo ticky stuff).  KSW 1999-04.
640 setupUpdate closure_info code
641  = if closureReEntrant closure_info
642    then
643      code
644    else
645      case (closureUpdReqd closure_info, isStaticClosure closure_info) of
646        (False,False) -> profCtrC SLIT("TICK_UPDF_OMITTED") [] `thenC`
647                         code
648        (False,True ) -> (if opt_DoTickyProfiling
649                          then
650                          -- blackhole the SE CAF
651                            link_caf seCafBlackHoleClosureInfo `thenFC` \ _ -> nopC
652                          else
653                            nopC)                                                       `thenC`
654                         profCtrC SLIT("TICK_UPD_CAF_BH_SINGLE_ENTRY") [mkCString cl_name] `thenC`
655                         profCtrC SLIT("TICK_UPDF_OMITTED") []                           `thenC`
656                         code
657        (True ,False) -> pushUpdateFrame (CReg node) code
658        (True ,True ) -> -- blackhole the (updatable) CAF:
659                         link_caf cafBlackHoleClosureInfo           `thenFC` \ update_closure ->
660                         profCtrC SLIT("TICK_UPD_CAF_BH_UPDATABLE") [mkCString cl_name]    `thenC`
661                         pushUpdateFrame update_closure code
662  where
663    cl_name :: FAST_STRING
664    cl_name  = (occNameFS . nameOccName . closureName) closure_info
665
666    link_caf :: (ClosureInfo -> ClosureInfo)  -- function yielding BH closure_info
667             -> FCode CAddrMode               -- Returns amode for closure to be updated
668    link_caf bhCI
669      = -- To update a CAF we must allocate a black hole, link the CAF onto the
670        -- CAF list, then update the CAF to point to the fresh black hole.
671        -- This function returns the address of the black hole, so it can be
672        -- updated with the new value when available.
673
674              -- Alloc black hole specifying CC_HDR(Node) as the cost centre
675        let
676            use_cc   = CMacroExpr PtrRep CCS_HDR [nodeReg]
677            blame_cc = use_cc
678        in
679        allocDynClosure (bhCI closure_info) use_cc blame_cc []  `thenFC` \ heap_offset ->
680        getHpRelOffset heap_offset                              `thenFC` \ hp_rel ->
681        let  amode = CAddr hp_rel
682        in
683        absC (CMacroStmt UPD_CAF [CReg node, amode])            `thenC`
684        returnFC amode
685 \end{code}
686
687 %************************************************************************
688 %*                                                                      *
689 \subsection[CgClosure-Description]{Profiling Closure Description.}
690 %*                                                                      *
691 %************************************************************************
692
693 For "global" data constructors the description is simply occurrence
694 name of the data constructor itself (see \ref{CgConTbls-info-tables}).
695
696 Otherwise it is determind by @closureDescription@ from the let
697 binding information.
698
699 \begin{code}
700 closureDescription :: Module            -- Module
701                    -> Name              -- Id of closure binding
702                    -> String
703
704         -- Not called for StgRhsCon which have global info tables built in
705         -- CgConTbls.lhs with a description generated from the data constructor
706
707 closureDescription mod_name name
708   = showSDoc (
709         hcat [char '<',
710                    pprModule mod_name,
711                    char '.',
712                    ppr name,
713                    char '>'])
714 \end{code}
715
716 \begin{code}
717 chooseDynCostCentres ccs args fvs body
718   = let
719         use_cc -- cost-centre we record in the object
720           = if currentOrSubsumedCCS ccs
721             then CReg CurCostCentre
722             else mkCCostCentreStack ccs
723
724         blame_cc -- cost-centre on whom we blame the allocation
725           = case (args, fvs, body) of
726               ([], _, StgApp fun [{-no args-}])
727                 -> mkCCostCentreStack overheadCCS
728               _ -> use_cc
729
730             -- if it's an utterly trivial RHS, then it must be
731             -- one introduced by boxHigherOrderArgs for profiling,
732             -- so we charge it to "OVERHEAD".
733
734             -- This looks like a HACK to me --SDM
735     in
736     (use_cc, blame_cc)
737 \end{code}
738
739
740