ghc/compiler/codeGen/CgHeapery.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
   3 %
   4 % $Id: CgHeapery.lhs,v 1.46 2005/04/21 15:28:20 simonmar Exp $
   5 %
   6 \section[CgHeapery]{Heap management functions}
   7
   8 \begin{code}
   9 module CgHeapery (
  10         initHeapUsage, getVirtHp, setVirtHp, setRealHp,
  11         getHpRelOffset, hpRel,
  12
  13         funEntryChecks, thunkEntryChecks,
  14         altHeapCheck, unbxTupleHeapCheck,
  15         hpChkGen, hpChkNodePointsAssignSp0,
  16         stkChkGen, stkChkNodePoints,
  17
  18         layOutDynConstr, layOutStaticConstr,
  19         mkVirtHeapOffsets, mkStaticClosureFields, mkStaticClosure,
  20
  21         allocDynClosure, emitSetDynHdr
  22     ) where
  23
  24 #include "HsVersions.h"
  25
  26 import Constants        ( mIN_UPD_SIZE )
  27 import StgSyn           ( AltType(..) )
  28 import CLabel           ( CLabel, mkRtsCodeLabel )
  29 import CgUtils          ( mkWordCLit, cmmRegOffW, cmmOffsetW,
  30                           cmmOffsetExprB )
  31 import CgMonad
  32 import CgProf           ( staticProfHdr, profDynAlloc, dynProfHdr )
  33 import CgTicky          ( staticTickyHdr, tickyDynAlloc, tickyAllocHeap )
  34 import CgParallel       ( staticGranHdr, staticParHdr, doGranAllocate )
  35 import CgStackery       ( getFinalStackHW, getRealSp )
  36 import CgCallConv       ( mkRegLiveness )
  37 import ClosureInfo      ( closureSize, staticClosureNeedsLink,
  38                           mkConInfo,  closureNeedsUpdSpace,
  39                           infoTableLabelFromCI, closureLabelFromCI,
  40                           nodeMustPointToIt, closureLFInfo,
  41                           ClosureInfo )
  42 import SMRep            ( CgRep(..), cgRepSizeW, separateByPtrFollowness,
  43                           WordOff, fixedHdrSize, thunkHdrSize,
  44                           isVoidArg, primRepToCgRep )
  45
  46 import Cmm              ( CmmLit(..), CmmStmt(..), CmmExpr(..), GlobalReg(..),
  47                           CmmReg(..), hpReg, nodeReg, spReg )
  48 import MachOp           ( mo_wordULt, mo_wordUGt, mo_wordSub )
  49 import CmmUtils         ( mkIntCLit, CmmStmts, noStmts, oneStmt, plusStmts,
  50                           mkStmts )
  51 import Id               ( Id )
  52 import DataCon          ( DataCon )
  53 import TyCon            ( tyConPrimRep )
  54 import CostCentre       ( CostCentreStack )
  55 import Util             ( mapAccumL, filterOut )
  56 import Constants        ( wORD_SIZE )
  57 import DynFlags ( DynFlags )
  58 import Outputable
  59
  60 import GLAEXTS
  61
  62 \end{code}
  63
  64
  65 %************************************************************************
  66 %*                                                                      *
  67 \subsection[CgUsages-heapery]{Monad things for fiddling with heap usage}
  68 %*                                                                      *
  69 %************************************************************************
  70
  71 The heap always grows upwards, so hpRel is easy
  72
  73 \begin{code}
  74 hpRel :: VirtualHpOffset        -- virtual offset of Hp
  75       -> VirtualHpOffset        -- virtual offset of The Thing
  76       -> WordOff                        -- integer word offset
  77 hpRel hp off = off - hp
  78 \end{code}
  79
  80 @initHeapUsage@ applies a function to the amount of heap that it uses.
  81 It initialises the heap usage to zeros, and passes on an unchanged
  82 heap usage.
  83
  84 It is usually a prelude to performing a GC check, so everything must
  85 be in a tidy and consistent state.
  86
  87 rje: Note the slightly suble fixed point behaviour needed here
  88
  89 \begin{code}
  90 initHeapUsage :: (VirtualHpOffset -> Code) -> Code
  91 initHeapUsage fcode
  92   = do  { orig_hp_usage <- getHpUsage
  93         ; setHpUsage initHpUsage
  94         ; fixC (\heap_usage2 -> do
  95                 { fcode (heapHWM heap_usage2)
  96                 ; getHpUsage })
  97         ; setHpUsage orig_hp_usage }
  98
  99 setVirtHp :: VirtualHpOffset -> Code
 100 setVirtHp new_virtHp
 101   = do  { hp_usage <- getHpUsage
 102         ; setHpUsage (hp_usage {virtHp = new_virtHp}) }
 103
 104 getVirtHp :: FCode VirtualHpOffset
 105 getVirtHp
 106   = do  { hp_usage <- getHpUsage
 107         ; return (virtHp hp_usage) }
 108
 109 setRealHp ::  VirtualHpOffset -> Code
 110 setRealHp new_realHp
 111   = do  { hp_usage <- getHpUsage
 112         ; setHpUsage (hp_usage {realHp = new_realHp}) }
 113
 114 getHpRelOffset :: VirtualHpOffset -> FCode CmmExpr
 115 getHpRelOffset virtual_offset
 116   = do  { hp_usg <- getHpUsage
 117         ; return (cmmRegOffW hpReg (hpRel (realHp hp_usg) virtual_offset)) }
 118 \end{code}
 119
 120
 121 %************************************************************************
 122 %*                                                                      *
 123                 Layout of heap objects
 124 %*                                                                      *
 125 %************************************************************************
 126
 127 \begin{code}
 128 layOutDynConstr, layOutStaticConstr
 129         :: DynFlags
 130         -> DataCon
 131         -> [(CgRep,a)]
 132         -> (ClosureInfo,
 133             [(a,VirtualHpOffset)])
 134
 135 layOutDynConstr    = layOutConstr False
 136 layOutStaticConstr = layOutConstr True
 137
 138 layOutConstr  is_static dflags data_con args
 139    = (mkConInfo dflags is_static data_con tot_wds ptr_wds,
 140       things_w_offsets)
 141   where
 142     (tot_wds,            --  #ptr_wds + #nonptr_wds
 143      ptr_wds,            --  #ptr_wds
 144      things_w_offsets) = mkVirtHeapOffsets False{-not a thunk-} args
 145 \end{code}
 146
 147 @mkVirtHeapOffsets@ always returns boxed things with smaller offsets
 148 than the unboxed things, and furthermore, the offsets in the result
 149 list
 150
 151 \begin{code}
 152 mkVirtHeapOffsets
 153           :: Bool               -- True <=> is a thunk
 154           -> [(CgRep,a)]        -- Things to make offsets for
 155           -> (WordOff,          -- _Total_ number of words allocated
 156               WordOff,          -- Number of words allocated for *pointers*
 157               [(a, VirtualHpOffset)])
 158                                 -- Things with their offsets from start of
 159                                 --  object in order of increasing offset
 160
 161 -- First in list gets lowest offset, which is initial offset + 1.
 162
 163 mkVirtHeapOffsets is_thunk things
 164   = let non_void_things               = filterOut (isVoidArg . fst) things
 165         (ptrs, non_ptrs)              = separateByPtrFollowness non_void_things
 166         (wds_of_ptrs, ptrs_w_offsets) = mapAccumL computeOffset 0 ptrs
 167         (tot_wds, non_ptrs_w_offsets) = mapAccumL computeOffset wds_of_ptrs non_ptrs
 168     in
 169     (tot_wds, wds_of_ptrs, ptrs_w_offsets ++ non_ptrs_w_offsets)
 170   where
 171     hdr_size    | is_thunk   = thunkHdrSize
 172                 | otherwise  = fixedHdrSize
 173
 174     computeOffset wds_so_far (rep, thing)
 175       = (wds_so_far + cgRepSizeW rep, (thing, hdr_size + wds_so_far))
 176 \end{code}
 177
 178
 179 %************************************************************************
 180 %*                                                                      *
 181                 Lay out a static closure
 182 %*                                                                      *
 183 %************************************************************************
 184
 185 Make a static closure, adding on any extra padding needed for CAFs,
 186 and adding a static link field if necessary.
 187
 188 \begin{code}
 189 mkStaticClosureFields
 190         :: ClosureInfo
 191         -> CostCentreStack
 192         -> Bool                 -- Has CAF refs
 193         -> [CmmLit]             -- Payload
 194         -> [CmmLit]             -- The full closure
 195 mkStaticClosureFields cl_info ccs caf_refs payload
 196   = mkStaticClosure info_lbl ccs payload padding_wds
 197         static_link_field saved_info_field
 198   where
 199     info_lbl = infoTableLabelFromCI cl_info
 200
 201     -- CAFs must have consistent layout, regardless of whether they
 202     -- are actually updatable or not.  The layout of a CAF is:
 203     --
 204     --        3 saved_info
 205     --        2 static_link
 206     --        1 indirectee
 207     --        0 info ptr
 208     --
 209     -- the static_link and saved_info fields must always be in the same
 210     -- place.  So we use closureNeedsUpdSpace rather than
 211     -- closureUpdReqd here:
 212
 213     is_caf = closureNeedsUpdSpace cl_info
 214
 215     padding_wds
 216         | not is_caf = []
 217         | otherwise  = replicate n (mkIntCLit 0) -- a bunch of 0s
 218         where n = max 0 (mIN_UPD_SIZE - length payload)
 219
 220     static_link_field
 221         | is_caf || staticClosureNeedsLink cl_info = [static_link_value]
 222         | otherwise                                = []
 223
 224     saved_info_field
 225         | is_caf     = [mkIntCLit 0]
 226         | otherwise  = []
 227
 228         -- for a static constructor which has NoCafRefs, we set the
 229         -- static link field to a non-zero value so the garbage
 230         -- collector will ignore it.
 231     static_link_value
 232         | caf_refs      = mkIntCLit 0
 233         | otherwise     = mkIntCLit 1
 234
 235
 236 mkStaticClosure :: CLabel -> CostCentreStack -> [CmmLit]
 237   -> [CmmLit] -> [CmmLit] -> [CmmLit] -> [CmmLit]
 238 mkStaticClosure info_lbl ccs payload padding_wds static_link_field saved_info_field
 239   =  [CmmLabel info_lbl]
 240   ++ variable_header_words
 241   ++ payload
 242   ++ padding_wds
 243   ++ static_link_field
 244   ++ saved_info_field
 245   where
 246     variable_header_words
 247         =  staticGranHdr
 248         ++ staticParHdr
 249         ++ staticProfHdr ccs
 250         ++ staticTickyHdr
 251 \end{code}
 252
 253 %************************************************************************
 254 %*                                                                      *
 255 \subsection[CgHeapery-heap-overflow]{Heap overflow checking}
 256 %*                                                                      *
 257 %************************************************************************
 258
 259 The new code  for heapChecks. For GrAnSim the code for doing a heap check
 260 and doing a context switch has been separated. Especially, the HEAP_CHK
 261 macro only performs a heap check. THREAD_CONTEXT_SWITCH should be used for
 262 doing a context switch. GRAN_FETCH_AND_RESCHEDULE must be put at the
 263 beginning of every slow entry code in order to simulate the fetching of
 264 closures. If fetching is necessary (i.e. current closure is not local) then
 265 an automatic context switch is done.
 266
 267 --------------------------------------------------------------
 268 A heap/stack check at a function or thunk entry point.
 269
 270 \begin{code}
 271 funEntryChecks :: ClosureInfo -> CmmStmts -> Code -> Code
 272 funEntryChecks cl_info reg_save_code code
 273   = hpStkCheck cl_info True reg_save_code code
 274
 275 thunkEntryChecks :: ClosureInfo -> Code -> Code
 276 thunkEntryChecks cl_info code
 277   = hpStkCheck cl_info False noStmts code
 278
 279 hpStkCheck :: ClosureInfo       -- Function closure
 280            -> Bool              -- Is a function? (not a thunk)
 281            -> CmmStmts          -- Register saves
 282            -> Code
 283            -> Code
 284
 285 hpStkCheck cl_info is_fun reg_save_code code
 286   =  getFinalStackHW    $ \ spHw -> do
 287         { sp <- getRealSp
 288         ; let stk_words = spHw - sp
 289         ; initHeapUsage $ \ hpHw  -> do
 290             {   -- Emit heap checks, but be sure to do it lazily so
 291                 -- that the conditionals on hpHw don't cause a black hole
 292               codeOnly $ do
 293                 { do_checks stk_words hpHw full_save_code rts_label
 294                 ; tickyAllocHeap hpHw }
 295             ; setRealHp hpHw
 296             ; code }
 297         }
 298   where
 299     node_asst
 300         | nodeMustPointToIt (closureLFInfo cl_info)
 301         = noStmts
 302         | otherwise
 303         = oneStmt (CmmAssign nodeReg (CmmLit (CmmLabel closure_lbl)))
 304     closure_lbl = closureLabelFromCI cl_info
 305
 306     full_save_code = node_asst `plusStmts` reg_save_code
 307
 308     rts_label | is_fun    = CmmReg (CmmGlobal GCFun)
 309                                 -- Function entry point
 310               | otherwise = CmmReg (CmmGlobal GCEnter1)
 311                                 -- Thunk or case return
 312         -- In the thunk/case-return case, R1 points to a closure
 313         -- which should be (re)-entered after GC
 314 \end{code}
 315
 316 Heap checks in a case alternative are nice and easy, provided this is
 317 a bog-standard algebraic case.  We have in our hand:
 318
 319        * one return address, on the stack,
 320        * one return value, in Node.
 321
 322 the canned code for this heap check failure just pushes Node on the
 323 stack, saying 'EnterGHC' to return.  The scheduler will return by
 324 entering the top value on the stack, which in turn will return through
 325 the return address, getting us back to where we were.  This is
 326 therefore only valid if the return value is *lifted* (just being
 327 boxed isn't good enough).
 328
 329 For primitive returns, we have an unlifted value in some register
 330 (either R1 or FloatReg1 or DblReg1).  This means using specialised
 331 heap-check code for these cases.
 332
 333 \begin{code}
 334 altHeapCheck
 335     :: AltType  -- PolyAlt, PrimAlt, AlgAlt, but *not* UbxTupAlt
 336                 --      (Unboxed tuples are dealt with by ubxTupleHeapCheck)
 337     -> Code     -- Continuation
 338     -> Code
 339 altHeapCheck alt_type code
 340   = initHeapUsage $ \ hpHw -> do
 341         { codeOnly $ do
 342              { do_checks 0 {- no stack chk -} hpHw
 343                          noStmts {- nothign to save -}
 344                          (rts_label alt_type)
 345              ; tickyAllocHeap hpHw }
 346         ; setRealHp hpHw
 347         ; code }
 348   where
 349     rts_label PolyAlt = CmmLit (CmmLabel (mkRtsCodeLabel SLIT( "stg_gc_unpt_r1")))
 350         -- Do *not* enter R1 after a heap check in
 351         -- a polymorphic case.  It might be a function
 352         -- and the entry code for a function (currently)
 353         -- applies it
 354         --
 355         -- However R1 is guaranteed to be a pointer
 356
 357     rts_label (AlgAlt tc) = stg_gc_enter1
 358         -- Enter R1 after the heap check; it's a pointer
 359
 360     rts_label (PrimAlt tc)
 361       = CmmLit $ CmmLabel $
 362         case primRepToCgRep (tyConPrimRep tc) of
 363           VoidArg   -> mkRtsCodeLabel SLIT( "stg_gc_noregs")
 364           FloatArg  -> mkRtsCodeLabel SLIT( "stg_gc_f1")
 365           DoubleArg -> mkRtsCodeLabel SLIT( "stg_gc_d1")
 366           LongArg   -> mkRtsCodeLabel SLIT( "stg_gc_l1")
 367                                 -- R1 is boxed but unlifted:
 368           PtrArg    -> mkRtsCodeLabel SLIT( "stg_gc_unpt_r1")
 369                                 -- R1 is unboxed:
 370           NonPtrArg -> mkRtsCodeLabel SLIT( "stg_gc_unbx_r1")
 371
 372     rts_label (UbxTupAlt _) = panic "altHeapCheck"
 373 \end{code}
 374
 375
 376 Unboxed tuple alternatives and let-no-escapes (the two most annoying
 377 constructs to generate code for!)  For unboxed tuple returns, there
 378 are an arbitrary number of possibly unboxed return values, some of
 379 which will be in registers, and the others will be on the stack.  We
 380 always organise the stack-resident fields into pointers &
 381 non-pointers, and pass the number of each to the heap check code.
 382
 383 \begin{code}
 384 unbxTupleHeapCheck
 385         :: [(Id, GlobalReg)]    -- Live registers
 386         -> WordOff      -- no. of stack slots containing ptrs
 387         -> WordOff      -- no. of stack slots containing nonptrs
 388         -> CmmStmts     -- code to insert in the failure path
 389         -> Code
 390         -> Code
 391
 392 unbxTupleHeapCheck regs ptrs nptrs fail_code code
 393   -- We can't manage more than 255 pointers/non-pointers
 394   -- in a generic heap check.
 395   | ptrs > 255 || nptrs > 255 = panic "altHeapCheck"
 396   | otherwise
 397   = initHeapUsage $ \ hpHw -> do
 398         { codeOnly $ do { do_checks 0 {- no stack check -} hpHw
 399                                     full_fail_code rts_label
 400                         ; tickyAllocHeap hpHw }
 401         ; setRealHp hpHw
 402         ; code }
 403   where
 404     full_fail_code  = fail_code `plusStmts` oneStmt assign_liveness
 405     assign_liveness = CmmAssign (CmmGlobal (VanillaReg 9))      -- Ho ho ho!
 406                                 (CmmLit (mkWordCLit liveness))
 407     liveness        = mkRegLiveness regs ptrs nptrs
 408     rts_label       = CmmLit (CmmLabel (mkRtsCodeLabel SLIT("stg_gc_ut")))
 409
 410 \end{code}
 411
 412
 413 %************************************************************************
 414 %*                                                                      *
 415                 Heap/Stack Checks.
 416 %*                                                                      *
 417 %************************************************************************
 418
 419 When failing a check, we save a return address on the stack and
 420 jump to a pre-compiled code fragment that saves the live registers
 421 and returns to the scheduler.
 422
 423 The return address in most cases will be the beginning of the basic
 424 block in which the check resides, since we need to perform the check
 425 again on re-entry because someone else might have stolen the resource
 426 in the meantime.
 427
 428 \begin{code}
 429 do_checks :: WordOff    -- Stack headroom
 430           -> WordOff    -- Heap  headroom
 431           -> CmmStmts   -- Assignments to perform on failure
 432           -> CmmExpr    -- Rts address to jump to on failure
 433           -> Code
 434 do_checks 0 0 _ _   = nopC
 435 do_checks stk hp reg_save_code rts_lbl
 436   = do_checks' (CmmLit (mkIntCLit (stk*wORD_SIZE)))
 437                (CmmLit (mkIntCLit (hp*wORD_SIZE)))
 438          (stk /= 0) (hp /= 0) reg_save_code rts_lbl
 439
 440 -- The offsets are now in *bytes*
 441 do_checks' stk_expr hp_expr stk_nonzero hp_nonzero reg_save_code rts_lbl
 442   = do  { doGranAllocate hp_expr
 443
 444         -- Emit a block for the heap-check-failure code
 445         ; blk_id <- forkLabelledCode $ do
 446                         { whenC hp_nonzero $
 447                                 stmtC (CmmAssign (CmmGlobal HpAlloc) hp_expr)
 448                         ; emitStmts reg_save_code
 449                         ; stmtC (CmmJump rts_lbl []) }
 450
 451         -- Check for stack overflow *FIRST*; otherwise
 452         -- we might bumping Hp and then failing stack oflo
 453         ; whenC stk_nonzero
 454                 (stmtC (CmmCondBranch stk_oflo blk_id))
 455
 456         ; whenC hp_nonzero
 457                 (stmtsC [CmmAssign hpReg
 458                                 (cmmOffsetExprB (CmmReg hpReg) hp_expr),
 459                         CmmCondBranch hp_oflo blk_id])
 460                 -- Bump heap pointer, and test for heap exhaustion
 461                 -- Note that we don't move the heap pointer unless the
 462                 -- stack check succeeds.  Otherwise we might end up
 463                 -- with slop at the end of the current block, which can
 464                 -- confuse the LDV profiler.
 465     }
 466   where
 467         -- Stk overflow if (Sp - stk_bytes < SpLim)
 468     stk_oflo = CmmMachOp mo_wordULt
 469                   [CmmMachOp mo_wordSub [CmmReg spReg, stk_expr],
 470                    CmmReg (CmmGlobal SpLim)]
 471
 472         -- Hp overflow if (Hpp > HpLim)
 473         -- (Hp has been incremented by now)
 474         -- HpLim points to the LAST WORD of valid allocation space.
 475     hp_oflo = CmmMachOp mo_wordUGt
 476                   [CmmReg hpReg, CmmReg (CmmGlobal HpLim)]
 477 \end{code}
 478
 479 %************************************************************************
 480 %*                                                                      *
 481      Generic Heap/Stack Checks - used in the RTS
 482 %*                                                                      *
 483 %************************************************************************
 484
 485 \begin{code}
 486 hpChkGen :: CmmExpr -> CmmExpr -> CmmExpr -> Code
 487 hpChkGen bytes liveness reentry
 488   = do_checks' (CmmLit (mkIntCLit 0)) bytes False True assigns stg_gc_gen
 489   where
 490     assigns = mkStmts [
 491                 CmmAssign (CmmGlobal (VanillaReg 9))  liveness,
 492                 CmmAssign (CmmGlobal (VanillaReg 10)) reentry
 493                 ]
 494
 495 -- a heap check where R1 points to the closure to enter on return, and
 496 -- we want to assign to Sp[0] on failure (used in AutoApply.cmm:BUILD_PAP).
 497 hpChkNodePointsAssignSp0 :: CmmExpr -> CmmExpr -> Code
 498 hpChkNodePointsAssignSp0 bytes sp0
 499   = do_checks' (CmmLit (mkIntCLit 0)) bytes False True assign stg_gc_enter1
 500   where assign = oneStmt (CmmStore (CmmReg spReg) sp0)
 501
 502 stkChkGen :: CmmExpr -> CmmExpr -> CmmExpr -> Code
 503 stkChkGen bytes liveness reentry
 504   = do_checks' bytes (CmmLit (mkIntCLit 0)) True False assigns stg_gc_gen
 505   where
 506     assigns = mkStmts [
 507                 CmmAssign (CmmGlobal (VanillaReg 9))  liveness,
 508                 CmmAssign (CmmGlobal (VanillaReg 10)) reentry
 509                 ]
 510
 511 stkChkNodePoints :: CmmExpr -> Code
 512 stkChkNodePoints bytes
 513   = do_checks' bytes (CmmLit (mkIntCLit 0)) True False noStmts stg_gc_enter1
 514
 515 stg_gc_gen = CmmLit (CmmLabel (mkRtsCodeLabel SLIT("stg_gc_gen")))
 516 stg_gc_enter1 = CmmReg (CmmGlobal GCEnter1)
 517 \end{code}
 518
 519 %************************************************************************
 520 %*                                                                      *
 521 \subsection[initClosure]{Initialise a dynamic closure}
 522 %*                                                                      *
 523 %************************************************************************
 524
 525 @allocDynClosure@ puts the thing in the heap, and modifies the virtual Hp
 526 to account for this.
 527
 528 \begin{code}
 529 allocDynClosure
 530         :: ClosureInfo
 531         -> CmmExpr              -- Cost Centre to stick in the object
 532         -> CmmExpr              -- Cost Centre to blame for this alloc
 533                                 -- (usually the same; sometimes "OVERHEAD")
 534
 535         -> [(CmmExpr, VirtualHpOffset)] -- Offsets from start of the object
 536                                         -- ie Info ptr has offset zero.
 537         -> FCode VirtualHpOffset        -- Returns virt offset of object
 538
 539 allocDynClosure cl_info use_cc blame_cc amodes_with_offsets
 540   = do  { virt_hp <- getVirtHp
 541
 542         -- FIND THE OFFSET OF THE INFO-PTR WORD
 543         ; let   info_offset = virt_hp + 1
 544                 -- info_offset is the VirtualHpOffset of the first
 545                 -- word of the new object
 546                 -- Remember, virtHp points to last allocated word,
 547                 -- ie 1 *before* the info-ptr word of new object.
 548
 549                 info_ptr = CmmLit (CmmLabel (infoTableLabelFromCI cl_info))
 550                 hdr_w_offsets = initDynHdr info_ptr use_cc `zip` [0..]
 551
 552         -- SAY WHAT WE ARE ABOUT TO DO
 553         ; profDynAlloc cl_info use_cc
 554                 -- ToDo: This is almost certainly wrong
 555                 -- We're ignoring blame_cc. But until we've
 556                 -- fixed the boxing hack in chooseDynCostCentres etc,
 557                 -- we're worried about making things worse by "fixing"
 558                 -- this part to use blame_cc!
 559
 560         ; tickyDynAlloc cl_info
 561
 562         -- ALLOCATE THE OBJECT
 563         ; base <- getHpRelOffset info_offset
 564         ; hpStore base (hdr_w_offsets ++ amodes_with_offsets)
 565
 566         -- BUMP THE VIRTUAL HEAP POINTER
 567         ; setVirtHp (virt_hp + closureSize cl_info)
 568
 569         -- RETURN PTR TO START OF OBJECT
 570         ; returnFC info_offset }
 571
 572
 573 initDynHdr :: CmmExpr
 574            -> CmmExpr           -- Cost centre to put in object
 575            -> [CmmExpr]
 576 initDynHdr info_ptr cc
 577   =  [info_ptr]
 578         -- ToDo: Gransim stuff
 579         -- ToDo: Parallel stuff
 580   ++ dynProfHdr cc
 581         -- No ticky header
 582
 583 hpStore :: CmmExpr -> [(CmmExpr, VirtualHpOffset)] -> Code
 584 -- Store the item (expr,off) in base[off]
 585 hpStore base es
 586   = stmtsC [ CmmStore (cmmOffsetW base off) val
 587            | (val, off) <- es ]
 588
 589 emitSetDynHdr :: CmmExpr -> CmmExpr -> CmmExpr -> Code
 590 emitSetDynHdr base info_ptr ccs
 591   = hpStore base (zip (initDynHdr info_ptr ccs) [0..])
 592 \end{code}