compiler/codeGen/CgHeapery.lhs

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