ghc/compiler/codeGen/CgClosure.lhs

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