22007bf9fe233de1199e22c6178be6d97830f0a3
[ghc.git] / compiler / codeGen / StgCmmHeap.hs
1 -----------------------------------------------------------------------------
2 --
3 -- Stg to C--: heap management functions
4 --
5 -- (c) The University of Glasgow 2004-2006
6 --
7 -----------------------------------------------------------------------------
8
9 module StgCmmHeap (
10 getVirtHp, setVirtHp, setRealHp,
11 getHpRelOffset, hpRel,
12
13 entryHeapCheck, altHeapCheck, noEscapeHeapCheck, altHeapCheckReturnsTo,
14 heapStackCheckGen,
15 entryHeapCheck',
16
17 mkVirtHeapOffsets, mkVirtConstrOffsets,
18 mkStaticClosureFields, mkStaticClosure,
19
20 allocDynClosure, allocDynClosureCmm,
21 emitSetDynHdr
22 ) where
23
24 #include "HsVersions.h"
25
26 import StgSyn
27 import CLabel
28 import StgCmmLayout
29 import StgCmmUtils
30 import StgCmmMonad
31 import StgCmmProf
32 import StgCmmTicky
33 import StgCmmGran
34 import StgCmmClosure
35 import StgCmmEnv
36
37 import MkGraph
38
39 import Hoopl
40 import SMRep
41 import Cmm
42 import CmmUtils
43 import CostCentre
44 import Outputable
45 import IdInfo( CafInfo(..), mayHaveCafRefs )
46 import Module
47 import DynFlags
48 import FastString( mkFastString, fsLit )
49 import Util
50
51 import Control.Monad (when)
52 import Data.Maybe (isJust)
53
54 -----------------------------------------------------------
55 -- Initialise dynamic heap objects
56 -----------------------------------------------------------
57
58 allocDynClosure
59 :: CmmInfoTable
60 -> LambdaFormInfo
61 -> CmmExpr -- Cost Centre to stick in the object
62 -> CmmExpr -- Cost Centre to blame for this alloc
63 -- (usually the same; sometimes "OVERHEAD")
64
65 -> [(NonVoid StgArg, VirtualHpOffset)] -- Offsets from start of object
66 -- ie Info ptr has offset zero.
67 -- No void args in here
68 -> FCode CmmExpr -- returns Hp+n
69
70 allocDynClosureCmm
71 :: CmmInfoTable -> LambdaFormInfo -> CmmExpr -> CmmExpr
72 -> [(CmmExpr, VirtualHpOffset)]
73 -> FCode CmmExpr -- returns Hp+n
74
75 -- allocDynClosure allocates the thing in the heap,
76 -- and modifies the virtual Hp to account for this.
77 -- The second return value is the graph that sets the value of the
78 -- returned LocalReg, which should point to the closure after executing
79 -- the graph.
80
81 -- allocDynClosure returns an (Hp+8) CmmExpr, and hence the result is
82 -- only valid until Hp is changed. The caller should assign the
83 -- result to a LocalReg if it is required to remain live.
84 --
85 -- The reason we don't assign it to a LocalReg here is that the caller
86 -- is often about to call regIdInfo, which immediately assigns the
87 -- result of allocDynClosure to a new temp in order to add the tag.
88 -- So by not generating a LocalReg here we avoid a common source of
89 -- new temporaries and save some compile time. This can be quite
90 -- significant - see test T4801.
91
92
93 allocDynClosure info_tbl lf_info use_cc _blame_cc args_w_offsets
94 = do { let (args, offsets) = unzip args_w_offsets
95 ; cmm_args <- mapM getArgAmode args -- No void args
96 ; allocDynClosureCmm info_tbl lf_info
97 use_cc _blame_cc (zip cmm_args offsets)
98 }
99
100 allocDynClosureCmm info_tbl lf_info use_cc _blame_cc amodes_w_offsets
101 = do { virt_hp <- getVirtHp
102
103 -- SAY WHAT WE ARE ABOUT TO DO
104 ; let rep = cit_rep info_tbl
105 ; tickyDynAlloc rep lf_info
106 ; profDynAlloc rep use_cc
107
108 -- FIND THE OFFSET OF THE INFO-PTR WORD
109 ; let info_offset = virt_hp + 1
110 -- info_offset is the VirtualHpOffset of the first
111 -- word of the new object
112 -- Remember, virtHp points to last allocated word,
113 -- ie 1 *before* the info-ptr word of new object.
114
115 info_ptr = CmmLit (CmmLabel (cit_lbl info_tbl))
116
117 -- ALLOCATE THE OBJECT
118 ; base <- getHpRelOffset info_offset
119 ; emitComment $ mkFastString "allocDynClosure"
120 ; emitSetDynHdr base info_ptr use_cc
121 ; let (cmm_args, offsets) = unzip amodes_w_offsets
122 ; hpStore base cmm_args offsets
123
124 -- BUMP THE VIRTUAL HEAP POINTER
125 ; dflags <- getDynFlags
126 ; setVirtHp (virt_hp + heapClosureSize dflags rep)
127
128 ; getHpRelOffset info_offset
129 }
130
131 emitSetDynHdr :: CmmExpr -> CmmExpr -> CmmExpr -> FCode ()
132 emitSetDynHdr base info_ptr ccs
133 = do dflags <- getDynFlags
134 hpStore base (header dflags) [0..]
135 where
136 header :: DynFlags -> [CmmExpr]
137 header dflags = [info_ptr] ++ dynProfHdr dflags ccs
138 -- ToDo: Gransim stuff
139 -- ToDo: Parallel stuff
140 -- No ticky header
141
142 hpStore :: CmmExpr -> [CmmExpr] -> [VirtualHpOffset] -> FCode ()
143 -- Store the item (expr,off) in base[off]
144 hpStore base vals offs
145 = do dflags <- getDynFlags
146 let mk_store val off = mkStore (cmmOffsetW dflags base off) val
147 emit (catAGraphs (zipWith mk_store vals offs))
148
149
150 -----------------------------------------------------------
151 -- Layout of static closures
152 -----------------------------------------------------------
153
154 -- Make a static closure, adding on any extra padding needed for CAFs,
155 -- and adding a static link field if necessary.
156
157 mkStaticClosureFields
158 :: DynFlags
159 -> CmmInfoTable
160 -> CostCentreStack
161 -> CafInfo
162 -> [CmmLit] -- Payload
163 -> [CmmLit] -- The full closure
164 mkStaticClosureFields dflags info_tbl ccs caf_refs payload
165 = mkStaticClosure dflags info_lbl ccs payload padding
166 static_link_field saved_info_field
167 where
168 info_lbl = cit_lbl info_tbl
169
170 -- CAFs must have consistent layout, regardless of whether they
171 -- are actually updatable or not. The layout of a CAF is:
172 --
173 -- 3 saved_info
174 -- 2 static_link
175 -- 1 indirectee
176 -- 0 info ptr
177 --
178 -- the static_link and saved_info fields must always be in the
179 -- same place. So we use isThunkRep rather than closureUpdReqd
180 -- here:
181
182 is_caf = isThunkRep (cit_rep info_tbl)
183
184 padding
185 | not is_caf = []
186 | otherwise = ASSERT(null payload) [mkIntCLit dflags 0]
187
188 static_link_field
189 | is_caf || staticClosureNeedsLink (mayHaveCafRefs caf_refs) info_tbl
190 = [static_link_value]
191 | otherwise
192 = []
193
194 saved_info_field
195 | is_caf = [mkIntCLit dflags 0]
196 | otherwise = []
197
198 -- For a static constructor which has NoCafRefs, we set the
199 -- static link field to a non-zero value so the garbage
200 -- collector will ignore it.
201 static_link_value
202 | mayHaveCafRefs caf_refs = mkIntCLit dflags 0
203 | otherwise = mkIntCLit dflags 1 -- No CAF refs
204
205
206 mkStaticClosure :: DynFlags -> CLabel -> CostCentreStack -> [CmmLit]
207 -> [CmmLit] -> [CmmLit] -> [CmmLit] -> [CmmLit]
208 mkStaticClosure dflags info_lbl ccs payload padding static_link_field saved_info_field
209 = [CmmLabel info_lbl]
210 ++ variable_header_words
211 ++ concatMap (padLitToWord dflags) payload
212 ++ padding
213 ++ static_link_field
214 ++ saved_info_field
215 where
216 variable_header_words
217 = staticGranHdr
218 ++ staticParHdr
219 ++ staticProfHdr dflags ccs
220 ++ staticTickyHdr
221
222 -- JD: Simon had ellided this padding, but without it the C back end asserts
223 -- failure. Maybe it's a bad assertion, and this padding is indeed unnecessary?
224 padLitToWord :: DynFlags -> CmmLit -> [CmmLit]
225 padLitToWord dflags lit = lit : padding pad_length
226 where width = typeWidth (cmmLitType dflags lit)
227 pad_length = wORD_SIZE dflags - widthInBytes width :: Int
228
229 padding n | n <= 0 = []
230 | n `rem` 2 /= 0 = CmmInt 0 W8 : padding (n-1)
231 | n `rem` 4 /= 0 = CmmInt 0 W16 : padding (n-2)
232 | n `rem` 8 /= 0 = CmmInt 0 W32 : padding (n-4)
233 | otherwise = CmmInt 0 W64 : padding (n-8)
234
235 -----------------------------------------------------------
236 -- Heap overflow checking
237 -----------------------------------------------------------
238
239 {- Note [Heap checks]
240 ~~~~~~~~~~~~~~~~~~
241 Heap checks come in various forms. We provide the following entry
242 points to the runtime system, all of which use the native C-- entry
243 convention.
244
245 * gc() performs garbage collection and returns
246 nothing to its caller
247
248 * A series of canned entry points like
249 r = gc_1p( r )
250 where r is a pointer. This performs gc, and
251 then returns its argument r to its caller.
252
253 * A series of canned entry points like
254 gcfun_2p( f, x, y )
255 where f is a function closure of arity 2
256 This performs garbage collection, keeping alive the
257 three argument ptrs, and then tail-calls f(x,y)
258
259 These are used in the following circumstances
260
261 * entryHeapCheck: Function entry
262 (a) With a canned GC entry sequence
263 f( f_clo, x:ptr, y:ptr ) {
264 Hp = Hp+8
265 if Hp > HpLim goto L
266 ...
267 L: HpAlloc = 8
268 jump gcfun_2p( f_clo, x, y ) }
269 Note the tail call to the garbage collector;
270 it should do no register shuffling
271
272 (b) No canned sequence
273 f( f_clo, x:ptr, y:ptr, ...etc... ) {
274 T: Hp = Hp+8
275 if Hp > HpLim goto L
276 ...
277 L: HpAlloc = 8
278 call gc() -- Needs an info table
279 goto T }
280
281 * altHeapCheck: Immediately following an eval
282 Started as
283 case f x y of r { (p,q) -> rhs }
284 (a) With a canned sequence for the results of f
285 (which is the very common case since
286 all boxed cases return just one pointer
287 ...
288 r = f( x, y )
289 K: -- K needs an info table
290 Hp = Hp+8
291 if Hp > HpLim goto L
292 ...code for rhs...
293
294 L: r = gc_1p( r )
295 goto K }
296
297 Here, the info table needed by the call
298 to gc_1p should be the *same* as the
299 one for the call to f; the C-- optimiser
300 spots this sharing opportunity)
301
302 (b) No canned sequence for results of f
303 Note second info table
304 ...
305 (r1,r2,r3) = call f( x, y )
306 K:
307 Hp = Hp+8
308 if Hp > HpLim goto L
309 ...code for rhs...
310
311 L: call gc() -- Extra info table here
312 goto K
313
314 * generalHeapCheck: Anywhere else
315 e.g. entry to thunk
316 case branch *not* following eval,
317 or let-no-escape
318 Exactly the same as the previous case:
319
320 K: -- K needs an info table
321 Hp = Hp+8
322 if Hp > HpLim goto L
323 ...
324
325 L: call gc()
326 goto K
327 -}
328
329 --------------------------------------------------------------
330 -- A heap/stack check at a function or thunk entry point.
331
332 entryHeapCheck :: ClosureInfo
333 -> Maybe LocalReg -- Function (closure environment)
334 -> Int -- Arity -- not same as len args b/c of voids
335 -> [LocalReg] -- Non-void args (empty for thunk)
336 -> FCode ()
337 -> FCode ()
338
339 entryHeapCheck cl_info nodeSet arity args code
340 = entryHeapCheck' is_fastf node arity args code
341 where
342 node = case nodeSet of
343 Just r -> CmmReg (CmmLocal r)
344 Nothing -> CmmLit (CmmLabel $ staticClosureLabel cl_info)
345
346 is_fastf = case closureFunInfo cl_info of
347 Just (_, ArgGen _) -> False
348 _otherwise -> True
349
350 -- | lower-level version for CmmParse
351 entryHeapCheck' :: Bool -- is a known function pattern
352 -> CmmExpr -- expression for the closure pointer
353 -> Int -- Arity -- not same as len args b/c of voids
354 -> [LocalReg] -- Non-void args (empty for thunk)
355 -> FCode ()
356 -> FCode ()
357 entryHeapCheck' is_fastf node arity args code
358 = do dflags <- getDynFlags
359 let is_thunk = arity == 0
360
361 args' = map (CmmReg . CmmLocal) args
362 stg_gc_fun = CmmReg (CmmGlobal GCFun)
363 stg_gc_enter1 = CmmReg (CmmGlobal GCEnter1)
364
365 {- Thunks: jump stg_gc_enter_1
366
367 Function (fast): call (NativeNode) stg_gc_fun(fun, args)
368
369 Function (slow): call (slow) stg_gc_fun(fun, args)
370 -}
371 gc_call upd
372 | is_thunk
373 = mkJump dflags NativeNodeCall stg_gc_enter1 [node] upd
374
375 | is_fastf
376 = mkJump dflags NativeNodeCall stg_gc_fun (node : args') upd
377
378 | otherwise
379 = mkJump dflags Slow stg_gc_fun (node : args') upd
380
381 updfr_sz <- getUpdFrameOff
382
383 loop_id <- newLabelC
384 emitLabel loop_id
385 heapCheck True True (gc_call updfr_sz <*> mkBranch loop_id) code
386
387 -- ------------------------------------------------------------
388 -- A heap/stack check in a case alternative
389
390
391 -- If there are multiple alts and we need to GC, but don't have a
392 -- continuation already (the scrut was simple), then we should
393 -- pre-generate the continuation. (if there are multiple alts it is
394 -- always a canned GC point).
395
396 -- altHeapCheck:
397 -- If we have a return continuation,
398 -- then if it is a canned GC pattern,
399 -- then we do mkJumpReturnsTo
400 -- else we do a normal call to stg_gc_noregs
401 -- else if it is a canned GC pattern,
402 -- then generate the continuation and do mkCallReturnsTo
403 -- else we do a normal call to stg_gc_noregs
404
405 altHeapCheck :: [LocalReg] -> FCode a -> FCode a
406 altHeapCheck regs code = altOrNoEscapeHeapCheck False regs code
407
408 altOrNoEscapeHeapCheck :: Bool -> [LocalReg] -> FCode a -> FCode a
409 altOrNoEscapeHeapCheck checkYield regs code = do
410 dflags <- getDynFlags
411 case cannedGCEntryPoint dflags regs of
412 Nothing -> genericGC checkYield code
413 Just gc -> do
414 lret <- newLabelC
415 let (off, _, copyin) = copyInOflow dflags NativeReturn (Young lret) regs []
416 lcont <- newLabelC
417 emitOutOfLine lret (copyin <*> mkBranch lcont)
418 emitLabel lcont
419 cannedGCReturnsTo checkYield False gc regs lret off code
420
421 altHeapCheckReturnsTo :: [LocalReg] -> Label -> ByteOff -> FCode a -> FCode a
422 altHeapCheckReturnsTo regs lret off code
423 = do dflags <- getDynFlags
424 case cannedGCEntryPoint dflags regs of
425 Nothing -> genericGC False code
426 Just gc -> cannedGCReturnsTo False True gc regs lret off code
427
428 -- noEscapeHeapCheck is implemented identically to altHeapCheck (which
429 -- is more efficient), but cannot be optimized away in the non-allocating
430 -- case because it may occur in a loop
431 noEscapeHeapCheck :: [LocalReg] -> FCode a -> FCode a
432 noEscapeHeapCheck regs code = altOrNoEscapeHeapCheck True regs code
433
434 cannedGCReturnsTo :: Bool -> Bool -> CmmExpr -> [LocalReg] -> Label -> ByteOff
435 -> FCode a
436 -> FCode a
437 cannedGCReturnsTo checkYield cont_on_stack gc regs lret off code
438 = do dflags <- getDynFlags
439 updfr_sz <- getUpdFrameOff
440 heapCheck False checkYield (gc_call dflags gc updfr_sz) code
441 where
442 reg_exprs = map (CmmReg . CmmLocal) regs
443 -- Note [stg_gc arguments]
444
445 -- NB. we use the NativeReturn convention for passing arguments
446 -- to the canned heap-check routines, because we are in a case
447 -- alternative and hence the [LocalReg] was passed to us in the
448 -- NativeReturn convention.
449 gc_call dflags label sp
450 | cont_on_stack
451 = mkJumpReturnsTo dflags label NativeReturn reg_exprs lret off sp
452 | otherwise
453 = mkCallReturnsTo dflags label NativeReturn reg_exprs lret off sp []
454
455 genericGC :: Bool -> FCode a -> FCode a
456 genericGC checkYield code
457 = do updfr_sz <- getUpdFrameOff
458 lretry <- newLabelC
459 emitLabel lretry
460 call <- mkCall generic_gc (GC, GC) [] [] updfr_sz []
461 heapCheck False checkYield (call <*> mkBranch lretry) code
462
463 cannedGCEntryPoint :: DynFlags -> [LocalReg] -> Maybe CmmExpr
464 cannedGCEntryPoint dflags regs
465 = case map localRegType regs of
466 [] -> Just (mkGcLabel "stg_gc_noregs")
467 [ty]
468 | isGcPtrType ty -> Just (mkGcLabel "stg_gc_unpt_r1")
469 | isFloatType ty -> case width of
470 W32 -> Just (mkGcLabel "stg_gc_f1")
471 W64 -> Just (mkGcLabel "stg_gc_d1")
472 _ -> Nothing
473
474 | width == wordWidth dflags -> Just (mkGcLabel "stg_gc_unbx_r1")
475 | width == W64 -> Just (mkGcLabel "stg_gc_l1")
476 | otherwise -> Nothing
477 where
478 width = typeWidth ty
479 [ty1,ty2]
480 | isGcPtrType ty1
481 && isGcPtrType ty2 -> Just (mkGcLabel "stg_gc_pp")
482 [ty1,ty2,ty3]
483 | isGcPtrType ty1
484 && isGcPtrType ty2
485 && isGcPtrType ty3 -> Just (mkGcLabel "stg_gc_ppp")
486 [ty1,ty2,ty3,ty4]
487 | isGcPtrType ty1
488 && isGcPtrType ty2
489 && isGcPtrType ty3
490 && isGcPtrType ty4 -> Just (mkGcLabel "stg_gc_pppp")
491 _otherwise -> Nothing
492
493 -- Note [stg_gc arguments]
494 -- It might seem that we could avoid passing the arguments to the
495 -- stg_gc function, because they are already in the right registers.
496 -- While this is usually the case, it isn't always. Sometimes the
497 -- code generator has cleverly avoided the eval in a case, e.g. in
498 -- ffi/should_run/4221.hs we found
499 --
500 -- case a_r1mb of z
501 -- FunPtr x y -> ...
502 --
503 -- where a_r1mb is bound a top-level constructor, and is known to be
504 -- evaluated. The codegen just assigns x, y and z, and continues;
505 -- R1 is never assigned.
506 --
507 -- So we'll have to rely on optimisations to eliminatethese
508 -- assignments where possible.
509
510
511 -- | The generic GC procedure; no params, no results
512 generic_gc :: CmmExpr
513 generic_gc = mkGcLabel "stg_gc_noregs"
514
515 -- | Create a CLabel for calling a garbage collector entry point
516 mkGcLabel :: String -> CmmExpr
517 mkGcLabel s = CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageId (fsLit s)))
518
519 -------------------------------
520 heapCheck :: Bool -> Bool -> CmmAGraph -> FCode a -> FCode a
521 heapCheck checkStack checkYield do_gc code
522 = getHeapUsage $ \ hpHw ->
523 -- Emit heap checks, but be sure to do it lazily so
524 -- that the conditionals on hpHw don't cause a black hole
525 do { dflags <- getDynFlags
526 ; let mb_alloc_bytes
527 | hpHw > 0 = Just (mkIntExpr dflags (hpHw * (wORD_SIZE dflags)))
528 | otherwise = Nothing
529 stk_hwm | checkStack = Just (CmmLit CmmHighStackMark)
530 | otherwise = Nothing
531 ; codeOnly $ do_checks stk_hwm checkYield mb_alloc_bytes do_gc
532 ; tickyAllocHeap hpHw
533 ; doGranAllocate hpHw
534 ; setRealHp hpHw
535 ; code }
536
537 heapStackCheckGen :: Maybe CmmExpr -> Maybe CmmExpr -> FCode ()
538 heapStackCheckGen stk_hwm mb_bytes
539 = do updfr_sz <- getUpdFrameOff
540 lretry <- newLabelC
541 emitLabel lretry
542 call <- mkCall generic_gc (GC, GC) [] [] updfr_sz []
543 do_checks stk_hwm False mb_bytes (call <*> mkBranch lretry)
544
545 do_checks :: Maybe CmmExpr -- Should we check the stack?
546 -> Bool -- Should we check for preemption?
547 -> Maybe CmmExpr -- Heap headroom (bytes)
548 -> CmmAGraph -- What to do on failure
549 -> FCode ()
550 do_checks mb_stk_hwm checkYield mb_alloc_lit do_gc = do
551 dflags <- getDynFlags
552 gc_id <- newLabelC
553
554 let
555 Just alloc_lit = mb_alloc_lit
556
557 bump_hp = cmmOffsetExprB dflags (CmmReg hpReg) alloc_lit
558
559 -- Sp overflow if (Sp - CmmHighStack < SpLim)
560 sp_oflo sp_hwm =
561 CmmMachOp (mo_wordULt dflags)
562 [CmmMachOp (MO_Sub (typeWidth (cmmRegType dflags spReg)))
563 [CmmReg spReg, sp_hwm],
564 CmmReg spLimReg]
565
566 -- Hp overflow if (Hp > HpLim)
567 -- (Hp has been incremented by now)
568 -- HpLim points to the LAST WORD of valid allocation space.
569 hp_oflo = CmmMachOp (mo_wordUGt dflags)
570 [CmmReg hpReg, CmmReg (CmmGlobal HpLim)]
571
572 alloc_n = mkAssign (CmmGlobal HpAlloc) alloc_lit
573
574 case mb_stk_hwm of
575 Nothing -> return ()
576 Just stk_hwm -> emit =<< mkCmmIfGoto (sp_oflo stk_hwm) gc_id
577
578 if (isJust mb_alloc_lit)
579 then do
580 emitAssign hpReg bump_hp
581 emit =<< mkCmmIfThen hp_oflo (alloc_n <*> mkBranch gc_id)
582 else do
583 when (not (gopt Opt_OmitYields dflags) && checkYield) $ do
584 -- Yielding if HpLim == 0
585 let yielding = CmmMachOp (mo_wordEq dflags)
586 [CmmReg (CmmGlobal HpLim),
587 CmmLit (zeroCLit dflags)]
588 emit =<< mkCmmIfGoto yielding gc_id
589
590 emitOutOfLine gc_id $
591 do_gc -- this is expected to jump back somewhere
592
593 -- Test for stack pointer exhaustion, then
594 -- bump heap pointer, and test for heap exhaustion
595 -- Note that we don't move the heap pointer unless the
596 -- stack check succeeds. Otherwise we might end up
597 -- with slop at the end of the current block, which can
598 -- confuse the LDV profiler.
599
600 {-
601
602 {- Unboxed tuple alternatives and let-no-escapes (the two most annoying
603 constructs to generate code for!) For unboxed tuple returns, there
604 are an arbitrary number of possibly unboxed return values, some of
605 which will be in registers, and the others will be on the stack. We
606 always organise the stack-resident fields into pointers &
607 non-pointers, and pass the number of each to the heap check code. -}
608
609 unbxTupleHeapCheck
610 :: [(Id, GlobalReg)] -- Live registers
611 -> WordOff -- no. of stack slots containing ptrs
612 -> WordOff -- no. of stack slots containing nonptrs
613 -> CmmAGraph -- code to insert in the failure path
614 -> FCode ()
615 -> FCode ()
616
617 unbxTupleHeapCheck regs ptrs nptrs fail_code code
618 -- We can't manage more than 255 pointers/non-pointers
619 -- in a generic heap check.
620 | ptrs > 255 || nptrs > 255 = panic "altHeapCheck"
621 | otherwise
622 = initHeapUsage $ \ hpHw -> do
623 { codeOnly $ do { do_checks 0 {- no stack check -} hpHw
624 full_fail_code rts_label
625 ; tickyAllocHeap hpHw }
626 ; setRealHp hpHw
627 ; code }
628 where
629 full_fail_code = fail_code `plusStmts` oneStmt assign_liveness
630 assign_liveness = CmmAssign (CmmGlobal (VanillaReg 9)) -- Ho ho ho!
631 (CmmLit (mkWordCLit liveness))
632 liveness = mkRegLiveness regs ptrs nptrs
633 rts_label = CmmLit (CmmLabel (mkRtsCodeLabel (sLit "stg_gc_ut")))
634
635
636 {- Old Gransim com -- I have no idea whether it still makes sense (SLPJ Sep07)
637 For GrAnSim the code for doing a heap check and doing a context switch
638 has been separated. Especially, the HEAP_CHK macro only performs a
639 heap check. THREAD_CONTEXT_SWITCH should be used for doing a context
640 switch. GRAN_FETCH_AND_RESCHEDULE must be put at the beginning of
641 every slow entry code in order to simulate the fetching of
642 closures. If fetching is necessary (i.e. current closure is not local)
643 then an automatic context switch is done. -}
644
645
646 When failing a check, we save a return address on the stack and
647 jump to a pre-compiled code fragment that saves the live registers
648 and returns to the scheduler.
649
650 The return address in most cases will be the beginning of the basic
651 block in which the check resides, since we need to perform the check
652 again on re-entry because someone else might have stolen the resource
653 in the meantime.
654
655 %************************************************************************
656 %* *
657 Generic Heap/Stack Checks - used in the RTS
658 %* *
659 %************************************************************************
660
661 \begin{code}
662 hpChkGen :: CmmExpr -> CmmExpr -> CmmExpr -> FCode ()
663 hpChkGen bytes liveness reentry
664 = do_checks' bytes True assigns stg_gc_gen
665 where
666 assigns = mkStmts [
667 CmmAssign (CmmGlobal (VanillaReg 9)) liveness,
668 CmmAssign (CmmGlobal (VanillaReg 10)) reentry
669 ]
670
671 -- a heap check where R1 points to the closure to enter on return, and
672 -- we want to assign to Sp[0] on failure (used in AutoApply.cmm:BUILD_PAP).
673 hpChkNodePointsAssignSp0 :: CmmExpr -> CmmExpr -> FCode ()
674 hpChkNodePointsAssignSp0 bytes sp0
675 = do_checks' bytes True assign stg_gc_enter1
676 where assign = oneStmt (CmmStore (CmmReg spReg) sp0)
677
678 stg_gc_gen = CmmLit (CmmLabel (mkRtsCodeLabel (sLit "stg_gc_gen")))
679 \end{code}
680
681 -}