ghc/compiler/codeGen/CgHeapery.lhs

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