ghc/compiler/codeGen/CgClosure.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
   3 %
   4 % $Id: CgClosure.lhs,v 1.27 1999/04/08 15:46:15 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     is_box  = case body of { StgApp fun [] -> True; _ -> False }
 271
 272     body_code   = profCtrC SLIT("TICK_ENT_THK") []              `thenC`
 273                   thunkWrapper closure_info body_label (
 274                         -- We only enter cc after setting up update so that cc
 275                         -- of enclosing scope will be recorded in update frame
 276                         -- CAF/DICT functions will be subsumed by this enclosing cc
 277                     enterCostCentreCode closure_info cc IsThunk is_box `thenC`
 278                     cgExpr body)
 279 \end{code}
 280
 281 If there is {\em at least one argument}, then this closure is in
 282 normal form, so there is no need to set up an update frame.  On the
 283 other hand, we do have to check that there are enough args, and
 284 perform an update if not!
 285
 286 The Macros for GrAnSim are produced at the beginning of the
 287 argSatisfactionCheck (by calling fetchAndReschedule).  There info if
 288 Node points to closure is available. -- HWL
 289
 290 \begin{code}
 291 closureCodeBody binder_info closure_info cc all_args body
 292   = getEntryConvention name lf_info
 293                        (map idPrimRep all_args)         `thenFC` \ entry_conv ->
 294
 295     -- get the current virtual Sp (it might not be zero, eg. if we're
 296     -- compiling a let-no-escape).
 297     getVirtSp `thenFC` \vSp ->
 298     let
 299         -- Figure out what is needed and what isn't
 300
 301         -- SDM: need everything for now in case the heap/stack check refers
 302         -- to it. (ToDo)
 303         slow_code_needed   = True
 304                    --slowFunEntryCodeRequired name binder_info entry_conv
 305         info_table_needed  = True
 306                    --funInfoTableRequired name binder_info lf_info
 307
 308         -- Arg mapping for standard (slow) entry point; all args on stack,
 309         -- with tagging.
 310         (sp_all_args, arg_offsets, arg_tags)
 311            = mkTaggedVirtStkOffsets vSp idPrimRep all_args
 312
 313         -- Arg mapping for the fast entry point; as many args as poss in
 314         -- registers; the rest on the stack
 315         --      arg_regs are the registers used for arg passing
 316         --      stk_args are the args which are passed on the stack
 317         --
 318         -- Args passed on the stack are tagged, but the tags may not
 319         -- actually be present (just gaps) if the function is called
 320         -- by jumping directly to the fast entry point.
 321         --
 322         arg_regs = case entry_conv of
 323                 DirectEntry lbl arity regs -> regs
 324                 other                       -> panic "closureCodeBody:arg_regs"
 325
 326         num_arg_regs = length arg_regs
 327
 328         (reg_args, stk_args) = splitAt num_arg_regs all_args
 329
 330         (sp_stk_args, stk_offsets, stk_tags)
 331           = mkTaggedVirtStkOffsets vSp idPrimRep stk_args
 332
 333         -- HWL; Note: empty list of live regs in slow entry code
 334         -- Old version (reschedule combined with heap check);
 335         -- see argSatisfactionCheck for new version
 336         --slow_entry_code = forceHeapCheck [node] True slow_entry_code'
 337         --                where node = UnusedReg PtrRep 1
 338         --slow_entry_code = forceHeapCheck [] True slow_entry_code'
 339
 340         slow_entry_code
 341           = profCtrC SLIT("TICK_ENT_FUN_STD") []            `thenC`
 342
 343             -- Bind args, and record expected position of stk ptrs
 344             mapCs bindNewToStack arg_offsets                `thenC`
 345             setRealAndVirtualSp sp_all_args                 `thenC`
 346
 347             argSatisfactionCheck closure_info               `thenC`
 348
 349             -- OK, so there are enough args.  Now we need to stuff as
 350             -- many of them in registers as the fast-entry code
 351             -- expects. Note that the zipWith will give up when it hits
 352             -- the end of arg_regs.
 353
 354             mapFCs getCAddrMode all_args            `thenFC` \ stk_amodes ->
 355             absC (mkAbstractCs (zipWith assign_to_reg arg_regs stk_amodes))
 356                                                             `thenC`
 357
 358             -- Now adjust real stack pointers
 359             adjustRealSp sp_stk_args                    `thenC`
 360
 361             absC (CFallThrough (CLbl fast_label CodePtrRep))
 362
 363         assign_to_reg reg_id amode = CAssign (CReg reg_id) amode
 364
 365         -- HWL
 366         -- Old version (reschedule combined with heap check);
 367         -- see argSatisfactionCheck for new version
 368         -- fast_entry_code = forceHeapCheck [] True fast_entry_code'
 369
 370         fast_entry_code
 371           = profCtrC SLIT("TICK_ENT_FUN_DIRECT") [
 372                     mkIntCLit stg_arity         -- total # of args
 373
 374                 {-  CLbl (mkRednCountsLabel name) PtrRep,
 375                     CString (_PK_ (showSDoc (ppr name))),
 376                     mkIntCLit stg_arity,        -- total # of args
 377                     mkIntCLit sp_stk_args,      -- # passed on stk
 378                     CString (_PK_ (map (showTypeCategory . idType) all_args)),
 379                     CString SLIT(""), CString SLIT("")
 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                 ]                       `thenC`
 387
 388                 -- Bind args to regs/stack as appropriate, and
 389                 -- record expected position of sps.
 390             bindArgsToRegs reg_args arg_regs                `thenC`
 391             mapCs bindNewToStack stk_offsets                `thenC`
 392             setRealAndVirtualSp sp_stk_args                 `thenC`
 393
 394                 -- free up the stack slots containing tags
 395             freeStackSlots (map fst stk_tags)               `thenC`
 396
 397                 -- Enter the closures cc, if required
 398             enterCostCentreCode closure_info cc IsFunction False `thenC`
 399
 400                 -- Do the business
 401             funWrapper closure_info arg_regs stk_tags slow_label (cgExpr body)
 402     in
 403         -- Make a labelled code-block for the slow and fast entry code
 404     forkAbsC (if slow_code_needed then slow_entry_code else absC AbsCNop)
 405                                 `thenFC` \ slow_abs_c ->
 406     forkAbsC fast_entry_code    `thenFC` \ fast_abs_c ->
 407     moduleName                  `thenFC` \ mod_name ->
 408
 409         -- Now either construct the info table, or put the fast code in alone
 410         -- (We never have slow code without an info table)
 411         -- XXX probably need the info table and slow entry code in case of
 412         -- a heap check failure.
 413     absC (
 414       if info_table_needed then
 415         CClosureInfoAndCode closure_info slow_abs_c (Just fast_abs_c)
 416                         (cl_descr mod_name)
 417       else
 418         CCodeBlock fast_label fast_abs_c
 419     )
 420   where
 421     stg_arity = length all_args
 422     lf_info = closureLFInfo closure_info
 423
 424     cl_descr mod_name = closureDescription mod_name name
 425
 426         -- Manufacture labels
 427     name       = closureName closure_info
 428     fast_label = mkFastEntryLabel name stg_arity
 429     slow_label = mkStdEntryLabel name
 430 \end{code}
 431
 432 For lexically scoped profiling we have to load the cost centre from
 433 the closure entered, if the costs are not supposed to be inherited.
 434 This is done immediately on entering the fast entry point.
 435
 436 Load current cost centre from closure, if not inherited.
 437 Node is guaranteed to point to it, if profiling and not inherited.
 438
 439 \begin{code}
 440 data IsThunk = IsThunk | IsFunction -- Bool-like, local
 441 -- #ifdef DEBUG
 442         deriving Eq
 443 -- #endif
 444
 445 enterCostCentreCode
 446    :: ClosureInfo -> CostCentreStack
 447    -> IsThunk
 448    -> Bool      -- is_box: this closure is a special box introduced by SCCfinal
 449    -> Code
 450
 451 enterCostCentreCode closure_info ccs is_thunk is_box
 452   = if not opt_SccProfilingOn then
 453         nopC
 454     else
 455         ASSERT(not (noCCSAttached ccs))
 456
 457         if isSubsumedCCS ccs then
 458             ASSERT(isToplevClosure closure_info)
 459             ASSERT(is_thunk == IsFunction)
 460             costCentresC SLIT("ENTER_CCS_FSUB") []
 461
 462         else if isSetCurrentCCS ccs then
 463             ASSERT(not (isToplevClosure closure_info))
 464             ASSERT(is_thunk == IsFunction)
 465             costCentresC SLIT("ENTER_CCS_TCL") [CReg node]
 466
 467         else if isCurrentCCS ccs then
 468             if re_entrant && not is_box
 469                 then costCentresC SLIT("ENTER_CCS_FCL") [CReg node]
 470                 else costCentresC SLIT("ENTER_CCS_TCL") [CReg node]
 471
 472         else if isCafCCS ccs then
 473             ASSERT(isToplevClosure closure_info)
 474             ASSERT(is_thunk == IsThunk)
 475                 -- might be a PAP, in which case we want to subsume costs
 476             if re_entrant
 477                 then costCentresC SLIT("ENTER_CCS_FSUB") []
 478                 else costCentresC SLIT("ENTER_CCS_CAF") c_ccs
 479
 480         else panic "enterCostCentreCode"
 481
 482    where
 483         c_ccs = [mkCCostCentreStack ccs]
 484         re_entrant = closureReEntrant closure_info
 485 \end{code}
 486
 487 %************************************************************************
 488 %*                                                                      *
 489 \subsubsection[pre-closure-code-stuff]{Pre-closure-code code}
 490 %*                                                                      *
 491 %************************************************************************
 492
 493 The argument-satisfaction check code is placed after binding
 494 the arguments to their stack locations. Hence, the virtual stack
 495 pointer is pointing after all the args, and virtual offset 1 means
 496 the base of frame and hence most distant arg.  Hence
 497 virtual offset 0 is just beyond the most distant argument; the
 498 relative offset of this word tells how many words of arguments
 499 are expected.
 500
 501 \begin{code}
 502 argSatisfactionCheck :: ClosureInfo -> Code
 503
 504 argSatisfactionCheck closure_info
 505
 506   = nodeMustPointToIt (closureLFInfo closure_info)   `thenFC` \ node_points ->
 507
 508     let
 509        emit_gran_macros = opt_GranMacros
 510     in
 511
 512     -- HWL  ngo' ngoq:
 513     -- absC (CMacroStmt GRAN_FETCH [])                  `thenC`
 514     -- forceHeapCheck [] node_points (absC AbsCNop)                     `thenC`
 515     (if emit_gran_macros
 516       then if node_points
 517              then fetchAndReschedule  [] node_points
 518              else yield [] node_points
 519       else absC AbsCNop)                       `thenC`
 520
 521         getSpRelOffset 0        `thenFC` \ (SpRel sp) ->
 522         let
 523             off = I# sp
 524             rel_arg = mkIntCLit off
 525         in
 526         ASSERT(off /= 0)
 527         if node_points then
 528             absC (CMacroStmt ARGS_CHK [rel_arg]) -- node already points
 529         else
 530             absC (CMacroStmt ARGS_CHK_LOAD_NODE [rel_arg, set_Node_to_this])
 531   where
 532     -- We must tell the arg-satis macro whether Node is pointing to
 533     -- the closure or not.  If it isn't so pointing, then we give to
 534     -- the macro the (static) address of the closure.
 535
 536     set_Node_to_this = CLbl (closureLabelFromCI closure_info) PtrRep
 537 \end{code}
 538
 539 %************************************************************************
 540 %*                                                                      *
 541 \subsubsection[closure-code-wrappers]{Wrappers around closure code}
 542 %*                                                                      *
 543 %************************************************************************
 544
 545 \begin{code}
 546 thunkWrapper:: ClosureInfo -> CLabel -> Code -> Code
 547 thunkWrapper closure_info label thunk_code
 548   =     -- Stack and heap overflow checks
 549     nodeMustPointToIt (closureLFInfo closure_info) `thenFC` \ node_points ->
 550
 551     let
 552        emit_gran_macros = opt_GranMacros
 553     in
 554         -- HWL: insert macros for GrAnSim; 2 versions depending on liveness of node
 555         -- (we prefer fetchAndReschedule-style context switches to yield ones)
 556     (if emit_gran_macros
 557       then if node_points
 558              then fetchAndReschedule  [] node_points
 559              else yield [] node_points
 560       else absC AbsCNop)                       `thenC`
 561
 562         -- stack and/or heap checks
 563     thunkChecks label node_points (
 564
 565         -- Overwrite with black hole if necessary
 566     blackHoleIt closure_info node_points        `thenC`
 567
 568     setupUpdate closure_info (                  -- setupUpdate *encloses* the rest
 569
 570         -- Finally, do the business
 571     thunk_code
 572     ))
 573
 574 funWrapper :: ClosureInfo       -- Closure whose code body this is
 575            -> [MagicId]         -- List of argument registers (if any)
 576            -> [(VirtualSpOffset,Int)] -- tagged stack slots
 577            -> CLabel            -- slow entry point for heap check ret.
 578            -> Code              -- Body of function being compiled
 579            -> Code
 580 funWrapper closure_info arg_regs stk_tags slow_label fun_body
 581   =     -- Stack overflow check
 582     nodeMustPointToIt (closureLFInfo closure_info)      `thenFC` \ node_points ->
 583     let
 584        emit_gran_macros = opt_GranMacros
 585     in
 586     -- HWL   chu' ngoq:
 587     (if emit_gran_macros
 588       then yield  arg_regs node_points
 589       else absC AbsCNop)                                 `thenC`
 590
 591         -- heap and/or stack checks
 592     fastEntryChecks arg_regs stk_tags slow_label node_points (
 593
 594         -- Finally, do the business
 595     fun_body
 596     )
 597 \end{code}
 598
 599
 600 %************************************************************************
 601 %*                                                                      *
 602 \subsubsubsection[update-and-BHs]{Update and black-hole wrappers}
 603 %*                                                                      *
 604 %************************************************************************
 605
 606
 607 \begin{code}
 608 blackHoleIt :: ClosureInfo -> Bool -> Code      -- Only called for thunks
 609 blackHoleIt closure_info node_points
 610   = if blackHoleOnEntry closure_info && node_points
 611     then
 612         absC (if closureSingleEntry(closure_info) then
 613                 CMacroStmt UPD_BH_SINGLE_ENTRY [CReg node]
 614               else
 615                 CMacroStmt UPD_BH_UPDATABLE [CReg node])
 616     else
 617         nopC
 618 \end{code}
 619
 620 \begin{code}
 621 setupUpdate :: ClosureInfo -> Code -> Code      -- Only called for thunks
 622         -- Nota Bene: this function does not change Node (even if it's a CAF),
 623         -- so that the cost centre in the original closure can still be
 624         -- extracted by a subsequent ENTER_CC_TCL
 625
 626 setupUpdate closure_info code
 627  = if (closureUpdReqd closure_info) then
 628         link_caf_if_needed      `thenFC` \ update_closure ->
 629         pushUpdateFrame update_closure code
 630    else
 631         profCtrC SLIT("TICK_UPDF_OMITTED") [] `thenC`
 632         code
 633  where
 634    link_caf_if_needed :: FCode CAddrMode        -- Returns amode for closure to be updated
 635    link_caf_if_needed
 636      = if not (isStaticClosure closure_info) then
 637           returnFC (CReg node)
 638        else
 639
 640           -- First we must allocate a black hole, and link the
 641           -- CAF onto the CAF list
 642
 643                 -- Alloc black hole specifying CC_HDR(Node) as the cost centre
 644                 --   Hack Warning: Using a CLitLit to get CAddrMode !
 645           let
 646               use_cc   = CLitLit SLIT("CCS_HDR(R1.p)") PtrRep
 647               blame_cc = use_cc
 648           in
 649           allocDynClosure (blackHoleClosureInfo closure_info) use_cc blame_cc []
 650                                                         `thenFC` \ heap_offset ->
 651           getHpRelOffset heap_offset                    `thenFC` \ hp_rel ->
 652           let  amode = CAddr hp_rel
 653           in
 654           absC (CMacroStmt UPD_CAF [CReg node, amode])
 655                                                         `thenC`
 656           returnFC amode
 657 \end{code}
 658
 659 %************************************************************************
 660 %*                                                                      *
 661 \subsection[CgClosure-Description]{Profiling Closure Description.}
 662 %*                                                                      *
 663 %************************************************************************
 664
 665 For "global" data constructors the description is simply occurrence
 666 name of the data constructor itself (see \ref{CgConTbls-info-tables}).
 667
 668 Otherwise it is determind by @closureDescription@ from the let
 669 binding information.
 670
 671 \begin{code}
 672 closureDescription :: Module            -- Module
 673                    -> Name              -- Id of closure binding
 674                    -> String
 675
 676         -- Not called for StgRhsCon which have global info tables built in
 677         -- CgConTbls.lhs with a description generated from the data constructor
 678
 679 closureDescription mod_name name
 680   = showSDoc (
 681         hcat [char '<',
 682                    pprModule mod_name,
 683                    char '.',
 684                    ppr name,
 685                    char '>'])
 686 \end{code}
 687
 688 \begin{code}
 689 chooseDynCostCentres ccs args fvs body
 690   = let
 691         use_cc -- cost-centre we record in the object
 692           = if currentOrSubsumedCCS ccs
 693             then CReg CurCostCentre
 694             else mkCCostCentreStack ccs
 695
 696         blame_cc -- cost-centre on whom we blame the allocation
 697           = case (args, fvs, body) of
 698               ([], _, StgApp fun [{-no args-}])
 699                 -> mkCCostCentreStack overheadCCS
 700               _ -> use_cc
 701
 702             -- if it's an utterly trivial RHS, then it must be
 703             -- one introduced by boxHigherOrderArgs for profiling,
 704             -- so we charge it to "OVERHEAD".
 705
 706             -- This looks like a HACK to me --SDM
 707     in
 708     (use_cc, blame_cc)
 709 \end{code}
 710
 711
 712
 713 ========================================================================
 714 OLD CODE THAT EMITTED INFORMATON FOR QUANTITATIVE ANALYSIS
 715
 716 It's pretty wierd, so I've nuked it for now.  SLPJ Nov 96
 717
 718 \begin{pseudocode}
 719 getWrapperArgTypeCategories
 720         :: Type                         -- wrapper's type
 721         -> StrictnessInfo bdee          -- strictness info about its args
 722         -> Maybe String
 723
 724 getWrapperArgTypeCategories _ NoStrictnessInfo      = Nothing
 725 getWrapperArgTypeCategories _ BottomGuaranteed
 726   = trace "getWrapperArgTypeCategories:BottomGuaranteed!" Nothing  -- wrong
 727 getWrapperArgTypeCategories _ (StrictnessInfo [] _) = Nothing
 728
 729 getWrapperArgTypeCategories ty (StrictnessInfo arg_info _)
 730   = Just (mkWrapperArgTypeCategories ty arg_info)
 731
 732 mkWrapperArgTypeCategories
 733         :: Type         -- wrapper's type
 734         -> [Demand]     -- info about its arguments
 735         -> String       -- a string saying lots about the args
 736
 737 mkWrapperArgTypeCategories wrapper_ty wrap_info
 738   = case (splitFunTy_maybe wrapper_ty) of { Just (arg_tys,_) ->
 739     map do_one (wrap_info `zip` (map showTypeCategory arg_tys)) }
 740   where
 741     -- ToDo: this needs FIXING UP (it was a hack anyway...)
 742     do_one (WwPrim, _) = 'P'
 743     do_one (WwEnum, _) = 'E'
 744     do_one (WwStrict, arg_ty_char) = arg_ty_char
 745     do_one (WwUnpack _ _ _, arg_ty_char)
 746       = if arg_ty_char `elem` "CIJFDTS"
 747         then toLower arg_ty_char
 748         else if arg_ty_char == '+' then 't'
 749         else trace ("mkWrapp..:funny char:"++[arg_ty_char]) '-'
 750     do_one (other_wrap_info, _) = '-'
 751 \end{pseudocode}
 752