ghc/compiler/codeGen/CgHeapery.lhs

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