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