ghc/compiler/codeGen/CgClosure.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
   3 %
   4 % $Id: CgClosure.lhs,v 1.59 2002/12/11 15:36:25 simonmar 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 CgBindery
  24 import CgUpdate         ( pushUpdateFrame )
  25 import CgHeapery
  26 import CgStackery
  27 import CgUsages
  28 import ClosureInfo      -- lots and lots of stuff
  29
  30 import AbsCUtils        ( getAmodeRep, mkAbstractCs )
  31 import AbsCSyn
  32 import CLabel
  33
  34 import StgSyn
  35 import CmdLineOpts      ( opt_GranMacros, opt_SccProfilingOn, opt_DoTickyProfiling )
  36 import CostCentre
  37 import Id               ( Id, idName, idType, idPrimRep )
  38 import Name             ( Name, isInternalName )
  39 import Module           ( Module, pprModule )
  40 import ListSetOps       ( minusList )
  41 import PrimRep          ( PrimRep(..), getPrimRepSize )
  42 import PprType          ( showTypeCategory )
  43 import Util             ( isIn, splitAtList )
  44 import CmdLineOpts      ( opt_SccProfilingOn )
  45 import Outputable
  46 import FastString
  47
  48 import Name             ( nameOccName )
  49 import OccName          ( occNameFS )
  50 \end{code}
  51
  52 %********************************************************
  53 %*                                                      *
  54 \subsection[closures-no-free-vars]{Top-level closures}
  55 %*                                                      *
  56 %********************************************************
  57
  58 For closures bound at top level, allocate in static space.
  59 They should have no free variables.
  60
  61 \begin{code}
  62 cgTopRhsClosure :: Id
  63                 -> CostCentreStack      -- Optional cost centre annotation
  64                 -> StgBinderInfo
  65                 -> SRT
  66                 -> [Id]         -- Args
  67                 -> StgExpr
  68                 -> LambdaFormInfo
  69                 -> FCode (Id, CgIdInfo)
  70
  71 cgTopRhsClosure id ccs binder_info srt args body lf_info
  72   =
  73     -- LAY OUT THE OBJECT
  74     getSRTInfo srt              `thenFC` \ srt_info ->
  75     moduleName                  `thenFC` \ mod_name ->
  76     let
  77         name          = idName id
  78         descr         = closureDescription mod_name name
  79         closure_info  = layOutStaticNoFVClosure id lf_info srt_info descr
  80         closure_label = mkClosureLabel name
  81         cg_id_info    = stableAmodeIdInfo id (CLbl closure_label PtrRep) lf_info
  82     in
  83
  84         -- BUILD THE OBJECT (IF NECESSARY)
  85     (
  86      ({- if staticClosureRequired name binder_info lf_info
  87       then -}
  88         absC (mkStaticClosure closure_label closure_info ccs [] True)
  89       {- else
  90         nopC -}
  91      )
  92                                                         `thenC`
  93
  94         -- GENERATE THE INFO TABLE (IF NECESSARY)
  95     forkClosureBody (closureCodeBody binder_info closure_info
  96                                          ccs args body)
  97
  98     ) `thenC`
  99
 100     returnFC (id, cg_id_info)
 101
 102 \end{code}
 103
 104 %********************************************************
 105 %*                                                      *
 106 \subsection[non-top-level-closures]{Non top-level closures}
 107 %*                                                      *
 108 %********************************************************
 109
 110 For closures with free vars, allocate in heap.
 111
 112 \begin{code}
 113 cgStdRhsClosure
 114         :: Id
 115         -> CostCentreStack      -- Optional cost centre annotation
 116         -> StgBinderInfo
 117         -> [Id]                 -- Free vars
 118         -> [Id]                 -- Args
 119         -> StgExpr
 120         -> LambdaFormInfo
 121         -> [StgArg]             -- payload
 122         -> FCode (Id, CgIdInfo)
 123
 124 cgStdRhsClosure binder cc binder_info fvs args body lf_info payload
 125                 -- AHA!  A STANDARD-FORM THUNK
 126   = (
 127         -- LAY OUT THE OBJECT
 128     getArgAmodes payload                `thenFC` \ amodes ->
 129     moduleName                          `thenFC` \ mod_name ->
 130     let
 131         descr = closureDescription mod_name (idName binder)
 132
 133         (closure_info, amodes_w_offsets)
 134           = layOutDynClosure binder getAmodeRep amodes lf_info NoC_SRT descr
 135                 -- No SRT for a standard-form closure
 136
 137         (use_cc, blame_cc) = chooseDynCostCentres cc args fvs body
 138     in
 139
 140         -- BUILD THE OBJECT
 141     allocDynClosure closure_info use_cc blame_cc amodes_w_offsets
 142     )
 143                 `thenFC` \ heap_offset ->
 144
 145         -- RETURN
 146     returnFC (binder, heapIdInfo binder heap_offset lf_info)
 147 \end{code}
 148
 149 Here's the general case.
 150
 151 \begin{code}
 152 cgRhsClosure    :: Id
 153                 -> CostCentreStack      -- Optional cost centre annotation
 154                 -> StgBinderInfo
 155                 -> SRT
 156                 -> [Id]                 -- Free vars
 157                 -> [Id]                 -- Args
 158                 -> StgExpr
 159                 -> LambdaFormInfo
 160                 -> FCode (Id, CgIdInfo)
 161
 162 cgRhsClosure binder cc binder_info srt fvs args body lf_info
 163   = (
 164         -- LAY OUT THE OBJECT
 165         --
 166         -- If the binder is itself a free variable, then don't store
 167         -- it in the closure.  Instead, just bind it to Node on entry.
 168         -- NB we can be sure that Node will point to it, because we
 169         -- havn't told mkClosureLFInfo about this; so if the binder
 170         -- *was* a free var of its RHS, mkClosureLFInfo thinks it *is*
 171         -- stored in the closure itself, so it will make sure that
 172         -- Node points to it...
 173     let
 174         is_elem        = isIn "cgRhsClosure"
 175
 176         binder_is_a_fv = binder `is_elem` fvs
 177         reduced_fvs    = if binder_is_a_fv
 178                          then fvs `minusList` [binder]
 179                          else fvs
 180     in
 181
 182     mapFCs getCAddrModeAndInfo reduced_fvs      `thenFC` \ fvs_w_amodes_and_info ->
 183     getSRTInfo srt                              `thenFC` \ srt_info ->
 184     moduleName                                  `thenFC` \ mod_name ->
 185     let
 186         descr = closureDescription mod_name (idName binder)
 187
 188         closure_info :: ClosureInfo
 189         bind_details :: [((Id, CAddrMode, LambdaFormInfo), VirtualHeapOffset)]
 190
 191         (closure_info, bind_details)
 192           = layOutDynClosure binder get_kind
 193                              fvs_w_amodes_and_info lf_info srt_info descr
 194
 195         bind_fv ((id, _, lf_info), offset) = bindNewToNode id offset lf_info
 196
 197         amodes_w_offsets = [(amode,offset) | ((_,amode,_), offset) <- bind_details]
 198
 199         get_kind (id, _, _) = idPrimRep id
 200     in
 201
 202         -- BUILD ITS INFO TABLE AND CODE
 203     forkClosureBody (
 204                 -- Bind the fvs
 205             mapCs bind_fv bind_details `thenC`
 206
 207                 -- Bind the binder itself, if it is a free var
 208             (if binder_is_a_fv then
 209                 bindNewToReg binder node lf_info
 210             else
 211                 nopC)                                   `thenC`
 212
 213                 -- Compile the body
 214             closureCodeBody binder_info closure_info cc args body
 215     )   `thenC`
 216
 217         -- BUILD THE OBJECT
 218     let
 219         (use_cc, blame_cc) = chooseDynCostCentres cc args fvs body
 220     in
 221     allocDynClosure closure_info use_cc blame_cc amodes_w_offsets
 222     )           `thenFC` \ heap_offset ->
 223
 224         -- RETURN
 225     returnFC (binder, heapIdInfo binder heap_offset lf_info)
 226 \end{code}
 227
 228 %************************************************************************
 229 %*                                                                      *
 230 \subsection[code-for-closures]{The code for closures}
 231 %*                                                                      *
 232 %************************************************************************
 233
 234 \begin{code}
 235 closureCodeBody :: StgBinderInfo
 236                 -> ClosureInfo     -- Lots of information about this closure
 237                 -> CostCentreStack -- Optional cost centre attached to closure
 238                 -> [Id]
 239                 -> StgExpr
 240                 -> Code
 241 \end{code}
 242
 243 There are two main cases for the code for closures.  If there are {\em
 244 no arguments}, then the closure is a thunk, and not in normal form.
 245 So it should set up an update frame (if it is shared).
 246
 247 \begin{code}
 248 closureCodeBody binder_info closure_info cc [] body
 249   = -- thunks cannot have a primitive type!
 250     getAbsC body_code   `thenFC` \ body_absC ->
 251
 252     absC (CClosureInfoAndCode closure_info body_absC)
 253   where
 254     is_box  = case body of { StgApp fun [] -> True; _ -> False }
 255
 256     ticky_ent_lit = if (isStaticClosure closure_info)
 257                     then FSLIT("TICK_ENT_STATIC_THK")
 258                     else FSLIT("TICK_ENT_DYN_THK")
 259
 260     body_code   = profCtrC ticky_ent_lit []                     `thenC`
 261                   -- node always points when profiling, so this is ok:
 262                   ldvEnter                                      `thenC`
 263                   thunkWrapper closure_info (
 264                         -- We only enter cc after setting up update so
 265                         -- that cc of enclosing scope will be recorded
 266                         -- in update frame CAF/DICT functions will be
 267                         -- subsumed by this enclosing cc
 268                     enterCostCentreCode closure_info cc IsThunk is_box `thenC`
 269                     cgExpr body
 270                   )
 271
 272 \end{code}
 273
 274 If there is /at least one argument/, then this closure is in
 275 normal form, so there is no need to set up an update frame.
 276
 277 The Macros for GrAnSim are produced at the beginning of the
 278 argSatisfactionCheck (by calling fetchAndReschedule).  There info if
 279 Node points to closure is available. -- HWL
 280
 281 \begin{code}
 282 closureCodeBody binder_info closure_info cc all_args body
 283   = let arg_reps = map idPrimRep all_args in
 284
 285     getEntryConvention name lf_info arg_reps  `thenFC` \ entry_conv ->
 286
 287     let
 288         -- Arg mapping for the entry point; as many args as poss in
 289         -- registers; the rest on the stack
 290         --      arg_regs are the registers used for arg passing
 291         --      stk_args are the args which are passed on the stack
 292         --
 293         -- Args passed on the stack are not tagged.
 294         --
 295         arg_regs = case entry_conv of
 296                 DirectEntry lbl arity regs -> regs
 297                 _ -> panic "closureCodeBody"
 298     in
 299
 300     -- If this function doesn't have a specialised ArgDescr, we need
 301     -- to generate the function's arg bitmap, slow-entry code, and
 302     -- register-save code for the heap-check failure
 303     --
 304     (case closureFunInfo closure_info of
 305         Just (_, ArgGen slow_lbl liveness) ->
 306                 absC (CBitmap liveness) `thenC`
 307                 absC (mkSlowEntryCode name slow_lbl arg_regs arg_reps) `thenC`
 308                 returnFC (mkRegSaveCode arg_regs arg_reps)
 309
 310         other -> returnFC AbsCNop
 311      )
 312         `thenFC` \ reg_save_code ->
 313
 314     -- get the current virtual Sp (it might not be zero, eg. if we're
 315     -- compiling a let-no-escape).
 316     getVirtSp `thenFC` \vSp ->
 317
 318     let
 319         (reg_args, stk_args) = splitAtList arg_regs all_args
 320
 321         (sp_stk_args, stk_offsets)
 322           = mkVirtStkOffsets vSp idPrimRep stk_args
 323
 324         entry_code = do
 325                 mod_name <- moduleName
 326                 profCtrC FSLIT("TICK_CTR") [
 327                         CLbl ticky_ctr_label DataPtrRep,
 328                         mkCString (mkFastString (ppr_for_ticky_name mod_name name)),
 329                         mkIntCLit stg_arity,    -- total # of args
 330                         mkIntCLit sp_stk_args,  -- # passed on stk
 331                         mkCString (mkFastString (map (showTypeCategory . idType) all_args))
 332                         ]
 333                 let prof =
 334                         profCtrC ticky_ent_lit [
 335                                 CLbl ticky_ctr_label DataPtrRep
 336                         ]
 337
 338                 -- Bind args to regs/stack as appropriate, and
 339                 -- record expected position of sps.
 340                 bindArgsToRegs reg_args arg_regs
 341                 mapCs bindNewToStack stk_offsets
 342                 setRealAndVirtualSp sp_stk_args
 343
 344                 -- Enter the closures cc, if required
 345                 enterCostCentreCode closure_info cc IsFunction False
 346
 347                 -- Do the business
 348                 funWrapper closure_info arg_regs reg_save_code
 349                         (prof >> cgExpr body)
 350     in
 351
 352     setTickyCtrLabel ticky_ctr_label (
 353
 354       forkAbsC entry_code       `thenFC` \ entry_abs_c ->
 355       moduleName                `thenFC` \ mod_name ->
 356
 357       -- Now construct the info table
 358       absC (CClosureInfoAndCode closure_info entry_abs_c)
 359     )
 360   where
 361     ticky_ctr_label = mkRednCountsLabel name
 362
 363     ticky_ent_lit =
 364         if (isStaticClosure closure_info)
 365         then FSLIT("TICK_ENT_STATIC_FUN_DIRECT")
 366         else FSLIT("TICK_ENT_DYN_FUN_DIRECT")
 367
 368     stg_arity = length all_args
 369     lf_info = closureLFInfo closure_info
 370
 371         -- Manufacture labels
 372     name       = closureName closure_info
 373
 374
 375 -- When printing the name of a thing in a ticky file, we want to
 376 -- give the module name even for *local* things.   We print
 377 -- just "x (M)" rather that "M.x" to distinguish them from the global kind.
 378 ppr_for_ticky_name mod_name name
 379   | isInternalName name = showSDocDebug (ppr name <+> (parens (ppr mod_name)))
 380   | otherwise        = showSDocDebug (ppr name)
 381 \end{code}
 382
 383 The "slow entry" code for a function.  This entry point takes its
 384 arguments on the stack.  It loads the arguments into registers
 385 according to the calling convention, and jumps to the function's
 386 normal entry point.  The function's closure is assumed to be in
 387 R1/node.
 388
 389 The slow entry point is used in two places:
 390
 391  (a) unknown calls: eg. stg_PAP_entry
 392  (b) returning from a heap-check failure
 393
 394 \begin{code}
 395 mkSlowEntryCode :: Name -> CLabel -> [MagicId] -> [PrimRep] -> AbstractC
 396 mkSlowEntryCode name lbl regs reps
 397    = CCodeBlock lbl (
 398         mkAbstractCs [assts, stk_adj, jump]
 399       )
 400   where
 401      stk_offsets = scanl (\off rep -> off - getPrimRepSize rep) 0 reps
 402
 403      assts = mkAbstractCs (zipWith3 mk_asst reps regs stk_offsets)
 404      mk_asst rep reg offset = CAssign (CReg reg) (CVal (spRel 0 offset) rep)
 405
 406      stk_adj = CAssign (CReg Sp) (CAddr (spRel 0 stk_final_offset))
 407      stk_final_offset = head (drop (length regs) stk_offsets)
 408
 409      jump = CJump (CLbl (mkEntryLabel name) CodePtrRep)
 410
 411 mkRegSaveCode :: [MagicId] -> [PrimRep] -> AbstractC
 412 mkRegSaveCode regs reps
 413   = mkAbstractCs [stk_adj, assts]
 414   where
 415      stk_adj = CAssign (CReg Sp) (CAddr (spRel 0 (negate stk_final_offset)))
 416
 417      stk_final_offset = head (drop (length regs) stk_offsets)
 418      stk_offsets = scanl (\off rep -> off - getPrimRepSize rep) 0 reps
 419
 420      assts = mkAbstractCs (zipWith3 mk_asst reps regs stk_offsets)
 421      mk_asst rep reg offset = CAssign (CVal (spRel 0 offset) rep) (CReg reg)
 422 \end{code}
 423
 424 For lexically scoped profiling we have to load the cost centre from
 425 the closure entered, if the costs are not supposed to be inherited.
 426 This is done immediately on entering the fast entry point.
 427
 428 Load current cost centre from closure, if not inherited.
 429 Node is guaranteed to point to it, if profiling and not inherited.
 430
 431 \begin{code}
 432 data IsThunk = IsThunk | IsFunction -- Bool-like, local
 433 -- #ifdef DEBUG
 434         deriving Eq
 435 -- #endif
 436
 437 enterCostCentreCode
 438    :: ClosureInfo -> CostCentreStack
 439    -> IsThunk
 440    -> Bool      -- is_box: this closure is a special box introduced by SCCfinal
 441    -> Code
 442
 443 enterCostCentreCode closure_info ccs is_thunk is_box
 444   = if not opt_SccProfilingOn then
 445         nopC
 446     else
 447         ASSERT2(not (noCCSAttached ccs), ppr (closureName closure_info) <+> ppr ccs)
 448
 449         if isSubsumedCCS ccs then
 450             ASSERT(isToplevClosure closure_info)
 451             ASSERT(is_thunk == IsFunction)
 452             costCentresC FSLIT("ENTER_CCS_FSUB") []
 453
 454         else if isDerivedFromCurrentCCS ccs then
 455             if re_entrant && not is_box
 456                 then costCentresC FSLIT("ENTER_CCS_FCL") [CReg node]
 457                 else costCentresC FSLIT("ENTER_CCS_TCL") [CReg node]
 458
 459         else if isCafCCS ccs then
 460             ASSERT(isToplevClosure closure_info)
 461             ASSERT(is_thunk == IsThunk)
 462                 -- might be a PAP, in which case we want to subsume costs
 463             if re_entrant
 464                 then costCentresC FSLIT("ENTER_CCS_FSUB") []
 465                 else costCentresC FSLIT("ENTER_CCS_CAF") c_ccs
 466
 467         else panic "enterCostCentreCode"
 468
 469    where
 470         c_ccs = [mkCCostCentreStack ccs]
 471         re_entrant = closureReEntrant closure_info
 472 \end{code}
 473
 474 %************************************************************************
 475 %*                                                                      *
 476 \subsubsection[closure-code-wrappers]{Wrappers around closure code}
 477 %*                                                                      *
 478 %************************************************************************
 479
 480 \begin{code}
 481 thunkWrapper:: ClosureInfo -> Code -> Code
 482 thunkWrapper closure_info thunk_code
 483   =     -- Stack and heap overflow checks
 484     nodeMustPointToIt (closureLFInfo closure_info) `thenFC` \ node_points ->
 485
 486     -- HWL: insert macros for GrAnSim; 2 versions depending on liveness of node
 487     -- (we prefer fetchAndReschedule-style context switches to yield ones)
 488     (if opt_GranMacros
 489        then if node_points
 490               then fetchAndReschedule [] node_points
 491               else yield [] node_points
 492        else absC AbsCNop)                       `thenC`
 493
 494     let closure_lbl
 495                 | node_points = Nothing
 496                 | otherwise   = Just (closureLabelFromCI closure_info)
 497     in
 498
 499         -- stack and/or heap checks
 500     thunkChecks closure_lbl (
 501
 502         -- Overwrite with black hole if necessary
 503     blackHoleIt closure_info node_points  `thenC`
 504
 505     setupUpdate closure_info (                  -- setupUpdate *encloses* the rest
 506
 507         -- Finally, do the business
 508     thunk_code
 509     ))
 510
 511 funWrapper :: ClosureInfo       -- Closure whose code body this is
 512            -> [MagicId]         -- List of argument registers (if any)
 513            -> AbstractC         -- reg saves for the heap check failure
 514            -> Code              -- Body of function being compiled
 515            -> Code
 516 funWrapper closure_info arg_regs reg_save_code fun_body
 517   =     -- Stack overflow check
 518     nodeMustPointToIt (closureLFInfo closure_info)  `thenFC` \ node_points ->
 519
 520     -- enter for Ldv profiling
 521     (if node_points then ldvEnter else nopC)        `thenC`
 522
 523     (if opt_GranMacros
 524        then yield arg_regs node_points
 525        else absC AbsCNop)                           `thenC`
 526
 527     let closure_lbl
 528                 | node_points = Nothing
 529                 | otherwise   = Just (closureLabelFromCI closure_info)
 530     in
 531
 532         -- heap and/or stack checks
 533     funEntryChecks closure_lbl reg_save_code (
 534
 535         -- Finally, do the business
 536     fun_body
 537     )
 538 \end{code}
 539
 540
 541 %************************************************************************
 542 %*                                                                      *
 543 \subsubsubsection[update-and-BHs]{Update and black-hole wrappers}
 544 %*                                                                      *
 545 %************************************************************************
 546
 547
 548 \begin{code}
 549 blackHoleIt :: ClosureInfo -> Bool -> Code      -- Only called for closures with no args
 550
 551 blackHoleIt closure_info node_points
 552   = if blackHoleOnEntry closure_info && node_points
 553     then
 554         let
 555           info_label = infoTableLabelFromCI closure_info
 556           args = [ CLbl info_label DataPtrRep ]
 557         in
 558         absC (if closureSingleEntry(closure_info) then
 559                 CMacroStmt UPD_BH_SINGLE_ENTRY args
 560               else
 561                 CMacroStmt UPD_BH_UPDATABLE args)
 562     else
 563         nopC
 564 \end{code}
 565
 566 \begin{code}
 567 setupUpdate :: ClosureInfo -> Code -> Code      -- Only called for closures with no args
 568         -- Nota Bene: this function does not change Node (even if it's a CAF),
 569         -- so that the cost centre in the original closure can still be
 570         -- extracted by a subsequent ENTER_CC_TCL
 571
 572 -- I've tidied up the code for this function, but it should still do the same as
 573 -- it did before (modulo ticky stuff).  KSW 1999-04.
 574 setupUpdate closure_info code
 575  = if closureReEntrant closure_info
 576    then
 577      code
 578    else
 579      case (closureUpdReqd closure_info, isStaticClosure closure_info) of
 580        (False,False) -> profCtrC FSLIT("TICK_UPDF_OMITTED") [] `thenC`
 581                         code
 582        (False,True ) -> (if opt_DoTickyProfiling
 583                          then
 584                          -- blackhole the SE CAF
 585                            link_caf seCafBlackHoleClosureInfo `thenFC` \ _ -> nopC
 586                          else
 587                            nopC)                                                       `thenC`
 588                         profCtrC FSLIT("TICK_UPD_CAF_BH_SINGLE_ENTRY") [mkCString cl_name] `thenC`
 589                         profCtrC FSLIT("TICK_UPDF_OMITTED") []                           `thenC`
 590                         code
 591        (True ,False) -> pushUpdateFrame (CReg node) code
 592        (True ,True ) -> -- blackhole the (updatable) CAF:
 593                         link_caf cafBlackHoleClosureInfo           `thenFC` \ update_closure ->
 594                         profCtrC FSLIT("TICK_UPD_CAF_BH_UPDATABLE") [mkCString cl_name]    `thenC`
 595                         pushUpdateFrame update_closure code
 596  where
 597    cl_name :: FastString
 598    cl_name  = (occNameFS . nameOccName . closureName) closure_info
 599
 600    link_caf :: (ClosureInfo -> ClosureInfo)  -- function yielding BH closure_info
 601             -> FCode CAddrMode               -- Returns amode for closure to be updated
 602    link_caf bhCI
 603      = -- To update a CAF we must allocate a black hole, link the CAF onto the
 604        -- CAF list, then update the CAF to point to the fresh black hole.
 605        -- This function returns the address of the black hole, so it can be
 606        -- updated with the new value when available.
 607
 608              -- Alloc black hole specifying CC_HDR(Node) as the cost centre
 609        let
 610            use_cc   = CMacroExpr PtrRep CCS_HDR [nodeReg]
 611            blame_cc = use_cc
 612        in
 613        allocDynClosure (bhCI closure_info) use_cc blame_cc []  `thenFC` \ heap_offset ->
 614        getHpRelOffset heap_offset                              `thenFC` \ hp_rel ->
 615        let  amode = CAddr hp_rel
 616        in
 617        absC (CMacroStmt UPD_CAF [CReg node, amode])            `thenC`
 618        returnFC amode
 619 \end{code}
 620
 621 %************************************************************************
 622 %*                                                                      *
 623 \subsection[CgClosure-Description]{Profiling Closure Description.}
 624 %*                                                                      *
 625 %************************************************************************
 626
 627 For "global" data constructors the description is simply occurrence
 628 name of the data constructor itself (see \ref{CgConTbls-info-tables}).
 629
 630 Otherwise it is determind by @closureDescription@ from the let
 631 binding information.
 632
 633 \begin{code}
 634 closureDescription :: Module            -- Module
 635                    -> Name              -- Id of closure binding
 636                    -> String
 637
 638         -- Not called for StgRhsCon which have global info tables built in
 639         -- CgConTbls.lhs with a description generated from the data constructor
 640
 641 closureDescription mod_name name
 642   = showSDoc (
 643         hcat [char '<',
 644                    pprModule mod_name,
 645                    char '.',
 646                    ppr name,
 647                    char '>'])
 648 \end{code}
 649
 650 \begin{code}
 651 chooseDynCostCentres ccs args fvs body
 652   = let
 653         use_cc -- cost-centre we record in the object
 654           = if currentOrSubsumedCCS ccs
 655             then CReg CurCostCentre
 656             else mkCCostCentreStack ccs
 657
 658         blame_cc -- cost-centre on whom we blame the allocation
 659           = case (args, fvs, body) of
 660               ([], _, StgApp fun [{-no args-}])
 661                 -> mkCCostCentreStack overheadCCS
 662               _ -> use_cc
 663
 664             -- if it's an utterly trivial RHS, then it must be
 665             -- one introduced by boxHigherOrderArgs for profiling,
 666             -- so we charge it to "OVERHEAD".
 667
 668             -- This looks like a HACK to me --SDM
 669     in
 670     (use_cc, blame_cc)
 671 \end{code}