ghc/compiler/codeGen/CgClosure.lhs

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