ghc/compiler/codeGen/CgClosure.lhs

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