ghc/compiler/codeGen/CgClosure.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
   3 %
   4 % $Id: CgClosure.lhs,v 1.62 2003/11/17 14:23:31 simonmar Exp $
   5 %
   6 \section[CgClosure]{Code generation for closures}
   7
   8 This module provides the support code for @StgToAbstractC@ to deal
   9 with {\em closures} on the RHSs of let(rec)s.  See also
  10 @CgCon@, which deals with constructors.
  11
  12 \begin{code}
  13 module CgClosure ( cgTopRhsClosure,
  14                    cgStdRhsClosure,
  15                    cgRhsClosure,
  16                    ) where
  17
  18 #include "HsVersions.h"
  19
  20 import {-# SOURCE #-} CgExpr ( cgExpr )
  21
  22 import CgMonad
  23 import CgBindery
  24 import CgUpdate         ( pushUpdateFrame )
  25 import CgHeapery
  26 import CgStackery
  27 import CgUsages
  28 import ClosureInfo      -- lots and lots of stuff
  29
  30 import AbsCUtils        ( getAmodeRep, mkAbstractCs )
  31 import AbsCSyn
  32 import CLabel
  33
  34 import StgSyn
  35 import CmdLineOpts      ( opt_GranMacros, opt_SccProfilingOn, opt_DoTickyProfiling )
  36 import CostCentre
  37 import Id               ( Id, idName, idType, idPrimRep )
  38 import Name             ( Name, isInternalName )
  39 import Module           ( Module, pprModule )
  40 import ListSetOps       ( minusList )
  41 import PrimRep          ( PrimRep(..), getPrimRepSize )
  42 import Util             ( isIn, splitAtList )
  43 import CmdLineOpts      ( opt_SccProfilingOn )
  44 import Outputable
  45 import FastString
  46
  47 import Name             ( nameOccName )
  48 import OccName          ( occNameFS )
  49
  50 -- Turgid imports for showTypeCategory
  51 import PrelNames
  52 import TcType           ( Type, isDictTy, tcSplitTyConApp_maybe, tcSplitFunTy_maybe )
  53 import TyCon            ( isPrimTyCon, isTupleTyCon, isEnumerationTyCon, maybeTyConSingleCon )
  54 import Maybe
  55 \end{code}
  56
  57 %********************************************************
  58 %*                                                      *
  59 \subsection[closures-no-free-vars]{Top-level closures}
  60 %*                                                      *
  61 %********************************************************
  62
  63 For closures bound at top level, allocate in static space.
  64 They should have no free variables.
  65
  66 \begin{code}
  67 cgTopRhsClosure :: Id
  68                 -> CostCentreStack      -- Optional cost centre annotation
  69                 -> StgBinderInfo
  70                 -> SRT
  71                 -> [Id]         -- Args
  72                 -> StgExpr
  73                 -> LambdaFormInfo
  74                 -> FCode (Id, CgIdInfo)
  75
  76 cgTopRhsClosure id ccs binder_info srt args body lf_info
  77   =
  78     let
  79         name          = idName id
  80     in
  81     -- LAY OUT THE OBJECT
  82     getSRTInfo name srt         `thenFC` \ srt_info ->
  83     moduleName                  `thenFC` \ mod_name ->
  84     let
  85         name          = idName id
  86         descr         = closureDescription mod_name name
  87         closure_info  = layOutStaticNoFVClosure id lf_info srt_info descr
  88         closure_label = mkClosureLabel name
  89         cg_id_info    = stableAmodeIdInfo id (CLbl closure_label PtrRep) lf_info
  90     in
  91
  92         -- BUILD THE OBJECT (IF NECESSARY)
  93     (
  94      ({- if staticClosureRequired name binder_info lf_info
  95       then -}
  96         absC (mkStaticClosure closure_label closure_info ccs [] True)
  97       {- else
  98         nopC -}
  99      )
 100                                                         `thenC`
 101
 102         -- GENERATE THE INFO TABLE (IF NECESSARY)
 103     forkClosureBody (closureCodeBody binder_info closure_info
 104                                          ccs args body)
 105
 106     ) `thenC`
 107
 108     returnFC (id, cg_id_info)
 109
 110 \end{code}
 111
 112 %********************************************************
 113 %*                                                      *
 114 \subsection[non-top-level-closures]{Non top-level closures}
 115 %*                                                      *
 116 %********************************************************
 117
 118 For closures with free vars, allocate in heap.
 119
 120 \begin{code}
 121 cgStdRhsClosure
 122         :: Id
 123         -> CostCentreStack      -- Optional cost centre annotation
 124         -> StgBinderInfo
 125         -> [Id]                 -- Free vars
 126         -> [Id]                 -- Args
 127         -> StgExpr
 128         -> LambdaFormInfo
 129         -> [StgArg]             -- payload
 130         -> FCode (Id, CgIdInfo)
 131
 132 cgStdRhsClosure binder cc binder_info fvs args body lf_info payload
 133                 -- AHA!  A STANDARD-FORM THUNK
 134   = (
 135         -- LAY OUT THE OBJECT
 136     getArgAmodes payload                `thenFC` \ amodes ->
 137     moduleName                          `thenFC` \ mod_name ->
 138     let
 139         descr = closureDescription mod_name (idName binder)
 140
 141         (closure_info, amodes_w_offsets)
 142           = layOutDynClosure binder getAmodeRep amodes lf_info NoC_SRT descr
 143                 -- No SRT for a standard-form closure
 144
 145         (use_cc, blame_cc) = chooseDynCostCentres cc args fvs body
 146     in
 147
 148         -- BUILD THE OBJECT
 149     allocDynClosure closure_info use_cc blame_cc amodes_w_offsets
 150     )
 151                 `thenFC` \ heap_offset ->
 152
 153         -- RETURN
 154     returnFC (binder, heapIdInfo binder heap_offset lf_info)
 155 \end{code}
 156
 157 Here's the general case.
 158
 159 \begin{code}
 160 cgRhsClosure    :: Id
 161                 -> CostCentreStack      -- Optional cost centre annotation
 162                 -> StgBinderInfo
 163                 -> SRT
 164                 -> [Id]                 -- Free vars
 165                 -> [Id]                 -- Args
 166                 -> StgExpr
 167                 -> LambdaFormInfo
 168                 -> FCode (Id, CgIdInfo)
 169
 170 cgRhsClosure binder cc binder_info srt fvs args body lf_info
 171   = (
 172         -- LAY OUT THE OBJECT
 173         --
 174         -- If the binder is itself a free variable, then don't store
 175         -- it in the closure.  Instead, just bind it to Node on entry.
 176         -- NB we can be sure that Node will point to it, because we
 177         -- havn't told mkClosureLFInfo about this; so if the binder
 178         -- *was* a free var of its RHS, mkClosureLFInfo thinks it *is*
 179         -- stored in the closure itself, so it will make sure that
 180         -- Node points to it...
 181     let
 182         is_elem        = isIn "cgRhsClosure"
 183
 184         binder_is_a_fv = binder `is_elem` fvs
 185         reduced_fvs    = if binder_is_a_fv
 186                          then fvs `minusList` [binder]
 187                          else fvs
 188
 189         name = idName binder
 190     in
 191
 192     mapFCs getCAddrModeAndInfo reduced_fvs      `thenFC` \ fvs_w_amodes_and_info ->
 193     getSRTInfo name srt                         `thenFC` \ srt_info ->
 194     moduleName                                  `thenFC` \ mod_name ->
 195     let
 196         descr = closureDescription mod_name (idName binder)
 197
 198         closure_info :: ClosureInfo
 199         bind_details :: [((Id, CAddrMode, LambdaFormInfo), VirtualHeapOffset)]
 200
 201         (closure_info, bind_details)
 202           = layOutDynClosure binder get_kind
 203                              fvs_w_amodes_and_info lf_info srt_info descr
 204
 205         bind_fv ((id, _, lf_info), offset) = bindNewToNode id offset lf_info
 206
 207         amodes_w_offsets = [(amode,offset) | ((_,amode,_), offset) <- bind_details]
 208
 209         get_kind (id, _, _) = idPrimRep id
 210     in
 211
 212         -- BUILD ITS INFO TABLE AND CODE
 213     forkClosureBody (
 214                 -- Bind the fvs
 215             mapCs bind_fv bind_details `thenC`
 216
 217                 -- Bind the binder itself, if it is a free var
 218             (if binder_is_a_fv then
 219                 bindNewToReg binder node lf_info
 220             else
 221                 nopC)                                   `thenC`
 222
 223                 -- Compile the body
 224             closureCodeBody binder_info closure_info cc args body
 225     )   `thenC`
 226
 227         -- BUILD THE OBJECT
 228     let
 229         (use_cc, blame_cc) = chooseDynCostCentres cc args fvs body
 230     in
 231     allocDynClosure closure_info use_cc blame_cc amodes_w_offsets
 232     )           `thenFC` \ heap_offset ->
 233
 234         -- RETURN
 235     returnFC (binder, heapIdInfo binder heap_offset lf_info)
 236 \end{code}
 237
 238 %************************************************************************
 239 %*                                                                      *
 240 \subsection[code-for-closures]{The code for closures}
 241 %*                                                                      *
 242 %************************************************************************
 243
 244 \begin{code}
 245 closureCodeBody :: StgBinderInfo
 246                 -> ClosureInfo     -- Lots of information about this closure
 247                 -> CostCentreStack -- Optional cost centre attached to closure
 248                 -> [Id]
 249                 -> StgExpr
 250                 -> Code
 251 \end{code}
 252
 253 There are two main cases for the code for closures.  If there are {\em
 254 no arguments}, then the closure is a thunk, and not in normal form.
 255 So it should set up an update frame (if it is shared).
 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
 262     absC (CClosureInfoAndCode closure_info body_absC)
 263   where
 264     is_box  = case body of { StgApp fun [] -> True; _ -> False }
 265
 266     ticky_ent_lit = if (isStaticClosure closure_info)
 267                     then FSLIT("TICK_ENT_STATIC_THK")
 268                     else FSLIT("TICK_ENT_DYN_THK")
 269
 270     body_code   = profCtrC ticky_ent_lit []                     `thenC`
 271                   -- node always points when profiling, so this is ok:
 272                   ldvEnter                                      `thenC`
 273                   thunkWrapper closure_info (
 274                         -- We only enter cc after setting up update so
 275                         -- that cc of enclosing scope will be recorded
 276                         -- in update frame CAF/DICT functions will be
 277                         -- subsumed by this enclosing cc
 278                     enterCostCentreCode closure_info cc IsThunk is_box `thenC`
 279                     cgExpr body
 280                   )
 281
 282 \end{code}
 283
 284 If there is /at least one argument/, then this closure is in
 285 normal form, so there is no need to set up an update frame.
 286
 287 The Macros for GrAnSim are produced at the beginning of the
 288 argSatisfactionCheck (by calling fetchAndReschedule).  There info if
 289 Node points to closure is available. -- HWL
 290
 291 \begin{code}
 292 closureCodeBody binder_info closure_info cc all_args body
 293   = let arg_reps = map idPrimRep all_args in
 294
 295     getEntryConvention name lf_info arg_reps  `thenFC` \ entry_conv ->
 296
 297     let
 298         -- Arg mapping for the entry point; as many args as poss in
 299         -- registers; the rest on the stack
 300         --      arg_regs are the registers used for arg passing
 301         --      stk_args are the args which are passed on the stack
 302         --
 303         -- Args passed on the stack are not tagged.
 304         --
 305         arg_regs = case entry_conv of
 306                 DirectEntry lbl arity regs -> regs
 307                 _ -> panic "closureCodeBody"
 308     in
 309
 310     -- If this function doesn't have a specialised ArgDescr, we need
 311     -- to generate the function's arg bitmap, slow-entry code, and
 312     -- register-save code for the heap-check failure
 313     --
 314     (case closureFunInfo closure_info of
 315         Just (_, ArgGen slow_lbl liveness) ->
 316                 absC (maybeLargeBitmap liveness) `thenC`
 317                 absC (mkSlowEntryCode name slow_lbl arg_regs arg_reps) `thenC`
 318                 returnFC (mkRegSaveCode arg_regs arg_reps)
 319
 320         other -> returnFC AbsCNop
 321      )
 322         `thenFC` \ reg_save_code ->
 323
 324     -- get the current virtual Sp (it might not be zero, eg. if we're
 325     -- compiling a let-no-escape).
 326     getVirtSp `thenFC` \vSp ->
 327
 328     let
 329         (reg_args, stk_args) = splitAtList arg_regs all_args
 330
 331         (sp_stk_args, stk_offsets)
 332           = mkVirtStkOffsets vSp idPrimRep stk_args
 333
 334         entry_code = do
 335                 mod_name <- moduleName
 336                 profCtrC FSLIT("TICK_CTR") [
 337                         CLbl ticky_ctr_label DataPtrRep,
 338                         mkCString (mkFastString (ppr_for_ticky_name mod_name name)),
 339                         mkIntCLit stg_arity,    -- total # of args
 340                         mkIntCLit sp_stk_args,  -- # passed on stk
 341                         mkCString (mkFastString (map (showTypeCategory . idType) all_args))
 342                         ]
 343                 let prof =
 344                         profCtrC ticky_ent_lit [
 345                                 CLbl ticky_ctr_label DataPtrRep
 346                         ]
 347
 348                 -- Bind args to regs/stack as appropriate, and
 349                 -- record expected position of sps.
 350                 bindArgsToRegs reg_args arg_regs
 351                 mapCs bindNewToStack stk_offsets
 352                 setRealAndVirtualSp sp_stk_args
 353
 354                 -- Enter the closures cc, if required
 355                 enterCostCentreCode closure_info cc IsFunction False
 356
 357                 -- Do the business
 358                 funWrapper closure_info arg_regs reg_save_code
 359                         (prof >> cgExpr body)
 360     in
 361
 362     setTickyCtrLabel ticky_ctr_label (
 363
 364       forkAbsC entry_code       `thenFC` \ entry_abs_c ->
 365       moduleName                `thenFC` \ mod_name ->
 366
 367       -- Now construct the info table
 368       absC (CClosureInfoAndCode closure_info entry_abs_c)
 369     )
 370   where
 371     ticky_ctr_label = mkRednCountsLabel name
 372
 373     ticky_ent_lit =
 374         if (isStaticClosure closure_info)
 375         then FSLIT("TICK_ENT_STATIC_FUN_DIRECT")
 376         else FSLIT("TICK_ENT_DYN_FUN_DIRECT")
 377
 378     stg_arity = length all_args
 379     lf_info = closureLFInfo closure_info
 380
 381         -- Manufacture labels
 382     name       = closureName closure_info
 383
 384
 385 -- When printing the name of a thing in a ticky file, we want to
 386 -- give the module name even for *local* things.   We print
 387 -- just "x (M)" rather that "M.x" to distinguish them from the global kind.
 388 ppr_for_ticky_name mod_name name
 389   | isInternalName name = showSDocDebug (ppr name <+> (parens (ppr mod_name)))
 390   | otherwise        = showSDocDebug (ppr name)
 391 \end{code}
 392
 393 The "slow entry" code for a function.  This entry point takes its
 394 arguments on the stack.  It loads the arguments into registers
 395 according to the calling convention, and jumps to the function's
 396 normal entry point.  The function's closure is assumed to be in
 397 R1/node.
 398
 399 The slow entry point is used in two places:
 400
 401  (a) unknown calls: eg. stg_PAP_entry
 402  (b) returning from a heap-check failure
 403
 404 \begin{code}
 405 mkSlowEntryCode :: Name -> CLabel -> [MagicId] -> [PrimRep] -> AbstractC
 406 mkSlowEntryCode name lbl regs reps
 407    = CCodeBlock lbl (
 408         mkAbstractCs [assts, stk_adj, jump]
 409       )
 410   where
 411      stk_offsets = scanl (\off rep -> off - getPrimRepSize rep) 0 reps
 412
 413      assts = mkAbstractCs (zipWith3 mk_asst reps regs stk_offsets)
 414      mk_asst rep reg offset = CAssign (CReg reg) (CVal (spRel 0 offset) rep)
 415
 416      stk_adj = CAssign (CReg Sp) (CAddr (spRel 0 stk_final_offset))
 417      stk_final_offset = head (drop (length regs) stk_offsets)
 418
 419      jump = CJump (CLbl (mkEntryLabel name) CodePtrRep)
 420
 421 mkRegSaveCode :: [MagicId] -> [PrimRep] -> AbstractC
 422 mkRegSaveCode regs reps
 423   = mkAbstractCs [stk_adj, assts]
 424   where
 425      stk_adj = CAssign (CReg Sp) (CAddr (spRel 0 (negate stk_final_offset)))
 426
 427      stk_final_offset = head (drop (length regs) stk_offsets)
 428      stk_offsets = scanl (\off rep -> off - getPrimRepSize rep) 0 reps
 429
 430      assts = mkAbstractCs (zipWith3 mk_asst reps regs stk_offsets)
 431      mk_asst rep reg offset = CAssign (CVal (spRel 0 offset) rep) (CReg reg)
 432 \end{code}
 433
 434 For lexically scoped profiling we have to load the cost centre from
 435 the closure entered, if the costs are not supposed to be inherited.
 436 This is done immediately on entering the fast entry point.
 437
 438 Load current cost centre from closure, if not inherited.
 439 Node is guaranteed to point to it, if profiling and not inherited.
 440
 441 \begin{code}
 442 data IsThunk = IsThunk | IsFunction -- Bool-like, local
 443 -- #ifdef DEBUG
 444         deriving Eq
 445 -- #endif
 446
 447 enterCostCentreCode
 448    :: ClosureInfo -> CostCentreStack
 449    -> IsThunk
 450    -> Bool      -- is_box: this closure is a special box introduced by SCCfinal
 451    -> Code
 452
 453 enterCostCentreCode closure_info ccs is_thunk is_box
 454   = if not opt_SccProfilingOn then
 455         nopC
 456     else
 457         ASSERT2(not (noCCSAttached ccs), ppr (closureName closure_info) <+> ppr ccs)
 458
 459         if isSubsumedCCS ccs then
 460             ASSERT(isToplevClosure closure_info)
 461             ASSERT(is_thunk == IsFunction)
 462             costCentresC FSLIT("ENTER_CCS_FSUB") []
 463
 464         else if isDerivedFromCurrentCCS ccs then
 465             if re_entrant && not is_box
 466                 then costCentresC FSLIT("ENTER_CCS_FCL") [CReg node]
 467                 else costCentresC FSLIT("ENTER_CCS_TCL") [CReg node]
 468
 469         else if isCafCCS ccs then
 470             ASSERT(isToplevClosure closure_info)
 471             ASSERT(is_thunk == IsThunk)
 472                 -- might be a PAP, in which case we want to subsume costs
 473             if re_entrant
 474                 then costCentresC FSLIT("ENTER_CCS_FSUB") []
 475                 else costCentresC FSLIT("ENTER_CCS_CAF") c_ccs
 476
 477         else panic "enterCostCentreCode"
 478
 479    where
 480         c_ccs = [mkCCostCentreStack ccs]
 481         re_entrant = closureReEntrant closure_info
 482 \end{code}
 483
 484 %************************************************************************
 485 %*                                                                      *
 486 \subsubsection[closure-code-wrappers]{Wrappers around closure code}
 487 %*                                                                      *
 488 %************************************************************************
 489
 490 \begin{code}
 491 thunkWrapper:: ClosureInfo -> Code -> Code
 492 thunkWrapper closure_info thunk_code
 493   =     -- Stack and heap overflow checks
 494     nodeMustPointToIt (closureLFInfo closure_info) `thenFC` \ node_points ->
 495
 496     -- HWL: insert macros for GrAnSim; 2 versions depending on liveness of node
 497     -- (we prefer fetchAndReschedule-style context switches to yield ones)
 498     (if opt_GranMacros
 499        then if node_points
 500               then fetchAndReschedule [] node_points
 501               else yield [] node_points
 502        else absC AbsCNop)                       `thenC`
 503
 504     let closure_lbl
 505                 | node_points = Nothing
 506                 | otherwise   = Just (closureLabelFromCI closure_info)
 507     in
 508
 509         -- stack and/or heap checks
 510     thunkChecks closure_lbl (
 511
 512         -- Overwrite with black hole if necessary
 513     blackHoleIt closure_info node_points  `thenC`
 514
 515     setupUpdate closure_info (                  -- setupUpdate *encloses* the rest
 516
 517         -- Finally, do the business
 518     thunk_code
 519     ))
 520
 521 funWrapper :: ClosureInfo       -- Closure whose code body this is
 522            -> [MagicId]         -- List of argument registers (if any)
 523            -> AbstractC         -- reg saves for the heap check failure
 524            -> Code              -- Body of function being compiled
 525            -> Code
 526 funWrapper closure_info arg_regs reg_save_code fun_body
 527   =     -- Stack overflow check
 528     nodeMustPointToIt (closureLFInfo closure_info)  `thenFC` \ node_points ->
 529
 530     -- enter for Ldv profiling
 531     (if node_points then ldvEnter else nopC)        `thenC`
 532
 533     (if opt_GranMacros
 534        then yield arg_regs node_points
 535        else absC AbsCNop)                           `thenC`
 536
 537     let closure_lbl
 538                 | node_points = Nothing
 539                 | otherwise   = Just (closureLabelFromCI closure_info)
 540     in
 541
 542         -- heap and/or stack checks
 543     funEntryChecks closure_lbl reg_save_code (
 544
 545         -- Finally, do the business
 546     fun_body
 547     )
 548 \end{code}
 549
 550
 551 %************************************************************************
 552 %*                                                                      *
 553 \subsubsubsection[update-and-BHs]{Update and black-hole wrappers}
 554 %*                                                                      *
 555 %************************************************************************
 556
 557
 558 \begin{code}
 559 blackHoleIt :: ClosureInfo -> Bool -> Code      -- Only called for closures with no args
 560
 561 blackHoleIt closure_info node_points
 562   = if blackHoleOnEntry closure_info && node_points
 563     then
 564         let
 565           info_label = infoTableLabelFromCI closure_info
 566           args = [ CLbl info_label DataPtrRep ]
 567         in
 568         absC (if closureSingleEntry(closure_info) then
 569                 CMacroStmt UPD_BH_SINGLE_ENTRY args
 570               else
 571                 CMacroStmt UPD_BH_UPDATABLE args)
 572     else
 573         nopC
 574 \end{code}
 575
 576 \begin{code}
 577 setupUpdate :: ClosureInfo -> Code -> Code      -- Only called for closures with no args
 578         -- Nota Bene: this function does not change Node (even if it's a CAF),
 579         -- so that the cost centre in the original closure can still be
 580         -- extracted by a subsequent ENTER_CC_TCL
 581
 582 -- I've tidied up the code for this function, but it should still do the same as
 583 -- it did before (modulo ticky stuff).  KSW 1999-04.
 584 setupUpdate closure_info code
 585  = if closureReEntrant closure_info
 586    then
 587      code
 588    else
 589      case (closureUpdReqd closure_info, isStaticClosure closure_info) of
 590        (False,False) -> profCtrC FSLIT("TICK_UPDF_OMITTED") [] `thenC`
 591                         code
 592        (False,True ) -> (if opt_DoTickyProfiling
 593                          then
 594                          -- blackhole the SE CAF
 595                            link_caf seCafBlackHoleClosureInfo `thenFC` \ _ -> nopC
 596                          else
 597                            nopC)                                                       `thenC`
 598                         profCtrC FSLIT("TICK_UPD_CAF_BH_SINGLE_ENTRY") [mkCString cl_name] `thenC`
 599                         profCtrC FSLIT("TICK_UPDF_OMITTED") []                           `thenC`
 600                         code
 601        (True ,False) -> pushUpdateFrame (CReg node) code
 602        (True ,True ) -> -- blackhole the (updatable) CAF:
 603                         link_caf cafBlackHoleClosureInfo           `thenFC` \ update_closure ->
 604                         profCtrC FSLIT("TICK_UPD_CAF_BH_UPDATABLE") [mkCString cl_name]    `thenC`
 605                         pushUpdateFrame update_closure code
 606  where
 607    cl_name :: FastString
 608    cl_name  = (occNameFS . nameOccName . closureName) closure_info
 609
 610    link_caf :: (ClosureInfo -> ClosureInfo)  -- function yielding BH closure_info
 611             -> FCode CAddrMode               -- Returns amode for closure to be updated
 612    link_caf bhCI
 613      = -- To update a CAF we must allocate a black hole, link the CAF onto the
 614        -- CAF list, then update the CAF to point to the fresh black hole.
 615        -- This function returns the address of the black hole, so it can be
 616        -- updated with the new value when available.
 617
 618              -- Alloc black hole specifying CC_HDR(Node) as the cost centre
 619        let
 620            use_cc   = CMacroExpr PtrRep CCS_HDR [nodeReg]
 621            blame_cc = use_cc
 622        in
 623        allocDynClosure (bhCI closure_info) use_cc blame_cc []  `thenFC` \ heap_offset ->
 624        getHpRelOffset heap_offset                              `thenFC` \ hp_rel ->
 625        let  amode = CAddr hp_rel
 626        in
 627        absC (CMacroStmt UPD_CAF [CReg node, amode])            `thenC`
 628        returnFC amode
 629 \end{code}
 630
 631 %************************************************************************
 632 %*                                                                      *
 633 \subsection[CgClosure-Description]{Profiling Closure Description.}
 634 %*                                                                      *
 635 %************************************************************************
 636
 637 For "global" data constructors the description is simply occurrence
 638 name of the data constructor itself (see \ref{CgConTbls-info-tables}).
 639
 640 Otherwise it is determind by @closureDescription@ from the let
 641 binding information.
 642
 643 \begin{code}
 644 closureDescription :: Module            -- Module
 645                    -> Name              -- Id of closure binding
 646                    -> String
 647
 648         -- Not called for StgRhsCon which have global info tables built in
 649         -- CgConTbls.lhs with a description generated from the data constructor
 650
 651 closureDescription mod_name name
 652   = showSDoc (
 653         hcat [char '<',
 654                    pprModule mod_name,
 655                    char '.',
 656                    ppr name,
 657                    char '>'])
 658 \end{code}
 659
 660 \begin{code}
 661 chooseDynCostCentres ccs args fvs body
 662   = let
 663         use_cc -- cost-centre we record in the object
 664           = if currentOrSubsumedCCS ccs
 665             then CReg CurCostCentre
 666             else mkCCostCentreStack ccs
 667
 668         blame_cc -- cost-centre on whom we blame the allocation
 669           = case (args, fvs, body) of
 670               ([], _, StgApp fun [{-no args-}])
 671                 -> mkCCostCentreStack overheadCCS
 672               _ -> use_cc
 673
 674             -- if it's an utterly trivial RHS, then it must be
 675             -- one introduced by boxHigherOrderArgs for profiling,
 676             -- so we charge it to "OVERHEAD".
 677
 678             -- This looks like a HACK to me --SDM
 679     in
 680     (use_cc, blame_cc)
 681 \end{code}
 682
 683
 684 \begin{code}
 685 showTypeCategory :: Type -> Char
 686   {-
 687         {C,I,F,D}   char, int, float, double
 688         T           tuple
 689         S           other single-constructor type
 690         {c,i,f,d}   unboxed ditto
 691         t           *unpacked* tuple
 692         s           *unpacked" single-cons...
 693
 694         v           void#
 695         a           primitive array
 696
 697         E           enumeration type
 698         +           dictionary, unless it's a ...
 699         L           List
 700         >           function
 701         M           other (multi-constructor) data-con type
 702         .           other type
 703         -           reserved for others to mark as "uninteresting"
 704     -}
 705 showTypeCategory ty
 706   = if isDictTy ty
 707     then '+'
 708     else
 709       case tcSplitTyConApp_maybe ty of
 710         Nothing -> if isJust (tcSplitFunTy_maybe ty)
 711                    then '>'
 712                    else '.'
 713
 714         Just (tycon, _) ->
 715           let utc = getUnique tycon in
 716           if      utc == charDataConKey    then 'C'
 717           else if utc == intDataConKey     then 'I'
 718           else if utc == floatDataConKey   then 'F'
 719           else if utc == doubleDataConKey  then 'D'
 720           else if utc == smallIntegerDataConKey ||
 721                   utc == largeIntegerDataConKey   then 'J'
 722           else if utc == charPrimTyConKey  then 'c'
 723           else if (utc == intPrimTyConKey || utc == wordPrimTyConKey
 724                 || utc == addrPrimTyConKey)                then 'i'
 725           else if utc  == floatPrimTyConKey                then 'f'
 726           else if utc  == doublePrimTyConKey               then 'd'
 727           else if isPrimTyCon tycon {- array, we hope -}   then 'A'     -- Bogus
 728           else if isEnumerationTyCon tycon                 then 'E'
 729           else if isTupleTyCon tycon                       then 'T'
 730           else if isJust (maybeTyConSingleCon tycon)       then 'S'
 731           else if utc == listTyConKey                      then 'L'
 732           else 'M' -- oh, well...
 733 \end{code}