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