ghc/compiler/codeGen/CgClosure.lhs

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