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