ghc/compiler/codeGen/CgClosure.lhs

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