2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4 % $Id: CgHeapery.lhs,v 1.25 2000/11/06 08:15:21 simonpj Exp $
6 \section[CgHeapery]{Heap management functions}
10 fastEntryChecks, altHeapCheck, thunkChecks,
11 allocDynClosure, inPlaceAllocDynClosure
13 -- new functions, basically inserting macro calls into Code -- HWL
14 ,fetchAndReschedule, yield
17 #include "HsVersions.h"
23 import CgStackery ( getFinalStackHW, mkTaggedStkAmodes, mkTagAssts )
24 import AbsCUtils ( mkAbstractCs, getAmodeRep )
25 import CgUsages ( getVirtAndRealHp, getRealSp, setVirtHp, setRealHp,
28 import ClosureInfo ( closureSize, closureGoodStuffSize,
29 slopSize, allocProfilingMsg, ClosureInfo
31 import PrimRep ( PrimRep(..), isFollowableRep )
32 import Unique ( Unique )
33 import CmdLineOpts ( opt_SccProfilingOn, opt_GranMacros )
34 import Constants ( bLOCK_SIZE_W )
39 import PprAbsC ( pprMagicId ) -- tmp
43 %************************************************************************
45 \subsection[CgHeapery-heap-overflow]{Heap overflow checking}
47 %************************************************************************
49 The new code for heapChecks. For GrAnSim the code for doing a heap check
50 and doing a context switch has been separated. Especially, the HEAP_CHK
51 macro only performs a heap check. THREAD_CONTEXT_SWITCH should be used for
52 doing a context switch. GRAN_FETCH_AND_RESCHEDULE must be put at the
53 beginning of every slow entry code in order to simulate the fetching of
54 closures. If fetching is necessary (i.e. current closure is not local) then
55 an automatic context switch is done.
57 -----------------------------------------------------------------------------
58 A heap/stack check at a fast entry point.
63 :: [MagicId] -- Live registers
64 -> [(VirtualSpOffset,Int)] -- stack slots to tag
65 -> CLabel -- return point
66 -> Bool -- node points to closure
70 fastEntryChecks regs tags ret node_points code
71 = mkTagAssts tags `thenFC` \tag_assts ->
72 getFinalStackHW (\ spHw ->
73 getRealSp `thenFC` \ sp ->
74 let stk_words = spHw - sp in
75 initHeapUsage (\ hp_words ->
77 let hHw = if hp_words > bLOCK_SIZE_W then hpChkTooBig else hp_words in
79 getTickyCtrLabel `thenFC` \ ticky_ctr ->
81 ( if all_pointers then -- heap checks are quite easy
82 -- HWL: gran-yield immediately before heap check proper
83 --(if node `elem` regs
84 -- then yield regs True
85 -- else absC AbsCNop ) `thenC`
86 absC (checking_code stk_words hHw tag_assts
87 free_reg (length regs) ticky_ctr)
89 else -- they are complicated
91 -- save all registers on the stack and adjust the stack pointer.
92 -- ToDo: find the initial all-pointer segment and don't save them.
94 mkTaggedStkAmodes sp addrmode_regs
95 `thenFC` \(new_sp, stk_assts, more_tag_assts) ->
97 -- only let the extra stack assignments affect the stack
98 -- high water mark if we were doing a stack check anyway;
99 -- otherwise we end up generating unnecessary stack checks.
100 -- Careful about knot-tying loops!
101 let real_stk_words = if new_sp - sp > stk_words && stk_words /= 0
106 let adjust_sp = CAssign (CReg Sp) (CAddr (spRel sp new_sp)) in
108 absC (checking_code real_stk_words hHw
109 (mkAbstractCs [tag_assts, stk_assts, more_tag_assts,
111 (CReg node) 0 ticky_ctr)
115 setRealHp hp_words `thenC`
120 checking_code stk hp assts ret regs ctr
123 if hp == 0 then AbsCNop
124 else profCtrAbsC SLIT("TICK_ALLOC_HEAP")
125 [ mkIntCLit hp, CLbl ctr DataPtrRep ]
129 | node_points = do_checks_np stk hp assts (regs+1)
130 | otherwise = do_checks stk hp assts ret regs
132 -- When node points to the closure for the function:
135 :: Int -- stack headroom
136 -> Int -- heap headroom
137 -> AbstractC -- assignments to perform on failure
138 -> Int -- number of pointer registers live
140 do_checks_np 0 0 _ _ = AbsCNop
141 do_checks_np 0 hp_words tag_assts ptrs =
147 do_checks_np stk_words 0 tag_assts ptrs =
153 do_checks_np stk_words hp_words tag_assts ptrs =
154 CCheck HP_STK_CHK_NP [
161 -- When node doesn't point to the closure (we need an explicit retn addr)
164 :: Int -- stack headroom
165 -> Int -- heap headroom
166 -> AbstractC -- assignments to perform on failure
167 -> CAddrMode -- a register to hold the retn addr.
168 -> Int -- number of pointer registers live
171 do_checks 0 0 _ _ _ = AbsCNop
172 do_checks 0 hp_words tag_assts ret_reg ptrs =
180 do_checks stk_words 0 tag_assts ret_reg ptrs =
188 do_checks stk_words hp_words tag_assts ret_reg ptrs =
198 free_reg = case length regs + 1 of
199 I# x -> CReg (VanillaReg PtrRep x)
201 all_pointers = all pointer regs
202 pointer (VanillaReg rep _) = isFollowableRep rep
205 addrmode_regs = map CReg regs
207 -- Checking code for thunks is just a special case of fast entry points:
209 thunkChecks :: CLabel -> Bool -> Code -> Code
210 thunkChecks ret node_points code = fastEntryChecks [] [] ret node_points code
213 Heap checks in a case alternative are nice and easy, provided this is
214 a bog-standard algebraic case. We have in our hand:
216 * one return address, on the stack,
217 * one return value, in Node.
219 the canned code for this heap check failure just pushes Node on the
220 stack, saying 'EnterGHC' to return. The scheduler will return by
221 entering the top value on the stack, which in turn will return through
222 the return address, getting us back to where we were. This is
223 therefore only valid if the return value is *lifted* (just being
224 boxed isn't good enough). Only a PtrRep will do.
226 For primitive returns, we have an unlifted value in some register
227 (either R1 or FloatReg1 or DblReg1). This means using specialised
228 heap-check code for these cases.
230 For unboxed tuple returns, there are an arbitrary number of possibly
231 unboxed return values, some of which will be in registers, and the
232 others will be on the stack, with gaps left for tagging the unboxed
233 objects. If a heap check is required, we need to fill in these tags.
235 The code below will cover all cases for the x86 architecture (where R1
236 is the only VanillaReg ever used). For other architectures, we'll
237 have to do something about saving and restoring the other registers.
241 :: Bool -- is an algebraic alternative
242 -> [MagicId] -- live registers
243 -> [(VirtualSpOffset,Int)] -- stack slots to tag
245 -> Maybe Unique -- uniq of ret address (possibly)
249 -- unboxed tuple alternatives and let-no-escapes (the two most annoying
250 -- constructs to generate code for!):
252 altHeapCheck is_fun regs tags fail_code (Just ret_addr) code
253 = mkTagAssts tags `thenFC` \tag_assts1 ->
254 let tag_assts = mkAbstractCs [fail_code, tag_assts1]
256 initHeapUsage (\ hHw ->
257 do_heap_chk (if hHw > bLOCK_SIZE_W then hpChkTooBig else hHw) tag_assts
260 do_heap_chk words_required tag_assts
261 = getTickyCtrLabel `thenFC` \ ctr ->
262 absC ( if words_required == 0
265 [ checking_code tag_assts,
266 profCtrAbsC SLIT("TICK_ALLOC_HEAP")
267 [ mkIntCLit words_required, CLbl ctr DataPtrRep ]
270 setRealHp words_required
273 non_void_regs = filter (/= VoidReg) regs
275 checking_code tag_assts =
276 case non_void_regs of
278 {- no: there might be stuff on top of the retn. addr. on the stack.
281 [mkIntCLit words_required]
284 -- this will cover all cases for x86
287 | isFollowableRep rep ->
289 [mkIntCLit words_required, mkIntCLit 1, mkIntCLit 0,
290 CReg (VanillaReg RetRep 2#),
291 CLbl (mkReturnInfoLabel ret_addr) RetRep]
296 [mkIntCLit words_required, mkIntCLit 0, mkIntCLit 1,
297 CReg (VanillaReg RetRep 2#),
298 CLbl (mkReturnInfoLabel ret_addr) RetRep]
302 let liveness = mkRegLiveness several_regs
305 [mkIntCLit words_required,
306 mkIntCLit (I# (word2Int# liveness)),
307 -- HP_CHK_GEN needs a direct return address,
308 -- not an info table (might be different if
309 -- we're not assembly-mangling/tail-jumping etc.)
310 CLbl (mkReturnPtLabel ret_addr) RetRep]
313 -- normal algebraic and primitive case alternatives:
315 altHeapCheck is_fun regs [] AbsCNop Nothing code
316 = initHeapUsage (\ hHw ->
317 do_heap_chk (if hHw > bLOCK_SIZE_W then hpChkTooBig else hHw)
321 do_heap_chk :: HeapOffset -> Code
322 do_heap_chk words_required
323 = getTickyCtrLabel `thenFC` \ ctr ->
324 absC ( if words_required == 0
328 profCtrAbsC SLIT("TICK_ALLOC_HEAP")
329 [ mkIntCLit words_required, CLbl ctr DataPtrRep ]
332 setRealHp words_required
335 non_void_regs = filter (/= VoidReg) regs
338 case non_void_regs of
340 -- No regs live: probably a Void return
342 CCheck HP_CHK_NOREGS [mkIntCLit words_required] AbsCNop
344 -- The SEQ case (polymophic/function typed case branch)
345 -- We need this case because the closure in Node won't return
346 -- directly when we enter it (it could be a function), so the
347 -- heap check code needs to push a seq frame on top of the stack.
352 [mkIntCLit words_required, mkIntCLit 1{-regs live-}]
355 -- R1 is lifted (the common case)
359 [mkIntCLit words_required, mkIntCLit 1{-regs live-}]
362 -- R1 is boxed, but unlifted
363 | isFollowableRep rep ->
364 CCheck HP_CHK_UNPT_R1 [mkIntCLit words_required] AbsCNop
368 CCheck HP_CHK_UNBX_R1 [mkIntCLit words_required] AbsCNop
372 CCheck HP_CHK_F1 [mkIntCLit words_required] AbsCNop
376 CCheck HP_CHK_D1 [mkIntCLit words_required] AbsCNop
380 CCheck HP_CHK_L1 [mkIntCLit words_required] AbsCNop
383 _ -> panic ("CgHeapery.altHeapCheck: unimplemented heap-check, live regs = " ++ showSDoc (sep (map pprMagicId non_void_regs)))
386 -- build up a bitmap of the live pointer registers
388 mkRegLiveness :: [MagicId] -> Word#
389 mkRegLiveness [] = int2Word# 0#
390 mkRegLiveness (VanillaReg rep i : regs) | isFollowableRep rep
391 = ((int2Word# 1#) `shiftL#` (i -# 1#)) `or#` mkRegLiveness regs
392 mkRegLiveness (_ : regs) = mkRegLiveness regs
394 -- The two functions below are only used in a GranSim setup
395 -- Emit macro for simulating a fetch and then reschedule
397 fetchAndReschedule :: [MagicId] -- Live registers
398 -> Bool -- Node reqd?
401 fetchAndReschedule regs node_reqd =
402 if (node `elem` regs || node_reqd)
403 then fetch_code `thenC` reschedule_code
406 liveness_mask = mkRegLiveness regs
407 reschedule_code = absC (CMacroStmt GRAN_RESCHEDULE [
408 mkIntCLit (I# (word2Int# liveness_mask)),
409 mkIntCLit (if node_reqd then 1 else 0)])
411 --HWL: generate GRAN_FETCH macro for GrAnSim
412 -- currently GRAN_FETCH and GRAN_FETCH_AND_RESCHEDULE are miai
413 fetch_code = absC (CMacroStmt GRAN_FETCH [])
416 The @GRAN_YIELD@ macro is taken from JSM's code for Concurrent Haskell. It
417 allows to context-switch at places where @node@ is not alive (it uses the
418 @Continue@ rather than the @EnterNodeCode@ function in the RTS). We emit
419 this kind of macro at the beginning of the following kinds of basic bocks:
421 \item Slow entry code where node is not alive (see @CgClosure.lhs@). Normally
422 we use @fetchAndReschedule@ at a slow entry code.
423 \item Fast entry code (see @CgClosure.lhs@).
424 \item Alternatives in case expressions (@CLabelledCode@ structures), provided
425 that they are not inlined (see @CgCases.lhs@). These alternatives will
426 be turned into separate functions.
430 yield :: [MagicId] -- Live registers
431 -> Bool -- Node reqd?
434 yield regs node_reqd =
435 if opt_GranMacros && node_reqd
439 liveness_mask = mkRegLiveness regs
441 absC (CMacroStmt GRAN_YIELD
442 [mkIntCLit (I# (word2Int# liveness_mask))])
446 hpChkTooBig = panic "Oversize heap check detected. Please try compiling with -O."
449 %************************************************************************
451 \subsection[initClosure]{Initialise a dynamic closure}
453 %************************************************************************
455 @allocDynClosure@ puts the thing in the heap, and modifies the virtual Hp
461 -> CAddrMode -- Cost Centre to stick in the object
462 -> CAddrMode -- Cost Centre to blame for this alloc
463 -- (usually the same; sometimes "OVERHEAD")
465 -> [(CAddrMode, VirtualHeapOffset)] -- Offsets from start of the object
466 -- ie Info ptr has offset zero.
467 -> FCode VirtualHeapOffset -- Returns virt offset of object
469 allocDynClosure closure_info use_cc blame_cc amodes_with_offsets
470 = getVirtAndRealHp `thenFC` \ (virtHp, realHp) ->
472 -- FIND THE OFFSET OF THE INFO-PTR WORD
473 -- virtHp points to last allocated word, ie 1 *before* the
474 -- info-ptr word of new object.
475 let info_offset = virtHp + 1
477 -- do_move IS THE ASSIGNMENT FUNCTION
478 do_move (amode, offset_from_start)
479 = CAssign (CVal (hpRel realHp
480 (info_offset + offset_from_start))
484 -- SAY WHAT WE ARE ABOUT TO DO
485 profCtrC (allocProfilingMsg closure_info)
486 [mkIntCLit (closureGoodStuffSize closure_info),
487 mkIntCLit slop_size] `thenC`
490 absC ( mkAbstractCs (
491 [ cInitHdr closure_info (hpRel realHp info_offset) use_cc ]
492 ++ (map do_move amodes_with_offsets))) `thenC`
494 -- GENERATE CC PROFILING MESSAGES
495 costCentresC SLIT("CCS_ALLOC") [blame_cc, mkIntCLit closure_size]
498 -- BUMP THE VIRTUAL HEAP POINTER
499 setVirtHp (virtHp + closure_size) `thenC`
501 -- RETURN PTR TO START OF OBJECT
504 closure_size = closureSize closure_info
505 slop_size = slopSize closure_info
508 Occasionally we can update a closure in place instead of allocating
509 new space for it. This is the function that does the business, assuming:
511 - node points to the closure to be overwritten
513 - the new closure doesn't contain any pointers if we're
514 using a generational collector.
517 inPlaceAllocDynClosure
519 -> CAddrMode -- Pointer to beginning of closure
520 -> CAddrMode -- Cost Centre to stick in the object
522 -> [(CAddrMode, VirtualHeapOffset)] -- Offsets from start of the object
523 -- ie Info ptr has offset zero.
526 inPlaceAllocDynClosure closure_info head use_cc amodes_with_offsets
527 = let -- do_move IS THE ASSIGNMENT FUNCTION
528 do_move (amode, offset_from_start)
529 = CAssign (CVal (CIndex head (mkIntCLit offset_from_start) WordRep)
534 absC ( mkAbstractCs (
535 [ CInitHdr closure_info head use_cc ]
536 ++ (map do_move amodes_with_offsets)))
538 -- Avoid hanging on to anything in the CC field when we're not profiling.
540 cInitHdr closure_info amode cc
541 | opt_SccProfilingOn = CInitHdr closure_info (CAddr amode) cc
542 | otherwise = CInitHdr closure_info (CAddr amode) (panic "absent cc")