ghc/compiler/codeGen/CgClosure.lhs

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