ghc/compiler/codeGen/CgClosure.lhs

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