ghc/compiler/codeGen/CgClosure.lhs

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