ghc/compiler/codeGen/CgClosure.lhs

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