ghc/compiler/codeGen/CgClosure.lhs

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