Produce new-style Cmm from the Cmm parser
[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): R1 = fun
370 call (slow) stg_gc_fun(args)
371 XXX: this is a bit naughty, we should really pass R1 as an
372 argument and use a special calling convention.
373 -}
374 gc_call upd
375 | is_thunk
376 = mkJump dflags stg_gc_enter1 [node] upd
377
378 | is_fastf
379 = mkJump dflags stg_gc_fun (node : args') upd
380
381 | otherwise
382 = mkAssign nodeReg node <*>
383 mkForeignJump dflags Slow stg_gc_fun args' upd
384
385 updfr_sz <- getUpdFrameOff
386
387 loop_id <- newLabelC
388 emitLabel loop_id
389 heapCheck True True (gc_call updfr_sz <*> mkBranch loop_id) code
390
391 -- ------------------------------------------------------------
392 -- A heap/stack check in a case alternative
393
394
395 -- If there are multiple alts and we need to GC, but don't have a
396 -- continuation already (the scrut was simple), then we should
397 -- pre-generate the continuation. (if there are multiple alts it is
398 -- always a canned GC point).
399
400 -- altHeapCheck:
401 -- If we have a return continuation,
402 -- then if it is a canned GC pattern,
403 -- then we do mkJumpReturnsTo
404 -- else we do a normal call to stg_gc_noregs
405 -- else if it is a canned GC pattern,
406 -- then generate the continuation and do mkCallReturnsTo
407 -- else we do a normal call to stg_gc_noregs
408
409 altHeapCheck :: [LocalReg] -> FCode a -> FCode a
410 altHeapCheck regs code = altOrNoEscapeHeapCheck False regs code
411
412 altOrNoEscapeHeapCheck :: Bool -> [LocalReg] -> FCode a -> FCode a
413 altOrNoEscapeHeapCheck checkYield regs code = do
414 dflags <- getDynFlags
415 case cannedGCEntryPoint dflags regs of
416 Nothing -> genericGC checkYield code
417 Just gc -> do
418 lret <- newLabelC
419 let (off, copyin) = copyInOflow dflags NativeReturn (Young lret) regs []
420 lcont <- newLabelC
421 emitOutOfLine lret (copyin <*> mkBranch lcont)
422 emitLabel lcont
423 cannedGCReturnsTo checkYield False gc regs lret off code
424
425 altHeapCheckReturnsTo :: [LocalReg] -> Label -> ByteOff -> FCode a -> FCode a
426 altHeapCheckReturnsTo regs lret off code
427 = do dflags <- getDynFlags
428 case cannedGCEntryPoint dflags regs of
429 Nothing -> genericGC False code
430 Just gc -> cannedGCReturnsTo False True gc regs lret off code
431
432 -- noEscapeHeapCheck is implemented identically to altHeapCheck (which
433 -- is more efficient), but cannot be optimized away in the non-allocating
434 -- case because it may occur in a loop
435 noEscapeHeapCheck :: [LocalReg] -> FCode a -> FCode a
436 noEscapeHeapCheck regs code = altOrNoEscapeHeapCheck True regs code
437
438 cannedGCReturnsTo :: Bool -> Bool -> CmmExpr -> [LocalReg] -> Label -> ByteOff
439 -> FCode a
440 -> FCode a
441 cannedGCReturnsTo checkYield cont_on_stack gc regs lret off code
442 = do dflags <- getDynFlags
443 updfr_sz <- getUpdFrameOff
444 heapCheck False checkYield (gc_call dflags gc updfr_sz) code
445 where
446 reg_exprs = map (CmmReg . CmmLocal) regs
447 -- Note [stg_gc arguments]
448
449 -- NB. we use the NativeReturn convention for passing arguments
450 -- to the canned heap-check routines, because we are in a case
451 -- alternative and hence the [LocalReg] was passed to us in the
452 -- NativeReturn convention.
453 gc_call dflags label sp
454 | cont_on_stack
455 = mkJumpReturnsTo dflags label NativeReturn reg_exprs lret off sp
456 | otherwise
457 = mkCallReturnsTo dflags label NativeReturn reg_exprs lret off sp []
458
459 genericGC :: Bool -> FCode a -> FCode a
460 genericGC checkYield code
461 = do updfr_sz <- getUpdFrameOff
462 lretry <- newLabelC
463 emitLabel lretry
464 call <- mkCall generic_gc (GC, GC) [] [] updfr_sz []
465 heapCheck False checkYield (call <*> mkBranch lretry) code
466
467 cannedGCEntryPoint :: DynFlags -> [LocalReg] -> Maybe CmmExpr
468 cannedGCEntryPoint dflags regs
469 = case map localRegType regs of
470 [] -> Just (mkGcLabel "stg_gc_noregs")
471 [ty]
472 | isGcPtrType ty -> Just (mkGcLabel "stg_gc_unpt_r1")
473 | isFloatType ty -> case width of
474 W32 -> Just (mkGcLabel "stg_gc_f1")
475 W64 -> Just (mkGcLabel "stg_gc_d1")
476 _ -> Nothing
477
478 | width == wordWidth dflags -> Just (mkGcLabel "stg_gc_unbx_r1")
479 | width == W64 -> Just (mkGcLabel "stg_gc_l1")
480 | otherwise -> Nothing
481 where
482 width = typeWidth ty
483 [ty1,ty2]
484 | isGcPtrType ty1
485 && isGcPtrType ty2 -> Just (mkGcLabel "stg_gc_pp")
486 [ty1,ty2,ty3]
487 | isGcPtrType ty1
488 && isGcPtrType ty2
489 && isGcPtrType ty3 -> Just (mkGcLabel "stg_gc_ppp")
490 [ty1,ty2,ty3,ty4]
491 | isGcPtrType ty1
492 && isGcPtrType ty2
493 && isGcPtrType ty3
494 && isGcPtrType ty4 -> Just (mkGcLabel "stg_gc_pppp")
495 _otherwise -> Nothing
496
497 -- Note [stg_gc arguments]
498 -- It might seem that we could avoid passing the arguments to the
499 -- stg_gc function, because they are already in the right registers.
500 -- While this is usually the case, it isn't always. Sometimes the
501 -- code generator has cleverly avoided the eval in a case, e.g. in
502 -- ffi/should_run/4221.hs we found
503 --
504 -- case a_r1mb of z
505 -- FunPtr x y -> ...
506 --
507 -- where a_r1mb is bound a top-level constructor, and is known to be
508 -- evaluated. The codegen just assigns x, y and z, and continues;
509 -- R1 is never assigned.
510 --
511 -- So we'll have to rely on optimisations to eliminatethese
512 -- assignments where possible.
513
514
515 -- | The generic GC procedure; no params, no results
516 generic_gc :: CmmExpr
517 generic_gc = mkGcLabel "stg_gc_noregs"
518
519 -- | Create a CLabel for calling a garbage collector entry point
520 mkGcLabel :: String -> CmmExpr
521 mkGcLabel s = CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageId (fsLit s)))
522
523 -------------------------------
524 heapCheck :: Bool -> Bool -> CmmAGraph -> FCode a -> FCode a
525 heapCheck checkStack checkYield do_gc code
526 = getHeapUsage $ \ hpHw ->
527 -- Emit heap checks, but be sure to do it lazily so
528 -- that the conditionals on hpHw don't cause a black hole
529 do { dflags <- getDynFlags
530 ; let mb_alloc_bytes
531 | hpHw > 0 = Just (mkIntExpr dflags (hpHw * (wORD_SIZE dflags)))
532 | otherwise = Nothing
533 stk_hwm | checkStack = Just (CmmLit CmmHighStackMark)
534 | otherwise = Nothing
535 ; codeOnly $ do_checks stk_hwm checkYield mb_alloc_bytes do_gc
536 ; tickyAllocHeap hpHw
537 ; doGranAllocate hpHw
538 ; setRealHp hpHw
539 ; code }
540
541 heapStackCheckGen :: Maybe CmmExpr -> Maybe CmmExpr -> FCode ()
542 heapStackCheckGen stk_hwm mb_bytes
543 = do updfr_sz <- getUpdFrameOff
544 lretry <- newLabelC
545 emitLabel lretry
546 call <- mkCall generic_gc (GC, GC) [] [] updfr_sz []
547 do_checks stk_hwm False mb_bytes (call <*> mkBranch lretry)
548
549 do_checks :: Maybe CmmExpr -- Should we check the stack?
550 -> Bool -- Should we check for preemption?
551 -> Maybe CmmExpr -- Heap headroom (bytes)
552 -> CmmAGraph -- What to do on failure
553 -> FCode ()
554 do_checks mb_stk_hwm checkYield mb_alloc_lit do_gc = do
555 dflags <- getDynFlags
556 gc_id <- newLabelC
557
558 let
559 Just alloc_lit = mb_alloc_lit
560
561 bump_hp = cmmOffsetExprB dflags (CmmReg hpReg) alloc_lit
562
563 -- Sp overflow if (Sp - CmmHighStack < SpLim)
564 sp_oflo sp_hwm =
565 CmmMachOp (mo_wordULt dflags)
566 [CmmMachOp (MO_Sub (typeWidth (cmmRegType dflags spReg)))
567 [CmmReg spReg, sp_hwm],
568 CmmReg spLimReg]
569
570 -- Hp overflow if (Hp > HpLim)
571 -- (Hp has been incremented by now)
572 -- HpLim points to the LAST WORD of valid allocation space.
573 hp_oflo = CmmMachOp (mo_wordUGt dflags)
574 [CmmReg hpReg, CmmReg (CmmGlobal HpLim)]
575
576 alloc_n = mkAssign (CmmGlobal HpAlloc) alloc_lit
577
578 case mb_stk_hwm of
579 Nothing -> return ()
580 Just stk_hwm -> emit =<< mkCmmIfGoto (sp_oflo stk_hwm) gc_id
581
582 if (isJust mb_alloc_lit)
583 then do
584 emitAssign hpReg bump_hp
585 emit =<< mkCmmIfThen hp_oflo (alloc_n <*> mkBranch gc_id)
586 else do
587 when (not (dopt Opt_OmitYields dflags) && checkYield) $ do
588 -- Yielding if HpLim == 0
589 let yielding = CmmMachOp (mo_wordEq dflags)
590 [CmmReg (CmmGlobal HpLim),
591 CmmLit (zeroCLit dflags)]
592 emit =<< mkCmmIfGoto yielding gc_id
593
594 emitOutOfLine gc_id $
595 do_gc -- this is expected to jump back somewhere
596
597 -- Test for stack pointer exhaustion, then
598 -- bump heap pointer, and test for heap exhaustion
599 -- Note that we don't move the heap pointer unless the
600 -- stack check succeeds. Otherwise we might end up
601 -- with slop at the end of the current block, which can
602 -- confuse the LDV profiler.
603
604 {-
605
606 {- Unboxed tuple alternatives and let-no-escapes (the two most annoying
607 constructs to generate code for!) For unboxed tuple returns, there
608 are an arbitrary number of possibly unboxed return values, some of
609 which will be in registers, and the others will be on the stack. We
610 always organise the stack-resident fields into pointers &
611 non-pointers, and pass the number of each to the heap check code. -}
612
613 unbxTupleHeapCheck
614 :: [(Id, GlobalReg)] -- Live registers
615 -> WordOff -- no. of stack slots containing ptrs
616 -> WordOff -- no. of stack slots containing nonptrs
617 -> CmmAGraph -- code to insert in the failure path
618 -> FCode ()
619 -> FCode ()
620
621 unbxTupleHeapCheck regs ptrs nptrs fail_code code
622 -- We can't manage more than 255 pointers/non-pointers
623 -- in a generic heap check.
624 | ptrs > 255 || nptrs > 255 = panic "altHeapCheck"
625 | otherwise
626 = initHeapUsage $ \ hpHw -> do
627 { codeOnly $ do { do_checks 0 {- no stack check -} hpHw
628 full_fail_code rts_label
629 ; tickyAllocHeap hpHw }
630 ; setRealHp hpHw
631 ; code }
632 where
633 full_fail_code = fail_code `plusStmts` oneStmt assign_liveness
634 assign_liveness = CmmAssign (CmmGlobal (VanillaReg 9)) -- Ho ho ho!
635 (CmmLit (mkWordCLit liveness))
636 liveness = mkRegLiveness regs ptrs nptrs
637 rts_label = CmmLit (CmmLabel (mkRtsCodeLabel (sLit "stg_gc_ut")))
638
639
640 {- Old Gransim com -- I have no idea whether it still makes sense (SLPJ Sep07)
641 For GrAnSim the code for doing a heap check and doing a context switch
642 has been separated. Especially, the HEAP_CHK macro only performs a
643 heap check. THREAD_CONTEXT_SWITCH should be used for doing a context
644 switch. GRAN_FETCH_AND_RESCHEDULE must be put at the beginning of
645 every slow entry code in order to simulate the fetching of
646 closures. If fetching is necessary (i.e. current closure is not local)
647 then an automatic context switch is done. -}
648
649
650 When failing a check, we save a return address on the stack and
651 jump to a pre-compiled code fragment that saves the live registers
652 and returns to the scheduler.
653
654 The return address in most cases will be the beginning of the basic
655 block in which the check resides, since we need to perform the check
656 again on re-entry because someone else might have stolen the resource
657 in the meantime.
658
659 %************************************************************************
660 %* *
661 Generic Heap/Stack Checks - used in the RTS
662 %* *
663 %************************************************************************
664
665 \begin{code}
666 hpChkGen :: CmmExpr -> CmmExpr -> CmmExpr -> FCode ()
667 hpChkGen bytes liveness reentry
668 = do_checks' bytes True assigns stg_gc_gen
669 where
670 assigns = mkStmts [
671 CmmAssign (CmmGlobal (VanillaReg 9)) liveness,
672 CmmAssign (CmmGlobal (VanillaReg 10)) reentry
673 ]
674
675 -- a heap check where R1 points to the closure to enter on return, and
676 -- we want to assign to Sp[0] on failure (used in AutoApply.cmm:BUILD_PAP).
677 hpChkNodePointsAssignSp0 :: CmmExpr -> CmmExpr -> FCode ()
678 hpChkNodePointsAssignSp0 bytes sp0
679 = do_checks' bytes True assign stg_gc_enter1
680 where assign = oneStmt (CmmStore (CmmReg spReg) sp0)
681
682 stg_gc_gen = CmmLit (CmmLabel (mkRtsCodeLabel (sLit "stg_gc_gen")))
683 \end{code}
684
685 -}