ghc/compiler/codeGen/CgClosure.lhs

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