compiler/codeGen/StgCmmBind.hs

   1 -----------------------------------------------------------------------------
   2 --
   3 -- Stg to C-- code generation: bindings
   4 --
   5 -- (c) The University of Glasgow 2004-2006
   6 --
   7 -----------------------------------------------------------------------------
   8
   9 module StgCmmBind (
  10         cgTopRhsClosure,
  11         cgBind,
  12         emitBlackHoleCode,
  13         pushUpdateFrame
  14   ) where
  15
  16 #include "HsVersions.h"
  17
  18 import StgCmmExpr
  19 import StgCmmMonad
  20 import StgCmmEnv
  21 import StgCmmCon
  22 import StgCmmHeap
  23 import StgCmmProf
  24 import StgCmmTicky
  25 import StgCmmGran
  26 import StgCmmLayout
  27 import StgCmmUtils
  28 import StgCmmClosure
  29 import StgCmmForeign    (emitPrimCall)
  30
  31 import MkGraph
  32 import CoreSyn          ( AltCon(..) )
  33 import SMRep
  34 import CmmDecl
  35 import CmmExpr
  36 import CmmUtils
  37 import CLabel
  38 import StgSyn
  39 import CostCentre
  40 import Id
  41 import Control.Monad
  42 import Name
  43 import Module
  44 import ListSetOps
  45 import Util
  46 import BasicTypes
  47 import Constants
  48 import Outputable
  49 import FastString
  50 import Maybes
  51
  52 ------------------------------------------------------------------------
  53 --              Top-level bindings
  54 ------------------------------------------------------------------------
  55
  56 -- For closures bound at top level, allocate in static space.
  57 -- They should have no free variables.
  58
  59 cgTopRhsClosure :: Id
  60                 -> CostCentreStack      -- Optional cost centre annotation
  61                 -> StgBinderInfo
  62                 -> UpdateFlag
  63                 -> SRT
  64                 -> [Id]                 -- Args
  65                 -> StgExpr
  66                 -> FCode CgIdInfo
  67
  68 cgTopRhsClosure id ccs _ upd_flag srt args body = do
  69   {     -- LAY OUT THE OBJECT
  70     let name = idName id
  71   ; lf_info  <- mkClosureLFInfo id TopLevel [] upd_flag args
  72   ; srt_info <- getSRTInfo srt
  73   ; mod_name <- getModuleName
  74   ; let descr         = closureDescription mod_name name
  75         closure_info  = mkClosureInfo True id lf_info 0 0 srt_info descr
  76         closure_label = mkLocalClosureLabel name (idCafInfo id)
  77         cg_id_info    = litIdInfo id lf_info (CmmLabel closure_label)
  78         closure_rep   = mkStaticClosureFields closure_info ccs True []
  79
  80          -- BUILD THE OBJECT, AND GENERATE INFO TABLE (IF NECESSARY)
  81   ; emitDataLits closure_label closure_rep
  82   ; let fv_details :: [(NonVoid Id, VirtualHpOffset)]
  83         (_, _, fv_details) = mkVirtHeapOffsets (isLFThunk lf_info)
  84                                                (addIdReps [])
  85   -- Don't drop the non-void args until the closure info has been made
  86   ; forkClosureBody (closureCodeBody True id closure_info ccs
  87                                      (nonVoidIds args) (length args) body fv_details)
  88
  89   ; returnFC cg_id_info }
  90
  91 ------------------------------------------------------------------------
  92 --              Non-top-level bindings
  93 ------------------------------------------------------------------------
  94
  95 cgBind :: StgBinding -> FCode ()
  96 cgBind (StgNonRec name rhs)
  97   = do  { ((info, init), body) <- getCodeR $ cgRhs name rhs
  98         ; addBindC (cg_id info) info
  99         ; emit (init <*> body) }
 100
 101 cgBind (StgRec pairs)
 102   = do  { ((new_binds, inits), body) <- getCodeR $ fixC (\ new_binds_inits ->
 103                do { addBindsC $ fst new_binds_inits -- avoid premature deconstruction
 104                   ; liftM unzip $ listFCs [ cgRhs b e | (b,e) <- pairs ] })
 105        ; addBindsC new_binds
 106        ; emit (catAGraphs inits <*> body) }
 107
 108 {- Recursive let-bindings are tricky.
 109    Consider the following pseudocode:
 110      let x = \_ ->  ... y ...
 111          y = \_ ->  ... z ...
 112          z = \_ ->  ... x ...
 113      in ...
 114    For each binding, we need to allocate a closure, and each closure must
 115    capture the address of the other closures.
 116    We want to generate the following C-- code:
 117      // Initialization Code
 118      x = hp - 24; // heap address of x's closure
 119      y = hp - 40; // heap address of x's closure
 120      z = hp - 64; // heap address of x's closure
 121      // allocate and initialize x
 122      m[hp-8]   = ...
 123      m[hp-16]  = y       // the closure for x captures y
 124      m[hp-24] = x_info;
 125      // allocate and initialize y
 126      m[hp-32] = z;       // the closure for y captures z
 127      m[hp-40] = y_info;
 128      // allocate and initialize z
 129      ...
 130
 131    For each closure, we must generate not only the code to allocate and
 132    initialize the closure itself, but also some Initialization Code that
 133    sets a variable holding the closure pointer.
 134    The complication here is that we don't know the heap offsets a priori,
 135    which has two consequences:
 136      1. we need a fixpoint
 137      2. we can't trivially separate the Initialization Code from the
 138         code that compiles the right-hand-sides
 139
 140    Note: We don't need this complication with let-no-escapes, because
 141    in that case, the names are bound to labels in the environment,
 142    and we don't need to emit any code to witness that binding.
 143 -}
 144
 145 --------------------
 146 cgRhs :: Id -> StgRhs -> FCode (CgIdInfo, CmmAGraph)
 147    -- The Id is passed along so a binding can be set up
 148    -- The returned values are the binding for the environment
 149    -- and the Initialization Code that witnesses the binding
 150
 151 cgRhs name (StgRhsCon maybe_cc con args)
 152   = buildDynCon name maybe_cc con args
 153
 154 cgRhs name (StgRhsClosure cc bi fvs upd_flag srt args body)
 155   = mkRhsClosure name cc bi (nonVoidIds fvs) upd_flag srt args body
 156
 157 ------------------------------------------------------------------------
 158 --              Non-constructor right hand sides
 159 ------------------------------------------------------------------------
 160
 161 mkRhsClosure :: Id -> CostCentreStack -> StgBinderInfo
 162              -> [NonVoid Id]                    -- Free vars
 163              -> UpdateFlag -> SRT
 164              -> [Id]                            -- Args
 165              -> StgExpr
 166              -> FCode (CgIdInfo, CmmAGraph)
 167
 168 {- mkRhsClosure looks for two special forms of the right-hand side:
 169         a) selector thunks
 170         b) AP thunks
 171
 172 If neither happens, it just calls mkClosureLFInfo.  You might think
 173 that mkClosureLFInfo should do all this, but it seems wrong for the
 174 latter to look at the structure of an expression
 175
 176 Note [Selectors]
 177 ~~~~~~~~~~~~~~~~
 178 We look at the body of the closure to see if it's a selector---turgid,
 179 but nothing deep.  We are looking for a closure of {\em exactly} the
 180 form:
 181
 182 ...  = [the_fv] \ u [] ->
 183          case the_fv of
 184            con a_1 ... a_n -> a_i
 185
 186 Note [Ap thunks]
 187 ~~~~~~~~~~~~~~~~
 188 A more generic AP thunk of the form
 189
 190         x = [ x_1...x_n ] \.. [] -> x_1 ... x_n
 191
 192 A set of these is compiled statically into the RTS, so we just use
 193 those.  We could extend the idea to thunks where some of the x_i are
 194 global ids (and hence not free variables), but this would entail
 195 generating a larger thunk.  It might be an option for non-optimising
 196 compilation, though.
 197
 198 We only generate an Ap thunk if all the free variables are pointers,
 199 for semi-obvious reasons.
 200
 201 -}
 202
 203 ---------- Note [Selectors] ------------------
 204 mkRhsClosure    bndr cc bi
 205                 [NonVoid the_fv]                -- Just one free var
 206                 upd_flag                -- Updatable thunk
 207                 _srt
 208                 []                      -- A thunk
 209                 body@(StgCase (StgApp scrutinee [{-no args-}])
 210                       _ _ _ _   -- ignore uniq, etc.
 211                       (AlgAlt _)
 212                       [(DataAlt con, params, _use_mask,
 213                             (StgApp selectee [{-no args-}]))])
 214   |  the_fv == scrutinee                -- Scrutinee is the only free variable
 215   && maybeToBool maybe_offset           -- Selectee is a component of the tuple
 216   && offset_into_int <= mAX_SPEC_SELECTEE_SIZE  -- Offset is small enough
 217   = -- NOT TRUE: ASSERT(is_single_constructor)
 218     -- The simplifier may have statically determined that the single alternative
 219     -- is the only possible case and eliminated the others, even if there are
 220     -- other constructors in the datatype.  It's still ok to make a selector
 221     -- thunk in this case, because we *know* which constructor the scrutinee
 222     -- will evaluate to.
 223     --
 224     -- srt is discarded; it must be empty
 225     cgStdThunk bndr cc bi body lf_info [StgVarArg the_fv]
 226   where
 227     lf_info               = mkSelectorLFInfo bndr offset_into_int
 228                                  (isUpdatable upd_flag)
 229     (_, params_w_offsets) = layOutDynConstr con (addIdReps params)
 230                         -- Just want the layout
 231     maybe_offset          = assocMaybe params_w_offsets (NonVoid selectee)
 232     Just the_offset       = maybe_offset
 233     offset_into_int       = the_offset - fixedHdrSize
 234
 235 ---------- Note [Ap thunks] ------------------
 236 mkRhsClosure    bndr cc bi
 237                 fvs
 238                 upd_flag
 239                 _srt
 240                 []                      -- No args; a thunk
 241                 body@(StgApp fun_id args)
 242
 243   | args `lengthIs` (arity-1)
 244         && all isFollowableArg (map (idCgRep . stripNV) fvs)
 245         && isUpdatable upd_flag
 246         && arity <= mAX_SPEC_AP_SIZE
 247
 248                    -- Ha! an Ap thunk
 249   = cgStdThunk bndr cc bi body lf_info payload
 250   where
 251         lf_info = mkApLFInfo bndr upd_flag arity
 252         -- the payload has to be in the correct order, hence we can't
 253         -- just use the fvs.
 254         payload = StgVarArg fun_id : args
 255         arity   = length fvs
 256
 257 ---------- Default case ------------------
 258 mkRhsClosure bndr cc _ fvs upd_flag srt args body
 259   = do  {       -- LAY OUT THE OBJECT
 260         -- If the binder is itself a free variable, then don't store
 261         -- it in the closure.  Instead, just bind it to Node on entry.
 262         -- NB we can be sure that Node will point to it, because we
 263         -- haven't told mkClosureLFInfo about this; so if the binder
 264         -- _was_ a free var of its RHS, mkClosureLFInfo thinks it *is*
 265         -- stored in the closure itself, so it will make sure that
 266         -- Node points to it...
 267         ; let
 268                 is_elem      = isIn "cgRhsClosure"
 269                 bndr_is_a_fv = (NonVoid bndr) `is_elem` fvs
 270                 reduced_fvs | bndr_is_a_fv = fvs `minusList` [NonVoid bndr]
 271                             | otherwise    = fvs
 272
 273
 274         -- MAKE CLOSURE INFO FOR THIS CLOSURE
 275         ; lf_info <- mkClosureLFInfo bndr NotTopLevel fvs upd_flag args
 276         ; mod_name <- getModuleName
 277         ; c_srt <- getSRTInfo srt
 278         ; let   name  = idName bndr
 279                 descr = closureDescription mod_name name
 280                 fv_details :: [(NonVoid Id, VirtualHpOffset)]
 281                 (tot_wds, ptr_wds, fv_details)
 282                    = mkVirtHeapOffsets (isLFThunk lf_info)
 283                                        (addIdReps (map stripNV reduced_fvs))
 284                 closure_info = mkClosureInfo False      -- Not static
 285                                              bndr lf_info tot_wds ptr_wds
 286                                              c_srt descr
 287
 288         -- BUILD ITS INFO TABLE AND CODE
 289         ; forkClosureBody $
 290                 -- forkClosureBody: (a) ensure that bindings in here are not seen elsewhere
 291                 --                  (b) ignore Sequel from context; use empty Sequel
 292                 -- And compile the body
 293                 closureCodeBody False bndr closure_info cc (nonVoidIds args)
 294                                 (length args) body fv_details
 295
 296         -- BUILD THE OBJECT
 297         ; (use_cc, blame_cc) <- chooseDynCostCentres cc args body
 298         ; emit (mkComment $ mkFastString "calling allocDynClosure")
 299         ; let toVarArg (NonVoid a, off) = (NonVoid (StgVarArg a), off)
 300         ; (tmp, init) <- allocDynClosure closure_info use_cc blame_cc
 301                                          (map toVarArg fv_details)
 302
 303         -- RETURN
 304         ; regIdInfo bndr lf_info tmp init }
 305
 306 -- Use with care; if used inappropriately, it could break invariants.
 307 stripNV :: NonVoid a -> a
 308 stripNV (NonVoid a) = a
 309
 310 -------------------------
 311 cgStdThunk
 312         :: Id
 313         -> CostCentreStack      -- Optional cost centre annotation
 314         -> StgBinderInfo        -- XXX: not used??
 315         -> StgExpr
 316         -> LambdaFormInfo
 317         -> [StgArg]                     -- payload
 318         -> FCode (CgIdInfo, CmmAGraph)
 319
 320 cgStdThunk bndr cc _bndr_info body lf_info payload
 321   = do  -- AHA!  A STANDARD-FORM THUNK
 322   {     -- LAY OUT THE OBJECT
 323     mod_name <- getModuleName
 324   ; let (tot_wds, ptr_wds, payload_w_offsets)
 325             = mkVirtHeapOffsets (isLFThunk lf_info) (addArgReps payload)
 326
 327         descr = closureDescription mod_name (idName bndr)
 328         closure_info = mkClosureInfo False      -- Not static
 329                                      bndr lf_info tot_wds ptr_wds
 330                                      NoC_SRT    -- No SRT for a std-form closure
 331                                      descr
 332
 333   ; (use_cc, blame_cc) <- chooseDynCostCentres cc [{- no args-}] body
 334
 335         -- BUILD THE OBJECT
 336   ; (tmp, init) <- allocDynClosure closure_info use_cc blame_cc payload_w_offsets
 337
 338         -- RETURN
 339   ; regIdInfo bndr lf_info tmp init }
 340
 341 mkClosureLFInfo :: Id           -- The binder
 342                 -> TopLevelFlag -- True of top level
 343                 -> [NonVoid Id] -- Free vars
 344                 -> UpdateFlag   -- Update flag
 345                 -> [Id]         -- Args
 346                 -> FCode LambdaFormInfo
 347 mkClosureLFInfo bndr top fvs upd_flag args
 348   | null args = return (mkLFThunk (idType bndr) top (map stripNV fvs) upd_flag)
 349   | otherwise = do { arg_descr <- mkArgDescr (idName bndr) args
 350                    ; return (mkLFReEntrant top (map stripNV fvs) args arg_descr) }
 351
 352
 353 ------------------------------------------------------------------------
 354 --              The code for closures}
 355 ------------------------------------------------------------------------
 356
 357 closureCodeBody :: Bool            -- whether this is a top-level binding
 358                 -> Id              -- the closure's name
 359                 -> ClosureInfo     -- Lots of information about this closure
 360                 -> CostCentreStack -- Optional cost centre attached to closure
 361                 -> [NonVoid Id]    -- incoming args to the closure
 362                 -> Int             -- arity, including void args
 363                 -> StgExpr
 364                 -> [(NonVoid Id, VirtualHpOffset)] -- the closure's free vars
 365                 -> FCode ()
 366
 367 {- There are two main cases for the code for closures.
 368
 369 * If there are *no arguments*, then the closure is a thunk, and not in
 370   normal form. So it should set up an update frame (if it is
 371   shared). NB: Thunks cannot have a primitive type!
 372
 373 * If there is *at least one* argument, then this closure is in
 374   normal form, so there is no need to set up an update frame.
 375
 376   The Macros for GrAnSim are produced at the beginning of the
 377   argSatisfactionCheck (by calling fetchAndReschedule).
 378   There info if Node points to closure is available. -- HWL -}
 379
 380 closureCodeBody top_lvl bndr cl_info cc args arity body fv_details
 381   | length args == 0 -- No args i.e. thunk
 382   = emitClosureProcAndInfoTable top_lvl bndr cl_info [] $
 383       \(_, node, _) -> thunkCode cl_info fv_details cc node arity body
 384
 385 closureCodeBody top_lvl bndr cl_info cc args arity body fv_details
 386   = ASSERT( length args > 0 )
 387     do  { -- Allocate the global ticky counter,
 388           -- and establish the ticky-counter
 389           -- label for this block
 390           let ticky_ctr_lbl = mkRednCountsLabel (closureName cl_info) $
 391                                   clHasCafRefs cl_info
 392         ; emitTickyCounter cl_info (map stripNV args)
 393         ; setTickyCtrLabel ticky_ctr_lbl $ do
 394
 395         -- Emit the main entry code
 396         ; emitClosureProcAndInfoTable top_lvl bndr cl_info args $
 397             \(offset, node, arg_regs) -> do
 398                 -- Emit slow-entry code (for entering a closure through a PAP)
 399                 { mkSlowEntryCode cl_info arg_regs
 400
 401                 ; let lf_info = closureLFInfo cl_info
 402                       node_points = nodeMustPointToIt lf_info
 403                       node' = if node_points then Just node else Nothing
 404                 ; tickyEnterFun cl_info
 405                 ; whenC node_points (ldvEnterClosure cl_info)
 406                 ; granYield arg_regs node_points
 407
 408                 -- Main payload
 409                 ; entryHeapCheck cl_info offset node' arity arg_regs $ do
 410                 { enterCostCentre cl_info cc body
 411                 ; fv_bindings <- mapM bind_fv fv_details
 412                 -- Load free vars out of closure *after*
 413                 -- heap check, to reduce live vars over check
 414                 ; if node_points then load_fvs node lf_info fv_bindings
 415                                  else return ()
 416                 ; cgExpr body }}
 417   }
 418
 419 -- A function closure pointer may be tagged, so we
 420 -- must take it into account when accessing the free variables.
 421 bind_fv :: (NonVoid Id, VirtualHpOffset) -> FCode (LocalReg, WordOff)
 422 bind_fv (id, off) = do { reg <- rebindToReg id; return (reg, off) }
 423
 424 load_fvs :: LocalReg -> LambdaFormInfo -> [(LocalReg, WordOff)] -> FCode ()
 425 load_fvs node lf_info = mapCs (\ (reg, off) ->
 426       emit $ mkTaggedObjectLoad reg node off tag)
 427   where tag = lfDynTag lf_info
 428
 429 -----------------------------------------
 430 -- The "slow entry" code for a function.  This entry point takes its
 431 -- arguments on the stack.  It loads the arguments into registers
 432 -- according to the calling convention, and jumps to the function's
 433 -- normal entry point.  The function's closure is assumed to be in
 434 -- R1/node.
 435 --
 436 -- The slow entry point is used for unknown calls: eg. stg_PAP_entry
 437
 438 mkSlowEntryCode :: ClosureInfo -> [LocalReg] -> FCode ()
 439 -- If this function doesn't have a specialised ArgDescr, we need
 440 -- to generate the function's arg bitmap and slow-entry code.
 441 -- Here, we emit the slow-entry code.
 442 mkSlowEntryCode _ [] = panic "entering a closure with no arguments?"
 443 mkSlowEntryCode cl_info arg_regs -- function closure is already in `Node'
 444   | Just (_, ArgGen _) <- closureFunInfo cl_info
 445   = emitProcWithConvention Slow CmmNonInfoTable slow_lbl arg_regs jump
 446   | otherwise = return ()
 447   where
 448      caf_refs = clHasCafRefs cl_info
 449      name     = closureName cl_info
 450      slow_lbl = mkSlowEntryLabel  name caf_refs
 451      fast_lbl = enterLocalIdLabel name caf_refs
 452      -- mkDirectJump does not clobber `Node' containing function closure
 453      jump = mkDirectJump (mkLblExpr fast_lbl) (map (CmmReg . CmmLocal) arg_regs)
 454                          initUpdFrameOff
 455
 456 -----------------------------------------
 457 thunkCode :: ClosureInfo -> [(NonVoid Id, VirtualHpOffset)] -> CostCentreStack
 458           -> LocalReg -> Int -> StgExpr -> FCode ()
 459 thunkCode cl_info fv_details cc node arity body
 460   = do { let node_points = nodeMustPointToIt (closureLFInfo cl_info)
 461              node'       = if node_points then Just node else Nothing
 462         ; tickyEnterThunk cl_info
 463         ; ldvEnterClosure cl_info -- NB: Node always points when profiling
 464         ; granThunk node_points
 465
 466         -- Heap overflow check
 467         ; entryHeapCheck cl_info 0 node' arity [] $ do
 468         { -- Overwrite with black hole if necessary
 469           -- but *after* the heap-overflow check
 470           dflags <- getDynFlags
 471         ; whenC (blackHoleOnEntry dflags cl_info && node_points)
 472                 (blackHoleIt cl_info)
 473
 474           -- Push update frame
 475         ; setupUpdate cl_info node $
 476             -- We only enter cc after setting up update so
 477             -- that cc of enclosing scope will be recorded
 478             -- in update frame CAF/DICT functions will be
 479             -- subsumed by this enclosing cc
 480             do { enterCostCentre cl_info cc body
 481                ; let lf_info = closureLFInfo cl_info
 482                ; fv_bindings <- mapM bind_fv fv_details
 483                ; load_fvs node lf_info fv_bindings
 484                ; cgExpr body }}}
 485
 486
 487 ------------------------------------------------------------------------
 488 --              Update and black-hole wrappers
 489 ------------------------------------------------------------------------
 490
 491 blackHoleIt :: ClosureInfo -> FCode ()
 492 -- Only called for closures with no args
 493 -- Node points to the closure
 494 blackHoleIt closure_info = emitBlackHoleCode (closureSingleEntry closure_info)
 495
 496 emitBlackHoleCode :: Bool -> FCode ()
 497 emitBlackHoleCode is_single_entry
 498   | eager_blackholing = do
 499         tickyBlackHole (not is_single_entry)
 500         emit (mkStore (cmmOffsetW (CmmReg nodeReg) fixedHdrSize) (CmmReg (CmmGlobal CurrentTSO)))
 501         emitPrimCall [] MO_WriteBarrier []
 502         emit (mkStore (CmmReg nodeReg) (CmmLit (CmmLabel bh_lbl)))
 503   | otherwise =
 504         nopC
 505   where
 506     bh_lbl | is_single_entry = mkCmmDataLabel rtsPackageId (fsLit "stg_SE_BLACKHOLE_info")
 507            | otherwise       = mkCmmDataLabel rtsPackageId (fsLit "stg_BLACKHOLE_info")
 508
 509         -- If we wanted to do eager blackholing with slop filling,
 510         -- we'd need to do it at the *end* of a basic block, otherwise
 511         -- we overwrite the free variables in the thunk that we still
 512         -- need.  We have a patch for this from Andy Cheadle, but not
 513         -- incorporated yet. --SDM [6/2004]
 514         --
 515         -- Profiling needs slop filling (to support LDV profiling), so
 516         -- currently eager blackholing doesn't work with profiling.
 517         --
 518         -- Previously, eager blackholing was enabled when ticky-ticky
 519         -- was on. But it didn't work, and it wasn't strictly necessary
 520         -- to bring back minimal ticky-ticky, so now EAGER_BLACKHOLING
 521         -- is unconditionally disabled. -- krc 1/2007
 522
 523     eager_blackholing = False
 524
 525 setupUpdate :: ClosureInfo -> LocalReg -> FCode () -> FCode ()
 526         -- Nota Bene: this function does not change Node (even if it's a CAF),
 527         -- so that the cost centre in the original closure can still be
 528         -- extracted by a subsequent enterCostCentre
 529 setupUpdate closure_info node body
 530   | closureReEntrant closure_info
 531   = body
 532
 533   | not (isStaticClosure closure_info)
 534   = if not (closureUpdReqd closure_info)
 535       then do tickyUpdateFrameOmitted; body
 536       else do
 537           tickyPushUpdateFrame
 538           --dflags <- getDynFlags
 539           let es = [CmmReg (CmmLocal node), mkLblExpr mkUpdInfoLabel]
 540           --if not opt_SccProfilingOn && dopt Opt_EagerBlackHoling dflags
 541           --  then pushUpdateFrame es body -- XXX black hole
 542           --  else pushUpdateFrame es body
 543           pushUpdateFrame es body
 544
 545   | otherwise   -- A static closure
 546   = do  { tickyUpdateBhCaf closure_info
 547
 548         ; if closureUpdReqd closure_info
 549           then do       -- Blackhole the (updatable) CAF:
 550                 { upd_closure <- link_caf closure_info True
 551                 ; pushUpdateFrame [CmmReg (CmmLocal upd_closure),
 552                                      mkLblExpr mkUpdInfoLabel] body } -- XXX black hole
 553           else do {tickyUpdateFrameOmitted; body}
 554     }
 555
 556 -----------------------------------------------------------------------------
 557 -- Setting up update frames
 558
 559 -- Push the update frame on the stack in the Entry area,
 560 -- leaving room for the return address that is already
 561 -- at the old end of the area.
 562 pushUpdateFrame :: [CmmExpr] -> FCode () -> FCode ()
 563 pushUpdateFrame es body
 564   = do -- [EZY] I'm not sure if we need to special-case for BH too
 565        updfr  <- getUpdFrameOff
 566        offset <- foldM push updfr es
 567        withUpdFrameOff offset body
 568      where push off e =
 569              do emit (mkStore (CmmStackSlot (CallArea Old) base) e)
 570                 return base
 571              where base = off + widthInBytes (cmmExprWidth e)
 572
 573 -----------------------------------------------------------------------------
 574 -- Entering a CAF
 575 --
 576 -- When a CAF is first entered, it creates a black hole in the heap,
 577 -- and updates itself with an indirection to this new black hole.
 578 --
 579 -- We update the CAF with an indirection to a newly-allocated black
 580 -- hole in the heap.  We also set the blocking queue on the newly
 581 -- allocated black hole to be empty.
 582 --
 583 -- Why do we make a black hole in the heap when we enter a CAF?
 584 --
 585 --     - for a  generational garbage collector, which needs a fast
 586 --       test for whether an updatee is in an old generation or not
 587 --
 588 --     - for the parallel system, which can implement updates more
 589 --       easily if the updatee is always in the heap. (allegedly).
 590 --
 591 -- When debugging, we maintain a separate CAF list so we can tell when
 592 -- a CAF has been garbage collected.
 593
 594 -- newCAF must be called before the itbl ptr is overwritten, since
 595 -- newCAF records the old itbl ptr in order to do CAF reverting
 596 -- (which Hugs needs to do in order that combined mode works right.)
 597 --
 598
 599 -- ToDo [Feb 04]  This entire link_caf nonsense could all be moved
 600 -- into the "newCAF" RTS procedure, which we call anyway, including
 601 -- the allocation of the black-hole indirection closure.
 602 -- That way, code size would fall, the CAF-handling code would
 603 -- be closer together, and the compiler wouldn't need to know
 604 -- about off_indirectee etc.
 605
 606 link_caf :: ClosureInfo
 607          -> Bool                -- True <=> updatable, False <=> single-entry
 608          -> FCode LocalReg      -- Returns amode for closure to be updated
 609 -- To update a CAF we must allocate a black hole, link the CAF onto the
 610 -- CAF list, then update the CAF to point to the fresh black hole.
 611 -- This function returns the address of the black hole, so it can be
 612 -- updated with the new value when available.  The reason for all of this
 613 -- is that we only want to update dynamic heap objects, not static ones,
 614 -- so that generational GC is easier.
 615 link_caf cl_info _is_upd = do
 616   {     -- Alloc black hole specifying CC_HDR(Node) as the cost centre
 617   ; let use_cc   = costCentreFrom (CmmReg nodeReg)
 618         blame_cc = use_cc
 619         tso      = CmmReg (CmmGlobal CurrentTSO)
 620     -- XXX ezyang: FIXME
 621   ; (hp_rel, init) <- allocDynClosureCmm bh_cl_info use_cc blame_cc [(tso,fixedHdrSize)]
 622   ; emit init
 623
 624         -- Call the RTS function newCAF to add the CAF to the CafList
 625         -- so that the garbage collector can find them
 626         -- This must be done *before* the info table pointer is overwritten,
 627         -- because the old info table ptr is needed for reversion
 628   ; emitRtsCallWithVols rtsPackageId (fsLit "newCAF")
 629       [ (CmmReg (CmmGlobal BaseReg),  AddrHint),
 630         (CmmReg nodeReg, AddrHint) ]
 631       [node] False
 632         -- node is live, so save it.
 633
 634         -- Overwrite the closure with a (static) indirection
 635         -- to the newly-allocated black hole
 636   ; emit (mkStore (cmmRegOffW nodeReg off_indirectee) (CmmReg (CmmLocal hp_rel)) <*>
 637           mkStore (CmmReg nodeReg) ind_static_info)
 638
 639   ; return hp_rel }
 640   where
 641     bh_cl_info :: ClosureInfo
 642     bh_cl_info = cafBlackHoleClosureInfo cl_info
 643
 644     ind_static_info :: CmmExpr
 645     ind_static_info = mkLblExpr mkIndStaticInfoLabel
 646
 647     off_indirectee :: WordOff
 648     off_indirectee = fixedHdrSize + oFFSET_StgInd_indirectee*wORD_SIZE
 649
 650
 651 ------------------------------------------------------------------------
 652 --              Profiling
 653 ------------------------------------------------------------------------
 654
 655 -- For "global" data constructors the description is simply occurrence
 656 -- name of the data constructor itself.  Otherwise it is determined by
 657 -- @closureDescription@ from the let binding information.
 658
 659 closureDescription :: Module            -- Module
 660                    -> Name              -- Id of closure binding
 661                    -> String
 662         -- Not called for StgRhsCon which have global info tables built in
 663         -- CgConTbls.lhs with a description generated from the data constructor
 664 closureDescription mod_name name
 665   = showSDocDump (char '<' <>
 666                     (if isExternalName name
 667                       then ppr name -- ppr will include the module name prefix
 668                       else pprModule mod_name <> char '.' <> ppr name) <>
 669                     char '>')
 670    -- showSDocDump, because we want to see the unique on the Name.
 671