ghc/compiler/codeGen/CgClosure.lhs

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