ghc/compiler/codeGen/CgClosure.lhs

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