Add a class HasDynFlags(getDynFlags)
[ghc.git] / 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 -fno-warn-tabs #-}
9 -- The above warning supression flag is a temporary kludge.
10 -- While working on this module you are encouraged to remove it and
11 -- detab the module (please do the detabbing in a separate patch). See
12 --     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces
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 OldCmm
45 import OldCmmUtils
46 import Id
47 import DataCon
48 import TyCon
49 import CostCentre
50 import Util
51 import Module
52 import Constants
53 import Outputable
54 import FastString
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 :: Bool -> DataCon -> [(CgRep, a)]
133              -> (ClosureInfo, [(a, VirtualHpOffset)])
134 layOutConstr is_static data_con args
135    = (mkConInfo is_static data_con tot_wds ptr_wds,
136       things_w_offsets)
137   where
138     (tot_wds,            --  #ptr_wds + #nonptr_wds
139      ptr_wds,            --  #ptr_wds
140      things_w_offsets) = mkVirtHeapOffsets False{-not a thunk-} args
141 \end{code}
142
143 @mkVirtHeapOffsets@ always returns boxed things with smaller offsets
144 than the unboxed things, and furthermore, the offsets in the result
145 list
146
147 \begin{code}
148 mkVirtHeapOffsets
149           :: Bool               -- True <=> is a thunk
150           -> [(CgRep,a)]        -- Things to make offsets for
151           -> (WordOff,          -- _Total_ number of words allocated
152               WordOff,          -- Number of words allocated for *pointers*
153               [(a, VirtualHpOffset)])
154                                 -- Things with their offsets from start of 
155                                 --  object in order of increasing offset
156
157 -- First in list gets lowest offset, which is initial offset + 1.
158
159 mkVirtHeapOffsets is_thunk things
160   = let non_void_things               = filterOut (isVoidArg . fst) things
161         (ptrs, non_ptrs)              = separateByPtrFollowness non_void_things
162         (wds_of_ptrs, ptrs_w_offsets) = mapAccumL computeOffset 0 ptrs
163         (tot_wds, non_ptrs_w_offsets) = mapAccumL computeOffset wds_of_ptrs non_ptrs
164     in
165     (tot_wds, wds_of_ptrs, ptrs_w_offsets ++ non_ptrs_w_offsets)
166   where
167     hdr_size    | is_thunk   = thunkHdrSize
168                 | otherwise  = fixedHdrSize
169
170     computeOffset wds_so_far (rep, thing)
171       = (wds_so_far + cgRepSizeW rep, (thing, hdr_size + 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 
193         static_link_field saved_info_field
194   where
195     info_lbl = infoTableLabelFromCI cl_info
196
197     -- CAFs must have consistent layout, regardless of whether they
198     -- are actually updatable or not.  The layout of a CAF is:
199     --
200     --        3 saved_info
201     --        2 static_link
202     --        1 indirectee
203     --        0 info ptr
204     --
205     -- the static_link and saved_info fields must always be in the same
206     -- place.  So we use closureNeedsUpdSpace rather than
207     -- closureUpdReqd here:
208
209     is_caf = closureNeedsUpdSpace cl_info
210
211     padding_wds
212         | not is_caf = []
213         | otherwise  = ASSERT(null payload) [mkIntCLit 0]
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   ++ concatMap padLitToWord payload
236   ++ padding_wds
237   ++ static_link_field
238   ++ saved_info_field
239   where
240     variable_header_words
241         =  staticGranHdr
242         ++ staticParHdr
243         ++ staticProfHdr ccs
244         ++ staticTickyHdr
245
246 padLitToWord :: CmmLit -> [CmmLit]
247 padLitToWord lit = lit : padding pad_length
248   where width = typeWidth (cmmLitType lit)
249         pad_length = wORD_SIZE - widthInBytes width :: Int
250
251         padding n | n <= 0 = []
252                   | n `rem` 2 /= 0 = CmmInt 0 W8  : padding (n-1)
253                   | n `rem` 4 /= 0 = CmmInt 0 W16 : padding (n-2)
254                   | n `rem` 8 /= 0 = CmmInt 0 W32 : padding (n-4)
255                   | otherwise      = CmmInt 0 W64 : padding (n-8)
256 \end{code}
257
258 %************************************************************************
259 %*                                                                      *
260 \subsection[CgHeapery-heap-overflow]{Heap overflow checking}
261 %*                                                                      *
262 %************************************************************************
263
264 The new code  for heapChecks. For GrAnSim the code for doing a heap check
265 and doing a context switch has been separated. Especially, the HEAP_CHK
266 macro only performs a heap check. THREAD_CONTEXT_SWITCH should be used for
267 doing a context switch. GRAN_FETCH_AND_RESCHEDULE must be put at the
268 beginning of every slow entry code in order to simulate the fetching of
269 closures. If fetching is necessary (i.e. current closure is not local) then
270 an automatic context switch is done.
271
272 --------------------------------------------------------------
273 A heap/stack check at a function or thunk entry point.
274
275 \begin{code}
276 funEntryChecks :: ClosureInfo -> CmmStmts -> Code -> Code
277 funEntryChecks cl_info reg_save_code code 
278   = hpStkCheck cl_info True reg_save_code code
279
280 thunkEntryChecks :: ClosureInfo -> Code -> Code
281 thunkEntryChecks cl_info code 
282   = hpStkCheck cl_info False noStmts code
283
284 hpStkCheck :: ClosureInfo       -- Function closure
285            -> Bool              -- Is a function? (not a thunk)
286            -> CmmStmts          -- Register saves
287            -> Code
288            -> Code
289
290 hpStkCheck cl_info is_fun reg_save_code code
291   =  getFinalStackHW    $ \ spHw -> do
292         { sp <- getRealSp
293         ; let stk_words = spHw - sp
294         ; initHeapUsage $ \ hpHw  -> do
295             {   -- Emit heap checks, but be sure to do it lazily so 
296                 -- that the conditionals on hpHw don't cause a black hole
297               codeOnly $ do
298                 { do_checks stk_words hpHw full_save_code rts_label
299                 ; tickyAllocHeap hpHw }
300             ; setRealHp hpHw
301             ; code }
302         }
303   where
304     node_asst 
305         | nodeMustPointToIt (closureLFInfo cl_info)
306         = noStmts
307         | otherwise
308         = oneStmt (CmmAssign nodeReg (CmmLit (CmmLabel closure_lbl)))
309         -- Strictly speaking, we should tag node here.  But if
310         -- node doesn't point to the closure, the code for the closure
311         -- cannot depend on the value of R1 anyway, so we're safe.
312     closure_lbl = closureLabelFromCI cl_info
313
314     full_save_code = node_asst `plusStmts` reg_save_code
315
316     rts_label | is_fun    = CmmReg (CmmGlobal GCFun)
317                                 -- Function entry point
318               | otherwise = CmmReg (CmmGlobal GCEnter1)
319                                 -- Thunk or case return
320         -- In the thunk/case-return case, R1 points to a closure
321         -- which should be (re)-entered after GC
322 \end{code}
323
324 Heap checks in a case alternative are nice and easy, provided this is
325 a bog-standard algebraic case.  We have in our hand:
326
327        * one return address, on the stack,
328        * one return value, in Node.
329
330 the canned code for this heap check failure just pushes Node on the
331 stack, saying 'EnterGHC' to return.  The scheduler will return by
332 entering the top value on the stack, which in turn will return through
333 the return address, getting us back to where we were.  This is
334 therefore only valid if the return value is *lifted* (just being
335 boxed isn't good enough).
336
337 For primitive returns, we have an unlifted value in some register
338 (either R1 or FloatReg1 or DblReg1).  This means using specialised
339 heap-check code for these cases.
340
341 \begin{code}
342 altHeapCheck 
343     :: AltType  -- PolyAlt, PrimAlt, AlgAlt, but *not* UbxTupAlt
344                 --      (Unboxed tuples are dealt with by ubxTupleHeapCheck)
345     -> Code     -- Continuation
346     -> Code
347 altHeapCheck alt_type code
348   = initHeapUsage $ \ hpHw -> do
349         { codeOnly $ do
350              { do_checks 0 {- no stack chk -} hpHw
351                          noStmts {- nothign to save -}
352                          (rts_label alt_type)
353              ; tickyAllocHeap hpHw }
354         ; setRealHp hpHw
355         ; code }
356   where
357     rts_label PolyAlt = CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageId (fsLit "stg_gc_unpt_r1")))
358         -- Do *not* enter R1 after a heap check in
359         -- a polymorphic case.  It might be a function
360         -- and the entry code for a function (currently)
361         -- applies it
362         --
363         -- However R1 is guaranteed to be a pointer
364
365     rts_label (AlgAlt _) = stg_gc_enter1
366         -- Enter R1 after the heap check; it's a pointer
367         
368     rts_label (PrimAlt tc)
369       = CmmLit $ CmmLabel $ 
370         case primRepToCgRep (tyConPrimRep tc) of
371           VoidArg   -> mkCmmCodeLabel rtsPackageId (fsLit "stg_gc_noregs")
372           FloatArg  -> mkCmmCodeLabel rtsPackageId (fsLit "stg_gc_f1")
373           DoubleArg -> mkCmmCodeLabel rtsPackageId (fsLit "stg_gc_d1")
374           LongArg   -> mkCmmCodeLabel rtsPackageId (fsLit "stg_gc_l1")
375                                 -- R1 is boxed but unlifted: 
376           PtrArg    -> mkCmmCodeLabel rtsPackageId (fsLit "stg_gc_unpt_r1")
377                                 -- R1 is unboxed:
378           NonPtrArg -> mkCmmCodeLabel rtsPackageId (fsLit "stg_gc_unbx_r1")
379
380     rts_label (UbxTupAlt _) = panic "altHeapCheck"
381 \end{code}
382
383
384 Unboxed tuple alternatives and let-no-escapes (the two most annoying
385 constructs to generate code for!)  For unboxed tuple returns, there
386 are an arbitrary number of possibly unboxed return values, some of
387 which will be in registers, and the others will be on the stack.  We
388 always organise the stack-resident fields into pointers &
389 non-pointers, and pass the number of each to the heap check code.
390
391 \begin{code}
392 unbxTupleHeapCheck 
393         :: [(Id, GlobalReg)]    -- Live registers
394         -> WordOff      -- no. of stack slots containing ptrs
395         -> WordOff      -- no. of stack slots containing nonptrs
396         -> CmmStmts     -- code to insert in the failure path
397         -> Code
398         -> Code
399
400 unbxTupleHeapCheck regs ptrs nptrs fail_code code
401   -- We can't manage more than 255 pointers/non-pointers 
402   -- in a generic heap check.
403   | ptrs > 255 || nptrs > 255 = panic "altHeapCheck"
404   | otherwise 
405   = initHeapUsage $ \ hpHw -> do
406         { codeOnly $ do { do_checks 0 {- no stack check -} hpHw
407                                     full_fail_code rts_label
408                         ; tickyAllocHeap hpHw }
409         ; setRealHp hpHw
410         ; code }
411   where
412     full_fail_code  = fail_code `plusStmts` oneStmt assign_liveness
413     assign_liveness = CmmAssign (CmmGlobal (VanillaReg 9 VNonGcPtr))    -- Ho ho ho!
414                                 (CmmLit (mkWordCLit liveness))
415     liveness        = mkRegLiveness regs ptrs nptrs
416     rts_label       = CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageId (fsLit "stg_gc_ut")))
417
418 \end{code}
419
420
421 %************************************************************************
422 %*                                                                      *
423                 Heap/Stack Checks.
424 %*                                                                      *
425 %************************************************************************
426
427 When failing a check, we save a return address on the stack and
428 jump to a pre-compiled code fragment that saves the live registers
429 and returns to the scheduler.
430
431 The return address in most cases will be the beginning of the basic
432 block in which the check resides, since we need to perform the check
433 again on re-entry because someone else might have stolen the resource
434 in the meantime.
435
436 \begin{code}
437 do_checks :: WordOff    -- Stack headroom
438           -> WordOff    -- Heap  headroom
439           -> CmmStmts   -- Assignments to perform on failure
440           -> CmmExpr    -- Rts address to jump to on failure
441           -> Code
442 do_checks 0 0 _ _   = nopC
443
444 do_checks _ hp _ _
445   | hp > bLOCKS_PER_MBLOCK * bLOCK_SIZE_W
446   = sorry (unlines [
447             "Trying to allocate more than " ++ show (bLOCKS_PER_MBLOCK * bLOCK_SIZE) ++ " bytes.", 
448             "",
449             "See: http://hackage.haskell.org/trac/ghc/ticket/4505",
450             "Suggestion: read data from a file instead of having large static data",
451             "structures in the code."])
452
453 do_checks stk hp reg_save_code rts_lbl
454   = do_checks' (CmmLit (mkIntCLit (stk*wORD_SIZE))) 
455                (CmmLit (mkIntCLit (hp*wORD_SIZE)))
456          (stk /= 0) (hp /= 0) reg_save_code rts_lbl
457
458 -- The offsets are now in *bytes*
459 do_checks' :: CmmExpr -> CmmExpr -> Bool -> Bool -> CmmStmts -> CmmExpr -> Code
460 do_checks' stk_expr hp_expr stk_nonzero hp_nonzero reg_save_code rts_lbl
461   = do  { doGranAllocate hp_expr
462
463         -- The failure block: this saves the registers and jumps to
464         -- the appropriate RTS stub.
465         ; exit_blk_id <- forkLabelledCode $ do {
466                         ; emitStmts reg_save_code
467                         ; stmtC (CmmJump rts_lbl []) }
468
469         -- In the case of a heap-check failure, we must also set
470         -- HpAlloc.  NB. HpAlloc is *only* set if Hp has been
471         -- incremented by the heap check, it must not be set in the
472         -- event that a stack check failed, because the RTS stub will
473         -- retreat Hp by HpAlloc.
474         ; hp_blk_id <- if hp_nonzero
475                           then forkLabelledCode $ do
476                                   stmtC (CmmAssign (CmmGlobal HpAlloc) hp_expr)
477                                   stmtC (CmmBranch exit_blk_id)
478                           else return exit_blk_id
479
480         -- Check for stack overflow *FIRST*; otherwise
481         -- we might bumping Hp and then failing stack oflo
482         ; whenC stk_nonzero
483                 (stmtC (CmmCondBranch stk_oflo exit_blk_id))
484
485         ; whenC hp_nonzero
486                 (stmtsC [CmmAssign hpReg 
487                                 (cmmOffsetExprB (CmmReg hpReg) hp_expr),
488                         CmmCondBranch hp_oflo hp_blk_id])
489                 -- Bump heap pointer, and test for heap exhaustion
490                 -- Note that we don't move the heap pointer unless the 
491                 -- stack check succeeds.  Otherwise we might end up
492                 -- with slop at the end of the current block, which can 
493                 -- confuse the LDV profiler.
494     }
495   where
496         -- Stk overflow if (Sp - stk_bytes < SpLim)
497     stk_oflo = CmmMachOp mo_wordULt 
498                   [CmmMachOp mo_wordSub [CmmReg spReg, stk_expr],
499                    CmmReg (CmmGlobal SpLim)]
500
501         -- Hp overflow if (Hp > HpLim)
502         -- (Hp has been incremented by now)
503         -- HpLim points to the LAST WORD of valid allocation space.
504     hp_oflo = CmmMachOp mo_wordUGt 
505                   [CmmReg hpReg, CmmReg (CmmGlobal HpLim)]
506 \end{code}
507
508 %************************************************************************
509 %*                                                                      *
510      Generic Heap/Stack Checks - used in the RTS
511 %*                                                                      *
512 %************************************************************************
513
514 \begin{code}
515 hpChkGen :: CmmExpr -> CmmExpr -> CmmExpr -> Code
516 hpChkGen bytes liveness reentry
517   = do_checks' (CmmLit (mkIntCLit 0)) bytes False True assigns stg_gc_gen
518   where
519     assigns = mkStmts [ mk_vanilla_assignment 9 liveness,
520                         mk_vanilla_assignment 10 reentry ]
521
522 -- a heap check where R1 points to the closure to enter on return, and
523 -- we want to assign to Sp[0] on failure (used in AutoApply.cmm:BUILD_PAP).
524 hpChkNodePointsAssignSp0 :: CmmExpr -> CmmExpr -> Code
525 hpChkNodePointsAssignSp0 bytes sp0
526   = do_checks' (CmmLit (mkIntCLit 0)) bytes False True assign stg_gc_enter1
527   where assign = oneStmt (CmmStore (CmmReg spReg) sp0)
528
529 stkChkGen :: CmmExpr -> CmmExpr -> CmmExpr -> Code
530 stkChkGen bytes liveness reentry
531   = do_checks' bytes (CmmLit (mkIntCLit 0)) True False assigns stg_gc_gen
532   where
533     assigns = mkStmts [ mk_vanilla_assignment 9 liveness,
534                         mk_vanilla_assignment 10 reentry ]
535
536 mk_vanilla_assignment :: Int -> CmmExpr -> CmmStmt
537 mk_vanilla_assignment n e
538   = CmmAssign (CmmGlobal (VanillaReg n (vgcFlag (cmmExprType e)))) e
539
540 stkChkNodePoints :: CmmExpr -> Code
541 stkChkNodePoints bytes
542   = do_checks' bytes (CmmLit (mkIntCLit 0)) True False noStmts stg_gc_enter1
543
544 stg_gc_gen :: CmmExpr
545 stg_gc_gen = CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageId (fsLit "stg_gc_gen")))
546 stg_gc_enter1 :: CmmExpr
547 stg_gc_enter1 = CmmReg (CmmGlobal GCEnter1)
548 \end{code}
549
550 %************************************************************************
551 %*                                                                      *
552 \subsection[initClosure]{Initialise a dynamic closure}
553 %*                                                                      *
554 %************************************************************************
555
556 @allocDynClosure@ puts the thing in the heap, and modifies the virtual Hp
557 to account for this.
558
559 \begin{code}
560 allocDynClosure
561         :: ClosureInfo
562         -> CmmExpr              -- Cost Centre to stick in the object
563         -> CmmExpr              -- Cost Centre to blame for this alloc
564                                 -- (usually the same; sometimes "OVERHEAD")
565
566         -> [(CmmExpr, VirtualHpOffset)] -- Offsets from start of the object
567                                         -- ie Info ptr has offset zero.
568         -> FCode VirtualHpOffset        -- Returns virt offset of object
569
570 allocDynClosure cl_info use_cc _blame_cc amodes_with_offsets
571   = do  { virt_hp <- getVirtHp
572
573         -- FIND THE OFFSET OF THE INFO-PTR WORD
574         ; let   info_offset = virt_hp + 1
575                 -- info_offset is the VirtualHpOffset of the first
576                 -- word of the new object
577                 -- Remember, virtHp points to last allocated word, 
578                 -- ie 1 *before* the info-ptr word of new object.
579
580                 info_ptr = CmmLit (CmmLabel (infoTableLabelFromCI cl_info))
581                 hdr_w_offsets = initDynHdr info_ptr use_cc `zip` [0..]
582
583         -- SAY WHAT WE ARE ABOUT TO DO
584         ; profDynAlloc cl_info use_cc   
585         ; tickyDynAlloc cl_info
586
587         -- ALLOCATE THE OBJECT
588         ; base <- getHpRelOffset info_offset
589         ; hpStore base (hdr_w_offsets ++ amodes_with_offsets)
590
591         -- BUMP THE VIRTUAL HEAP POINTER
592         ; setVirtHp (virt_hp + closureSize cl_info)
593         
594         -- RETURN PTR TO START OF OBJECT
595         ; returnFC info_offset }
596
597
598 initDynHdr :: CmmExpr 
599            -> CmmExpr           -- Cost centre to put in object
600            -> [CmmExpr]
601 initDynHdr info_ptr cc
602   =  [info_ptr]
603         -- ToDo: Gransim stuff
604         -- ToDo: Parallel stuff
605   ++ dynProfHdr cc
606         -- No ticky header
607
608 hpStore :: CmmExpr -> [(CmmExpr, VirtualHpOffset)] -> Code
609 -- Store the item (expr,off) in base[off]
610 hpStore base es
611   = stmtsC [ CmmStore (cmmOffsetW base off) val 
612            | (val, off) <- es ]
613
614 emitSetDynHdr :: CmmExpr -> CmmExpr -> CmmExpr -> Code
615 emitSetDynHdr base info_ptr ccs 
616   = hpStore base (zip (initDynHdr info_ptr ccs) [0..])
617 \end{code}