ghc/compiler/codeGen/CgClosure.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
   3 %
   4 % $Id: CgClosure.lhs,v 1.46 2001/03/22 03:51:08 hwloidl 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   =
  83     -- LAY OUT THE OBJECT
  84     let
  85         name          = idName id
  86         closure_info  = layOutStaticNoFVClosure name lf_info
  87         closure_label = mkClosureLabel name
  88         cg_id_info    = stableAmodeIdInfo id (CLbl closure_label PtrRep) lf_info
  89     in
  90
  91         -- BUILD THE OBJECT (IF NECESSARY)
  92     ({- if staticClosureRequired name binder_info lf_info
  93      then -}
  94         (if opt_SccProfilingOn
  95           then
  96              absC (CStaticClosure
  97                 closure_label   -- Labelled with the name on lhs of defn
  98                 closure_info
  99                 (mkCCostCentreStack ccs)
 100                 [])             -- No fields
 101           else
 102              absC (CStaticClosure
 103                 closure_label   -- Labelled with the name on lhs of defn
 104                 closure_info
 105                 (panic "absent cc")
 106                 [])             -- No fields
 107         )
 108
 109      {- else
 110         nopC -}
 111                                                         `thenC`
 112
 113         -- GENERATE THE INFO TABLE (IF NECESSARY)
 114     forkClosureBody (closureCodeBody binder_info closure_info
 115                                          ccs args body)
 116
 117     ) `thenC`
 118
 119     returnFC (id, cg_id_info)
 120
 121 \end{code}
 122
 123 %********************************************************
 124 %*                                                      *
 125 \subsection[non-top-level-closures]{Non top-level closures}
 126 %*                                                      *
 127 %********************************************************
 128
 129 For closures with free vars, allocate in heap.
 130
 131 \begin{code}
 132 cgStdRhsClosure
 133         :: Id
 134         -> CostCentreStack      -- Optional cost centre annotation
 135         -> StgBinderInfo
 136         -> [Id]                 -- Free vars
 137         -> [Id]                 -- Args
 138         -> StgExpr
 139         -> LambdaFormInfo
 140         -> [StgArg]             -- payload
 141         -> FCode (Id, CgIdInfo)
 142
 143 cgStdRhsClosure binder cc binder_info fvs args body lf_info payload
 144                 -- AHA!  A STANDARD-FORM THUNK
 145   = (
 146         -- LAY OUT THE OBJECT
 147     getArgAmodes payload                        `thenFC` \ amodes ->
 148     let
 149         (closure_info, amodes_w_offsets)
 150           = layOutDynClosure (idName binder) getAmodeRep amodes lf_info
 151
 152         (use_cc, blame_cc) = chooseDynCostCentres cc args fvs body
 153     in
 154         -- BUILD THE OBJECT
 155     allocDynClosure closure_info use_cc blame_cc amodes_w_offsets
 156     )
 157                 `thenFC` \ heap_offset ->
 158
 159         -- RETURN
 160     returnFC (binder, heapIdInfo binder heap_offset lf_info)
 161 \end{code}
 162
 163 Here's the general case.
 164
 165 \begin{code}
 166 cgRhsClosure    :: Id
 167                 -> CostCentreStack      -- Optional cost centre annotation
 168                 -> StgBinderInfo
 169                 -> [Id]                 -- Free vars
 170                 -> [Id]                 -- Args
 171                 -> StgExpr
 172                 -> LambdaFormInfo
 173                 -> FCode (Id, CgIdInfo)
 174
 175 cgRhsClosure binder cc binder_info fvs args body lf_info
 176   = (
 177         -- LAY OUT THE OBJECT
 178         --
 179         -- If the binder is itself a free variable, then don't store
 180         -- it in the closure.  Instead, just bind it to Node on entry.
 181         -- NB we can be sure that Node will point to it, because we
 182         -- havn't told mkClosureLFInfo about this; so if the binder
 183         -- *was* a free var of its RHS, mkClosureLFInfo thinks it *is*
 184         -- stored in the closure itself, so it will make sure that
 185         -- Node points to it...
 186     let
 187         is_elem        = isIn "cgRhsClosure"
 188
 189         binder_is_a_fv = binder `is_elem` fvs
 190         reduced_fvs    = if binder_is_a_fv
 191                          then fvs `minusList` [binder]
 192                          else fvs
 193     in
 194     mapFCs getCAddrModeAndInfo reduced_fvs      `thenFC` \ fvs_w_amodes_and_info ->
 195     let
 196         closure_info :: ClosureInfo
 197         bind_details :: [((Id, CAddrMode, LambdaFormInfo), VirtualHeapOffset)]
 198
 199         (closure_info, bind_details)
 200           = layOutDynClosure (idName binder) get_kind fvs_w_amodes_and_info lf_info
 201
 202         bind_fv ((id, _, lf_info), offset) = bindNewToNode id offset lf_info
 203
 204         amodes_w_offsets = [(amode,offset) | ((_,amode,_), offset) <- bind_details]
 205
 206         get_kind (id, _, _) = idPrimRep id
 207     in
 208         -- BUILD ITS INFO TABLE AND CODE
 209     forkClosureBody (
 210                 -- Bind the fvs
 211             mapCs bind_fv bind_details `thenC`
 212
 213                 -- Bind the binder itself, if it is a free var
 214             (if binder_is_a_fv then
 215                 bindNewToReg binder node lf_info
 216             else
 217                 nopC)                                   `thenC`
 218
 219                 -- Compile the body
 220             closureCodeBody binder_info closure_info cc args body
 221     )   `thenC`
 222
 223         -- BUILD THE OBJECT
 224     let
 225         (use_cc, blame_cc) = chooseDynCostCentres cc args fvs body
 226     in
 227     allocDynClosure closure_info use_cc blame_cc amodes_w_offsets
 228     )           `thenFC` \ heap_offset ->
 229
 230         -- RETURN
 231     returnFC (binder, heapIdInfo binder heap_offset lf_info)
 232 \end{code}
 233
 234 %************************************************************************
 235 %*                                                                      *
 236 \subsection[code-for-closures]{The code for closures}
 237 %*                                                                      *
 238 %************************************************************************
 239
 240 \begin{code}
 241 closureCodeBody :: StgBinderInfo
 242                 -> ClosureInfo     -- Lots of information about this closure
 243                 -> CostCentreStack -- Optional cost centre attached to closure
 244                 -> [Id]
 245                 -> StgExpr
 246                 -> Code
 247 \end{code}
 248
 249 There are two main cases for the code for closures.  If there are {\em
 250 no arguments}, then the closure is a thunk, and not in normal form.
 251 So it should set up an update frame (if it is shared).  Also, it has
 252 no argument satisfaction check, so fast and slow entry-point labels
 253 are the same.
 254
 255 \begin{code}
 256 closureCodeBody binder_info closure_info cc [] body
 257   = -- thunks cannot have a primitive type!
 258     getAbsC body_code   `thenFC` \ body_absC ->
 259     moduleName          `thenFC` \ mod_name ->
 260
 261     absC (CClosureInfoAndCode closure_info body_absC Nothing
 262                               (cl_descr mod_name))
 263   where
 264     cl_descr mod_name = closureDescription mod_name (closureName closure_info)
 265
 266     body_label   = entryLabelFromCI closure_info
 267
 268     is_box  = case body of { StgApp fun [] -> True; _ -> False }
 269
 270     body_code   = profCtrC SLIT("TICK_ENT_THK") []              `thenC`
 271                   thunkWrapper closure_info body_label (
 272                         -- We only enter cc after setting up update so that cc
 273                         -- of enclosing scope will be recorded in update frame
 274                         -- CAF/DICT functions will be subsumed by this enclosing cc
 275                     enterCostCentreCode closure_info cc IsThunk is_box `thenC`
 276                     cgExpr body)
 277 \end{code}
 278
 279 If there is {\em at least one argument}, then this closure is in
 280 normal form, so there is no need to set up an update frame.  On the
 281 other hand, we do have to check that there are enough args, and
 282 perform an update if not!
 283
 284 The Macros for GrAnSim are produced at the beginning of the
 285 argSatisfactionCheck (by calling fetchAndReschedule).  There info if
 286 Node points to closure is available. -- HWL
 287
 288 \begin{code}
 289 closureCodeBody binder_info closure_info cc all_args body
 290   = getEntryConvention name lf_info
 291                        (map idPrimRep all_args)         `thenFC` \ entry_conv ->
 292
 293     -- get the current virtual Sp (it might not be zero, eg. if we're
 294     -- compiling a let-no-escape).
 295     getVirtSp `thenFC` \vSp ->
 296
 297     let
 298         -- Figure out what is needed and what isn't
 299
 300         -- SDM: need everything for now in case the heap/stack check refers
 301         -- to it. (ToDo)
 302         slow_code_needed   = True
 303                    --slowFunEntryCodeRequired name binder_info entry_conv
 304         info_table_needed  = True
 305                    --funInfoTableRequired name binder_info lf_info
 306
 307         -- Arg mapping for standard (slow) entry point; all args on stack,
 308         -- with tagging.
 309         (sp_all_args, arg_offsets, _)
 310            = mkTaggedVirtStkOffsets vSp idPrimRep all_args
 311
 312         -- Arg mapping for the fast entry point; as many args as poss in
 313         -- registers; the rest on the stack
 314         --      arg_regs are the registers used for arg passing
 315         --      stk_args are the args which are passed on the stack
 316         --
 317         -- Args passed on the stack are tagged, but the tags may not
 318         -- actually be present (just gaps) if the function is called
 319         -- by jumping directly to the fast entry point.
 320         --
 321         arg_regs = case entry_conv of
 322                 DirectEntry lbl arity regs -> regs
 323                 other                      -> []  -- "(HWL ignored; no args passed in regs)"
 324
 325         num_arg_regs = length arg_regs
 326
 327         (reg_args, stk_args) = splitAt num_arg_regs all_args
 328
 329         (sp_stk_args, stk_offsets, stk_tags)
 330           = mkTaggedVirtStkOffsets vSp idPrimRep stk_args
 331
 332         -- HWL; Note: empty list of live regs in slow entry code
 333         -- Old version (reschedule combined with heap check);
 334         -- see argSatisfactionCheck for new version
 335         --slow_entry_code = forceHeapCheck [node] True slow_entry_code'
 336         --                where node = UnusedReg PtrRep 1
 337         --slow_entry_code = forceHeapCheck [] True slow_entry_code'
 338
 339         slow_entry_code
 340           = profCtrC SLIT("TICK_ENT_FUN_STD") [
 341                     CLbl ticky_ctr_label DataPtrRep
 342             ] `thenC`
 343
 344             -- Bind args, and record expected position of stk ptrs
 345             mapCs bindNewToStack arg_offsets                `thenC`
 346             setRealAndVirtualSp sp_all_args                 `thenC`
 347
 348             argSatisfactionCheck closure_info   arg_regs            `thenC`
 349
 350             -- OK, so there are enough args.  Now we need to stuff as
 351             -- many of them in registers as the fast-entry code
 352             -- expects. Note that the zipWith will give up when it hits
 353             -- the end of arg_regs.
 354
 355             mapFCs getCAddrMode all_args            `thenFC` \ stk_amodes ->
 356             absC (mkAbstractCs (zipWith assign_to_reg arg_regs stk_amodes))
 357                                                             `thenC`
 358
 359             -- Now adjust real stack pointers (no need to adjust Hp,
 360             -- but call this function for convenience).
 361             adjustSpAndHp sp_stk_args                   `thenC`
 362
 363             absC (CFallThrough (CLbl fast_label CodePtrRep))
 364
 365         assign_to_reg reg_id amode = CAssign (CReg reg_id) amode
 366
 367         -- HWL
 368         -- Old version (reschedule combined with heap check);
 369         -- see argSatisfactionCheck for new version
 370         -- fast_entry_code = forceHeapCheck [] True fast_entry_code'
 371
 372         fast_entry_code
 373           = moduleName          `thenFC` \ mod_name ->
 374             profCtrC SLIT("TICK_CTR") [
 375                 CLbl ticky_ctr_label DataPtrRep,
 376                 mkCString (_PK_ (ppr_for_ticky_name mod_name name)),
 377                 mkIntCLit stg_arity,    -- total # of args
 378                 mkIntCLit sp_stk_args,  -- # passed on stk
 379                 mkCString (_PK_ (map (showTypeCategory . idType) all_args))
 380             ] `thenC`
 381
 382             profCtrC SLIT("TICK_ENT_FUN_DIRECT") [
 383                     CLbl ticky_ctr_label DataPtrRep
 384             ] `thenC`
 385
 386 -- Nuked for now; see comment at end of file
 387 --                  CString (_PK_ (show_wrapper_name wrapper_maybe)),
 388 --                  CString (_PK_ (show_wrapper_arg_kinds wrapper_maybe))
 389
 390
 391                 -- Bind args to regs/stack as appropriate, and
 392                 -- record expected position of sps.
 393             bindArgsToRegs reg_args arg_regs                `thenC`
 394             mapCs bindNewToStack stk_offsets                `thenC`
 395             setRealAndVirtualSp sp_stk_args                 `thenC`
 396
 397                 -- free up the stack slots containing tags
 398             freeStackSlots (map fst stk_tags)               `thenC`
 399
 400                 -- Enter the closures cc, if required
 401             enterCostCentreCode closure_info cc IsFunction False `thenC`
 402
 403                 -- Do the business
 404             funWrapper closure_info arg_regs stk_tags info_label (cgExpr body)
 405     in
 406
 407     setTickyCtrLabel ticky_ctr_label (
 408
 409         -- Make a labelled code-block for the slow and fast entry code
 410       forkAbsC (if slow_code_needed then slow_entry_code else absC AbsCNop)
 411                                 `thenFC` \ slow_abs_c ->
 412       forkAbsC fast_entry_code  `thenFC` \ fast_abs_c ->
 413       moduleName                        `thenFC` \ mod_name ->
 414
 415         -- Now either construct the info table, or put the fast code in alone
 416         -- (We never have slow code without an info table)
 417         -- XXX probably need the info table and slow entry code in case of
 418         -- a heap check failure.
 419       absC (
 420        if info_table_needed then
 421           CClosureInfoAndCode closure_info slow_abs_c (Just fast_abs_c)
 422                         (cl_descr mod_name)
 423        else
 424         CCodeBlock fast_label fast_abs_c
 425        )
 426     )
 427   where
 428     ticky_ctr_label = mkRednCountsLabel name
 429
 430     stg_arity = length all_args
 431     lf_info = closureLFInfo closure_info
 432
 433     cl_descr mod_name = closureDescription mod_name name
 434
 435         -- Manufacture labels
 436     name       = closureName closure_info
 437     fast_label = mkFastEntryLabel name stg_arity
 438     info_label = mkInfoTableLabel name
 439
 440
 441 -- When printing the name of a thing in a ticky file, we want to
 442 -- give the module name even for *local* things.   We print
 443 -- just "x (M)" rather that "M.x" to distinguish them from the global kind.
 444 ppr_for_ticky_name mod_name name
 445   | isLocalName name = showSDocDebug (ppr name <+> (parens (ppr mod_name)))
 446   | otherwise        = showSDocDebug (ppr name)
 447 \end{code}
 448
 449 For lexically scoped profiling we have to load the cost centre from
 450 the closure entered, if the costs are not supposed to be inherited.
 451 This is done immediately on entering the fast entry point.
 452
 453 Load current cost centre from closure, if not inherited.
 454 Node is guaranteed to point to it, if profiling and not inherited.
 455
 456 \begin{code}
 457 data IsThunk = IsThunk | IsFunction -- Bool-like, local
 458 -- #ifdef DEBUG
 459         deriving Eq
 460 -- #endif
 461
 462 enterCostCentreCode
 463    :: ClosureInfo -> CostCentreStack
 464    -> IsThunk
 465    -> Bool      -- is_box: this closure is a special box introduced by SCCfinal
 466    -> Code
 467
 468 enterCostCentreCode closure_info ccs is_thunk is_box
 469   = if not opt_SccProfilingOn then
 470         nopC
 471     else
 472         ASSERT(not (noCCSAttached ccs))
 473
 474         if isSubsumedCCS ccs then
 475             ASSERT(isToplevClosure closure_info)
 476             ASSERT(is_thunk == IsFunction)
 477             costCentresC SLIT("ENTER_CCS_FSUB") []
 478
 479         else if isCurrentCCS ccs then
 480             if re_entrant && not is_box
 481                 then costCentresC SLIT("ENTER_CCS_FCL") [CReg node]
 482                 else costCentresC SLIT("ENTER_CCS_TCL") [CReg node]
 483
 484         else if isCafCCS ccs then
 485             ASSERT(isToplevClosure closure_info)
 486             ASSERT(is_thunk == IsThunk)
 487                 -- might be a PAP, in which case we want to subsume costs
 488             if re_entrant
 489                 then costCentresC SLIT("ENTER_CCS_FSUB") []
 490                 else costCentresC SLIT("ENTER_CCS_CAF") c_ccs
 491
 492         else panic "enterCostCentreCode"
 493
 494    where
 495         c_ccs = [mkCCostCentreStack ccs]
 496         re_entrant = closureReEntrant closure_info
 497 \end{code}
 498
 499 %************************************************************************
 500 %*                                                                      *
 501 \subsubsection[pre-closure-code-stuff]{Pre-closure-code code}
 502 %*                                                                      *
 503 %************************************************************************
 504
 505 The argument-satisfaction check code is placed after binding
 506 the arguments to their stack locations. Hence, the virtual stack
 507 pointer is pointing after all the args, and virtual offset 1 means
 508 the base of frame and hence most distant arg.  Hence
 509 virtual offset 0 is just beyond the most distant argument; the
 510 relative offset of this word tells how many words of arguments
 511 are expected.
 512
 513 \begin{code}
 514 argSatisfactionCheck :: ClosureInfo -> [MagicId] {-GRAN-} -> Code
 515
 516 argSatisfactionCheck closure_info arg_regs
 517
 518   = nodeMustPointToIt (closureLFInfo closure_info)   `thenFC` \ node_points ->
 519
 520 --      let
 521 --         emit_gran_macros = opt_GranMacros
 522 --      in
 523
 524     -- HWL  ngo' ngoq:
 525     -- absC (CMacroStmt GRAN_FETCH [])                  `thenC`
 526     -- forceHeapCheck [] node_points (absC AbsCNop)                     `thenC`
 527     --(if opt_GranMacros
 528     --  then if node_points
 529     --         then fetchAndReschedule  arg_regs node_points
 530     --         else yield arg_regs node_points
 531     --  else absC AbsCNop)                       `thenC`
 532
 533         getSpRelOffset 0        `thenFC` \ (SpRel sp) ->
 534         let
 535             off     = iBox sp
 536             rel_arg = mkIntCLit off
 537         in
 538         ASSERT(off /= 0)
 539         if node_points then
 540             absC (CMacroStmt ARGS_CHK [rel_arg]) -- node already points
 541         else
 542             absC (CMacroStmt ARGS_CHK_LOAD_NODE [rel_arg, set_Node_to_this])
 543   where
 544     -- We must tell the arg-satis macro whether Node is pointing to
 545     -- the closure or not.  If it isn't so pointing, then we give to
 546     -- the macro the (static) address of the closure.
 547
 548     set_Node_to_this = CLbl (closureLabelFromCI closure_info) PtrRep
 549 \end{code}
 550
 551 %************************************************************************
 552 %*                                                                      *
 553 \subsubsection[closure-code-wrappers]{Wrappers around closure code}
 554 %*                                                                      *
 555 %************************************************************************
 556
 557 \begin{code}
 558 thunkWrapper:: ClosureInfo -> CLabel -> Code -> Code
 559 thunkWrapper closure_info lbl thunk_code
 560   =     -- Stack and heap overflow checks
 561     nodeMustPointToIt (closureLFInfo closure_info) `thenFC` \ node_points ->
 562
 563     -- HWL: insert macros for GrAnSim; 2 versions depending on liveness of node
 564     -- (we prefer fetchAndReschedule-style context switches to yield ones)
 565     (if opt_GranMacros
 566        then if node_points
 567               then fetchAndReschedule [] node_points
 568               else yield [] node_points
 569        else absC AbsCNop)                       `thenC`
 570
 571         -- stack and/or heap checks
 572     thunkChecks lbl node_points (
 573
 574         -- Overwrite with black hole if necessary
 575     blackHoleIt closure_info node_points  `thenC`
 576
 577     setupUpdate closure_info (                  -- setupUpdate *encloses* the rest
 578
 579         -- Finally, do the business
 580     thunk_code
 581     ))
 582
 583 funWrapper :: ClosureInfo       -- Closure whose code body this is
 584            -> [MagicId]         -- List of argument registers (if any)
 585            -> [(VirtualSpOffset,Int)] -- tagged stack slots
 586            -> CLabel            -- info table for heap check ret.
 587            -> Code              -- Body of function being compiled
 588            -> Code
 589 funWrapper closure_info arg_regs stk_tags info_label fun_body
 590   =     -- Stack overflow check
 591     nodeMustPointToIt (closureLFInfo closure_info)      `thenFC` \ node_points ->
 592     -- HWL   chu' ngoq:
 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}
 737
 738
 739