ghc/compiler/codeGen/CgClosure.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
   3 %
   4 % $Id: CgClosure.lhs,v 1.28 1999/04/23 09:51:24 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 isCurrentCCS ccs then
 463             if re_entrant && not is_box
 464                 then costCentresC SLIT("ENTER_CCS_FCL") [CReg node]
 465                 else costCentresC SLIT("ENTER_CCS_TCL") [CReg node]
 466
 467         else if isCafCCS ccs then
 468             ASSERT(isToplevClosure closure_info)
 469             ASSERT(is_thunk == IsThunk)
 470                 -- might be a PAP, in which case we want to subsume costs
 471             if re_entrant
 472                 then costCentresC SLIT("ENTER_CCS_FSUB") []
 473                 else costCentresC SLIT("ENTER_CCS_CAF") c_ccs
 474
 475         else panic "enterCostCentreCode"
 476
 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               ([], _, StgApp fun [{-no args-}])
 694                 -> mkCCostCentreStack overheadCCS
 695               _ -> use_cc
 696
 697             -- if it's an utterly trivial RHS, then it must be
 698             -- one introduced by boxHigherOrderArgs for profiling,
 699             -- so we charge it to "OVERHEAD".
 700
 701             -- This looks like a HACK to me --SDM
 702     in
 703     (use_cc, blame_cc)
 704 \end{code}
 705
 706
 707
 708 ========================================================================
 709 OLD CODE THAT EMITTED INFORMATON FOR QUANTITATIVE ANALYSIS
 710
 711 It's pretty wierd, so I've nuked it for now.  SLPJ Nov 96
 712
 713 \begin{pseudocode}
 714 getWrapperArgTypeCategories
 715         :: Type                         -- wrapper's type
 716         -> StrictnessInfo bdee          -- strictness info about its args
 717         -> Maybe String
 718
 719 getWrapperArgTypeCategories _ NoStrictnessInfo      = Nothing
 720 getWrapperArgTypeCategories _ BottomGuaranteed
 721   = trace "getWrapperArgTypeCategories:BottomGuaranteed!" Nothing  -- wrong
 722 getWrapperArgTypeCategories _ (StrictnessInfo [] _) = Nothing
 723
 724 getWrapperArgTypeCategories ty (StrictnessInfo arg_info _)
 725   = Just (mkWrapperArgTypeCategories ty arg_info)
 726
 727 mkWrapperArgTypeCategories
 728         :: Type         -- wrapper's type
 729         -> [Demand]     -- info about its arguments
 730         -> String       -- a string saying lots about the args
 731
 732 mkWrapperArgTypeCategories wrapper_ty wrap_info
 733   = case (splitFunTy_maybe wrapper_ty) of { Just (arg_tys,_) ->
 734     map do_one (wrap_info `zip` (map showTypeCategory arg_tys)) }
 735   where
 736     -- ToDo: this needs FIXING UP (it was a hack anyway...)
 737     do_one (WwPrim, _) = 'P'
 738     do_one (WwEnum, _) = 'E'
 739     do_one (WwStrict, arg_ty_char) = arg_ty_char
 740     do_one (WwUnpack _ _ _, arg_ty_char)
 741       = if arg_ty_char `elem` "CIJFDTS"
 742         then toLower arg_ty_char
 743         else if arg_ty_char == '+' then 't'
 744         else trace ("mkWrapp..:funny char:"++[arg_ty_char]) '-'
 745     do_one (other_wrap_info, _) = '-'
 746 \end{pseudocode}
 747