ghc/compiler/codeGen/CgClosure.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
   3 %
   4 % $Id: CgClosure.lhs,v 1.26 1999/03/22 16:58:19 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             if re_entrant
 461                 then costCentresC SLIT("ENTER_CCS_FCL") [CReg node]
 462                 else costCentresC SLIT("ENTER_CCS_TCL") [CReg node]
 463
 464         else if isCafCCS ccs && isToplevClosure closure_info then
 465             ASSERT(is_thunk == IsThunk)
 466                 -- might be a PAP, in which case we want to subsume costs
 467             if re_entrant
 468                 then costCentresC SLIT("ENTER_CCS_FSUB") []
 469                 else costCentresC SLIT("ENTER_CCS_CAF") c_ccs
 470
 471         else -- we've got a "real" cost centre right here in our hands...
 472             case is_thunk of
 473                 IsThunk    -> costCentresC SLIT("ENTER_CCS_T") c_ccs
 474                 IsFunction -> if isCafCCS ccs-- || isDictCC ccs
 475                               then costCentresC SLIT("ENTER_CCS_FCAF") c_ccs
 476                               else costCentresC SLIT("ENTER_CCS_FLOAD") c_ccs
 477    where
 478         c_ccs = [mkCCostCentreStack ccs]
 479         re_entrant = closureReEntrant closure_info
 480 \end{code}
 481
 482 %************************************************************************
 483 %*                                                                      *
 484 \subsubsection[pre-closure-code-stuff]{Pre-closure-code code}
 485 %*                                                                      *
 486 %************************************************************************
 487
 488 The argument-satisfaction check code is placed after binding
 489 the arguments to their stack locations. Hence, the virtual stack
 490 pointer is pointing after all the args, and virtual offset 1 means
 491 the base of frame and hence most distant arg.  Hence
 492 virtual offset 0 is just beyond the most distant argument; the
 493 relative offset of this word tells how many words of arguments
 494 are expected.
 495
 496 \begin{code}
 497 argSatisfactionCheck :: ClosureInfo -> Code
 498
 499 argSatisfactionCheck closure_info
 500
 501   = nodeMustPointToIt (closureLFInfo closure_info)   `thenFC` \ node_points ->
 502
 503     let
 504        emit_gran_macros = opt_GranMacros
 505     in
 506
 507     -- HWL  ngo' ngoq:
 508     -- absC (CMacroStmt GRAN_FETCH [])                  `thenC`
 509     -- forceHeapCheck [] node_points (absC AbsCNop)                     `thenC`
 510     (if emit_gran_macros
 511       then if node_points
 512              then fetchAndReschedule  [] node_points
 513              else yield [] node_points
 514       else absC AbsCNop)                       `thenC`
 515
 516         getSpRelOffset 0        `thenFC` \ (SpRel sp) ->
 517         let
 518             off = I# sp
 519             rel_arg = mkIntCLit off
 520         in
 521         ASSERT(off /= 0)
 522         if node_points then
 523             absC (CMacroStmt ARGS_CHK [rel_arg]) -- node already points
 524         else
 525             absC (CMacroStmt ARGS_CHK_LOAD_NODE [rel_arg, set_Node_to_this])
 526   where
 527     -- We must tell the arg-satis macro whether Node is pointing to
 528     -- the closure or not.  If it isn't so pointing, then we give to
 529     -- the macro the (static) address of the closure.
 530
 531     set_Node_to_this = CLbl (closureLabelFromCI closure_info) PtrRep
 532 \end{code}
 533
 534 %************************************************************************
 535 %*                                                                      *
 536 \subsubsection[closure-code-wrappers]{Wrappers around closure code}
 537 %*                                                                      *
 538 %************************************************************************
 539
 540 \begin{code}
 541 thunkWrapper:: ClosureInfo -> CLabel -> Code -> Code
 542 thunkWrapper closure_info label thunk_code
 543   =     -- Stack and heap overflow checks
 544     nodeMustPointToIt (closureLFInfo closure_info) `thenFC` \ node_points ->
 545
 546     let
 547        emit_gran_macros = opt_GranMacros
 548     in
 549         -- HWL: insert macros for GrAnSim; 2 versions depending on liveness of node
 550         -- (we prefer fetchAndReschedule-style context switches to yield ones)
 551     (if emit_gran_macros
 552       then if node_points
 553              then fetchAndReschedule  [] node_points
 554              else yield [] node_points
 555       else absC AbsCNop)                       `thenC`
 556
 557         -- stack and/or heap checks
 558     thunkChecks label node_points (
 559
 560         -- Overwrite with black hole if necessary
 561     blackHoleIt closure_info node_points        `thenC`
 562
 563     setupUpdate closure_info (                  -- setupUpdate *encloses* the rest
 564
 565         -- Finally, do the business
 566     thunk_code
 567     ))
 568
 569 funWrapper :: ClosureInfo       -- Closure whose code body this is
 570            -> [MagicId]         -- List of argument registers (if any)
 571            -> [(VirtualSpOffset,Int)] -- tagged stack slots
 572            -> CLabel            -- slow entry point for heap check ret.
 573            -> Code              -- Body of function being compiled
 574            -> Code
 575 funWrapper closure_info arg_regs stk_tags slow_label fun_body
 576   =     -- Stack overflow check
 577     nodeMustPointToIt (closureLFInfo closure_info)      `thenFC` \ node_points ->
 578     let
 579        emit_gran_macros = opt_GranMacros
 580     in
 581     -- HWL   chu' ngoq:
 582     (if emit_gran_macros
 583       then yield  arg_regs node_points
 584       else absC AbsCNop)                                 `thenC`
 585
 586         -- heap and/or stack checks
 587     fastEntryChecks arg_regs stk_tags slow_label node_points (
 588
 589         -- Finally, do the business
 590     fun_body
 591     )
 592 \end{code}
 593
 594
 595 %************************************************************************
 596 %*                                                                      *
 597 \subsubsubsection[update-and-BHs]{Update and black-hole wrappers}
 598 %*                                                                      *
 599 %************************************************************************
 600
 601
 602 \begin{code}
 603 blackHoleIt :: ClosureInfo -> Bool -> Code      -- Only called for thunks
 604 blackHoleIt closure_info node_points
 605   = if blackHoleOnEntry closure_info && node_points
 606     then
 607         absC (if closureSingleEntry(closure_info) then
 608                 CMacroStmt UPD_BH_SINGLE_ENTRY [CReg node]
 609               else
 610                 CMacroStmt UPD_BH_UPDATABLE [CReg node])
 611     else
 612         nopC
 613 \end{code}
 614
 615 \begin{code}
 616 setupUpdate :: ClosureInfo -> Code -> Code      -- Only called for thunks
 617         -- Nota Bene: this function does not change Node (even if it's a CAF),
 618         -- so that the cost centre in the original closure can still be
 619         -- extracted by a subsequent ENTER_CC_TCL
 620
 621 setupUpdate closure_info code
 622  = if (closureUpdReqd closure_info) then
 623         link_caf_if_needed      `thenFC` \ update_closure ->
 624         pushUpdateFrame update_closure code
 625    else
 626         profCtrC SLIT("TICK_UPDF_OMITTED") [] `thenC`
 627         code
 628  where
 629    link_caf_if_needed :: FCode CAddrMode        -- Returns amode for closure to be updated
 630    link_caf_if_needed
 631      = if not (isStaticClosure closure_info) then
 632           returnFC (CReg node)
 633        else
 634
 635           -- First we must allocate a black hole, and link the
 636           -- CAF onto the CAF list
 637
 638                 -- Alloc black hole specifying CC_HDR(Node) as the cost centre
 639                 --   Hack Warning: Using a CLitLit to get CAddrMode !
 640           let
 641               use_cc   = CLitLit SLIT("CCS_HDR(R1.p)") PtrRep
 642               blame_cc = use_cc
 643           in
 644           allocDynClosure (blackHoleClosureInfo closure_info) use_cc blame_cc []
 645                                                         `thenFC` \ heap_offset ->
 646           getHpRelOffset heap_offset                    `thenFC` \ hp_rel ->
 647           let  amode = CAddr hp_rel
 648           in
 649           absC (CMacroStmt UPD_CAF [CReg node, amode])
 650                                                         `thenC`
 651           returnFC amode
 652 \end{code}
 653
 654 %************************************************************************
 655 %*                                                                      *
 656 \subsection[CgClosure-Description]{Profiling Closure Description.}
 657 %*                                                                      *
 658 %************************************************************************
 659
 660 For "global" data constructors the description is simply occurrence
 661 name of the data constructor itself (see \ref{CgConTbls-info-tables}).
 662
 663 Otherwise it is determind by @closureDescription@ from the let
 664 binding information.
 665
 666 \begin{code}
 667 closureDescription :: Module            -- Module
 668                    -> Name              -- Id of closure binding
 669                    -> String
 670
 671         -- Not called for StgRhsCon which have global info tables built in
 672         -- CgConTbls.lhs with a description generated from the data constructor
 673
 674 closureDescription mod_name name
 675   = showSDoc (
 676         hcat [char '<',
 677                    pprModule mod_name,
 678                    char '.',
 679                    ppr name,
 680                    char '>'])
 681 \end{code}
 682
 683 \begin{code}
 684 chooseDynCostCentres ccs args fvs body
 685   = let
 686         use_cc -- cost-centre we record in the object
 687           = if currentOrSubsumedCCS ccs
 688             then CReg CurCostCentre
 689             else mkCCostCentreStack ccs
 690
 691         blame_cc -- cost-centre on whom we blame the allocation
 692           = case (args, fvs, body) of
 693               ([], [just1], StgApp fun [{-no args-}])
 694                 | just1 == fun
 695                 -> mkCCostCentreStack overheadCCS
 696               _ -> use_cc
 697
 698             -- if it's an utterly trivial RHS, then it must be
 699             -- one introduced by boxHigherOrderArgs for profiling,
 700             -- so we charge it to "OVERHEAD".
 701
 702             -- This looks like a HACK to me --SDM
 703     in
 704     (use_cc, blame_cc)
 705 \end{code}
 706
 707
 708
 709 ========================================================================
 710 OLD CODE THAT EMITTED INFORMATON FOR QUANTITATIVE ANALYSIS
 711
 712 It's pretty wierd, so I've nuked it for now.  SLPJ Nov 96
 713
 714 \begin{pseudocode}
 715 getWrapperArgTypeCategories
 716         :: Type                         -- wrapper's type
 717         -> StrictnessInfo bdee          -- strictness info about its args
 718         -> Maybe String
 719
 720 getWrapperArgTypeCategories _ NoStrictnessInfo      = Nothing
 721 getWrapperArgTypeCategories _ BottomGuaranteed
 722   = trace "getWrapperArgTypeCategories:BottomGuaranteed!" Nothing  -- wrong
 723 getWrapperArgTypeCategories _ (StrictnessInfo [] _) = Nothing
 724
 725 getWrapperArgTypeCategories ty (StrictnessInfo arg_info _)
 726   = Just (mkWrapperArgTypeCategories ty arg_info)
 727
 728 mkWrapperArgTypeCategories
 729         :: Type         -- wrapper's type
 730         -> [Demand]     -- info about its arguments
 731         -> String       -- a string saying lots about the args
 732
 733 mkWrapperArgTypeCategories wrapper_ty wrap_info
 734   = case (splitFunTy_maybe wrapper_ty) of { Just (arg_tys,_) ->
 735     map do_one (wrap_info `zip` (map showTypeCategory arg_tys)) }
 736   where
 737     -- ToDo: this needs FIXING UP (it was a hack anyway...)
 738     do_one (WwPrim, _) = 'P'
 739     do_one (WwEnum, _) = 'E'
 740     do_one (WwStrict, arg_ty_char) = arg_ty_char
 741     do_one (WwUnpack _ _ _, arg_ty_char)
 742       = if arg_ty_char `elem` "CIJFDTS"
 743         then toLower arg_ty_char
 744         else if arg_ty_char == '+' then 't'
 745         else trace ("mkWrapp..:funny char:"++[arg_ty_char]) '-'
 746     do_one (other_wrap_info, _) = '-'
 747 \end{pseudocode}
 748