ghc/compiler/codeGen/CgHeapery.lhs

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