2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4 % $Id: CgHeapery.lhs,v 1.23 2000/07/26 14:48:16 simonmar 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,
32 import PrimRep ( PrimRep(..), isFollowableRep )
33 import Unique ( Unique )
34 import CmdLineOpts ( opt_SccProfilingOn, opt_GranMacros )
35 import Constants ( bLOCK_SIZE_W )
40 import PprAbsC ( pprMagicId ) -- tmp
44 %************************************************************************
46 \subsection[CgHeapery-heap-overflow]{Heap overflow checking}
48 %************************************************************************
50 The new code for heapChecks. For GrAnSim the code for doing a heap check
51 and doing a context switch has been separated. Especially, the HEAP_CHK
52 macro only performs a heap check. THREAD_CONTEXT_SWITCH should be used for
53 doing a context switch. GRAN_FETCH_AND_RESCHEDULE must be put at the
54 beginning of every slow entry code in order to simulate the fetching of
55 closures. If fetching is necessary (i.e. current closure is not local) then
56 an automatic context switch is done.
58 -----------------------------------------------------------------------------
59 A heap/stack check at a fast entry point.
64 :: [MagicId] -- Live registers
65 -> [(VirtualSpOffset,Int)] -- stack slots to tag
66 -> CLabel -- return point
67 -> Bool -- node points to closure
71 fastEntryChecks regs tags ret node_points code
72 = mkTagAssts tags `thenFC` \tag_assts ->
73 getFinalStackHW (\ spHw ->
74 getRealSp `thenFC` \ sp ->
75 let stk_words = spHw - sp in
76 initHeapUsage (\ hp_words ->
78 let hHw = if hp_words > bLOCK_SIZE_W then hpChkTooBig else hp_words in
80 getTickyCtrLabel `thenFC` \ ticky_ctr ->
82 ( if all_pointers then -- heap checks are quite easy
83 -- HWL: gran-yield immediately before heap check proper
84 --(if node `elem` regs
85 -- then yield regs True
86 -- else absC AbsCNop ) `thenC`
87 absC (checking_code stk_words hHw tag_assts
88 free_reg (length regs) ticky_ctr)
90 else -- they are complicated
92 -- save all registers on the stack and adjust the stack pointer.
93 -- ToDo: find the initial all-pointer segment and don't save them.
95 mkTaggedStkAmodes sp addrmode_regs
96 `thenFC` \(new_sp, stk_assts, more_tag_assts) ->
98 -- only let the extra stack assignments affect the stack
99 -- high water mark if we were doing a stack check anyway;
100 -- otherwise we end up generating unnecessary stack checks.
101 -- Careful about knot-tying loops!
102 let real_stk_words = if new_sp - sp > stk_words && stk_words /= 0
107 let adjust_sp = CAssign (CReg Sp) (CAddr (spRel sp new_sp)) in
109 absC (checking_code real_stk_words hHw
110 (mkAbstractCs [tag_assts, stk_assts, more_tag_assts,
112 (CReg node) 0 ticky_ctr)
116 setRealHp hp_words `thenC`
121 checking_code stk hp assts ret regs ctr
124 if hp == 0 then AbsCNop
125 else profCtrAbsC SLIT("TICK_ALLOC_HEAP")
126 [ mkIntCLit hp, CLbl ctr DataPtrRep ]
130 | node_points = do_checks_np stk hp assts (regs+1)
131 | otherwise = do_checks stk hp assts ret regs
133 -- When node points to the closure for the function:
136 :: Int -- stack headroom
137 -> Int -- heap headroom
138 -> AbstractC -- assignments to perform on failure
139 -> Int -- number of pointer registers live
141 do_checks_np 0 0 _ _ = AbsCNop
142 do_checks_np 0 hp_words tag_assts ptrs =
148 do_checks_np stk_words 0 tag_assts ptrs =
154 do_checks_np stk_words hp_words tag_assts ptrs =
155 CCheck HP_STK_CHK_NP [
162 -- When node doesn't point to the closure (we need an explicit retn addr)
165 :: Int -- stack headroom
166 -> Int -- heap headroom
167 -> AbstractC -- assignments to perform on failure
168 -> CAddrMode -- a register to hold the retn addr.
169 -> Int -- number of pointer registers live
172 do_checks 0 0 _ _ _ = AbsCNop
173 do_checks 0 hp_words tag_assts ret_reg ptrs =
181 do_checks stk_words 0 tag_assts ret_reg ptrs =
189 do_checks stk_words hp_words tag_assts ret_reg ptrs =
199 free_reg = case length regs + 1 of
200 IBOX(x) -> CReg (VanillaReg PtrRep x)
202 all_pointers = all pointer regs
203 pointer (VanillaReg rep _) = isFollowableRep rep
206 addrmode_regs = map CReg regs
208 -- Checking code for thunks is just a special case of fast entry points:
210 thunkChecks :: CLabel -> Bool -> Code -> Code
211 thunkChecks ret node_points code = fastEntryChecks [] [] ret node_points code
214 Heap checks in a case alternative are nice and easy, provided this is
215 a bog-standard algebraic case. We have in our hand:
217 * one return address, on the stack,
218 * one return value, in Node.
220 the canned code for this heap check failure just pushes Node on the
221 stack, saying 'EnterGHC' to return. The scheduler will return by
222 entering the top value on the stack, which in turn will return through
223 the return address, getting us back to where we were. This is
224 therefore only valid if the return value is *lifted* (just being
225 boxed isn't good enough). Only a PtrRep will do.
227 For primitive returns, we have an unlifted value in some register
228 (either R1 or FloatReg1 or DblReg1). This means using specialised
229 heap-check code for these cases.
231 For unboxed tuple returns, there are an arbitrary number of possibly
232 unboxed return values, some of which will be in registers, and the
233 others will be on the stack, with gaps left for tagging the unboxed
234 objects. If a heap check is required, we need to fill in these tags.
236 The code below will cover all cases for the x86 architecture (where R1
237 is the only VanillaReg ever used). For other architectures, we'll
238 have to do something about saving and restoring the other registers.
242 :: Bool -- is an algebraic alternative
243 -> [MagicId] -- live registers
244 -> [(VirtualSpOffset,Int)] -- stack slots to tag
246 -> Maybe Unique -- uniq of ret address (possibly)
250 -- unboxed tuple alternatives and let-no-escapes (the two most annoying
251 -- constructs to generate code for!):
253 altHeapCheck is_fun regs tags fail_code (Just ret_addr) code
254 = mkTagAssts tags `thenFC` \tag_assts1 ->
255 let tag_assts = mkAbstractCs [fail_code, tag_assts1]
257 initHeapUsage (\ hHw ->
258 do_heap_chk (if hHw > bLOCK_SIZE_W then hpChkTooBig else hHw) tag_assts
261 do_heap_chk words_required tag_assts
262 = getTickyCtrLabel `thenFC` \ ctr ->
263 absC ( if words_required == 0
266 [ checking_code tag_assts,
267 profCtrAbsC SLIT("TICK_ALLOC_HEAP")
268 [ mkIntCLit words_required, CLbl ctr DataPtrRep ]
271 setRealHp words_required
274 non_void_regs = filter (/= VoidReg) regs
276 checking_code tag_assts =
277 case non_void_regs of
279 {- no: there might be stuff on top of the retn. addr. on the stack.
282 [mkIntCLit words_required]
285 -- this will cover all cases for x86
286 [VanillaReg rep ILIT(1)]
288 | isFollowableRep rep ->
290 [mkIntCLit words_required, mkIntCLit 1, mkIntCLit 0,
291 CReg (VanillaReg RetRep ILIT(2)),
292 CLbl (mkReturnInfoLabel ret_addr) RetRep]
297 [mkIntCLit words_required, mkIntCLit 0, mkIntCLit 1,
298 CReg (VanillaReg RetRep ILIT(2)),
299 CLbl (mkReturnInfoLabel ret_addr) RetRep]
303 let liveness = mkRegLiveness several_regs
306 [mkIntCLit words_required,
307 mkIntCLit (IBOX(word2Int# liveness)),
308 -- HP_CHK_GEN needs a direct return address,
309 -- not an info table (might be different if
310 -- we're not assembly-mangling/tail-jumping etc.)
311 CLbl (mkReturnPtLabel ret_addr) RetRep]
314 -- normal algebraic and primitive case alternatives:
316 altHeapCheck is_fun regs [] AbsCNop Nothing code
317 = initHeapUsage (\ hHw ->
318 do_heap_chk (if hHw > bLOCK_SIZE_W then hpChkTooBig else hHw)
322 do_heap_chk :: HeapOffset -> Code
323 do_heap_chk words_required
324 = getTickyCtrLabel `thenFC` \ ctr ->
325 absC ( if words_required == 0
329 profCtrAbsC SLIT("TICK_ALLOC_HEAP")
330 [ mkIntCLit words_required, CLbl ctr DataPtrRep ]
333 setRealHp words_required
336 non_void_regs = filter (/= VoidReg) regs
339 case non_void_regs of
341 -- No regs live: probably a Void return
343 CCheck HP_CHK_NOREGS [mkIntCLit words_required] AbsCNop
345 -- The SEQ case (polymophic/function typed case branch)
346 -- We need this case because the closure in Node won't return
347 -- directly when we enter it (it could be a function), so the
348 -- heap check code needs to push a seq frame on top of the stack.
349 [VanillaReg rep ILIT(1)]
353 [mkIntCLit words_required, mkIntCLit 1{-regs live-}]
356 -- R1 is lifted (the common case)
357 [VanillaReg rep ILIT(1)]
360 [mkIntCLit words_required, mkIntCLit 1{-regs live-}]
363 -- R1 is boxed, but unlifted
364 | isFollowableRep rep ->
365 CCheck HP_CHK_UNPT_R1 [mkIntCLit words_required] AbsCNop
369 CCheck HP_CHK_UNBX_R1 [mkIntCLit words_required] AbsCNop
372 [FloatReg ILIT(1)] ->
373 CCheck HP_CHK_F1 [mkIntCLit words_required] AbsCNop
376 [DoubleReg ILIT(1)] ->
377 CCheck HP_CHK_D1 [mkIntCLit words_required] AbsCNop
380 [LongReg _ ILIT(1)] ->
381 CCheck HP_CHK_L1 [mkIntCLit words_required] AbsCNop
384 _ -> panic ("CgHeapery.altHeapCheck: unimplemented heap-check, live regs = " ++ showSDoc (sep (map pprMagicId non_void_regs)))
387 -- build up a bitmap of the live pointer registers
389 mkRegLiveness :: [MagicId] -> Word#
390 mkRegLiveness [] = int2Word# 0#
391 mkRegLiveness (VanillaReg rep i : regs) | isFollowableRep rep
392 = ((int2Word# 1#) `shiftL#` (i -# 1#)) `or#` mkRegLiveness regs
393 mkRegLiveness (_ : regs) = mkRegLiveness regs
395 -- The two functions below are only used in a GranSim setup
396 -- Emit macro for simulating a fetch and then reschedule
398 fetchAndReschedule :: [MagicId] -- Live registers
399 -> Bool -- Node reqd?
402 fetchAndReschedule regs node_reqd =
403 if (node `elem` regs || node_reqd)
404 then fetch_code `thenC` reschedule_code
407 liveness_mask = mkRegLiveness regs
408 reschedule_code = absC (CMacroStmt GRAN_RESCHEDULE [
409 mkIntCLit (IBOX(word2Int# liveness_mask)),
410 mkIntCLit (if node_reqd then 1 else 0)])
412 --HWL: generate GRAN_FETCH macro for GrAnSim
413 -- currently GRAN_FETCH and GRAN_FETCH_AND_RESCHEDULE are miai
414 fetch_code = absC (CMacroStmt GRAN_FETCH [])
417 The @GRAN_YIELD@ macro is taken from JSM's code for Concurrent Haskell. It
418 allows to context-switch at places where @node@ is not alive (it uses the
419 @Continue@ rather than the @EnterNodeCode@ function in the RTS). We emit
420 this kind of macro at the beginning of the following kinds of basic bocks:
422 \item Slow entry code where node is not alive (see @CgClosure.lhs@). Normally
423 we use @fetchAndReschedule@ at a slow entry code.
424 \item Fast entry code (see @CgClosure.lhs@).
425 \item Alternatives in case expressions (@CLabelledCode@ structures), provided
426 that they are not inlined (see @CgCases.lhs@). These alternatives will
427 be turned into separate functions.
431 yield :: [MagicId] -- Live registers
432 -> Bool -- Node reqd?
435 yield regs node_reqd =
436 if opt_GranMacros && node_reqd
440 liveness_mask = mkRegLiveness regs
442 absC (CMacroStmt GRAN_YIELD
443 [mkIntCLit (IBOX(word2Int# liveness_mask))])
447 hpChkTooBig = panic "Oversize heap check detected. Please try compiling with -O."
450 %************************************************************************
452 \subsection[initClosure]{Initialise a dynamic closure}
454 %************************************************************************
456 @allocDynClosure@ puts the thing in the heap, and modifies the virtual Hp
462 -> CAddrMode -- Cost Centre to stick in the object
463 -> CAddrMode -- Cost Centre to blame for this alloc
464 -- (usually the same; sometimes "OVERHEAD")
466 -> [(CAddrMode, VirtualHeapOffset)] -- Offsets from start of the object
467 -- ie Info ptr has offset zero.
468 -> FCode VirtualHeapOffset -- Returns virt offset of object
470 allocDynClosure closure_info use_cc blame_cc amodes_with_offsets
471 = getVirtAndRealHp `thenFC` \ (virtHp, realHp) ->
473 -- FIND THE OFFSET OF THE INFO-PTR WORD
474 -- virtHp points to last allocated word, ie 1 *before* the
475 -- info-ptr word of new object.
476 let info_offset = virtHp + 1
478 -- do_move IS THE ASSIGNMENT FUNCTION
479 do_move (amode, offset_from_start)
480 = CAssign (CVal (hpRel realHp
481 (info_offset + offset_from_start))
485 -- SAY WHAT WE ARE ABOUT TO DO
486 profCtrC (allocProfilingMsg closure_info)
487 [mkIntCLit (closureGoodStuffSize closure_info),
488 mkIntCLit slop_size] `thenC`
491 absC ( mkAbstractCs (
492 [ cInitHdr closure_info (hpRel realHp info_offset) use_cc ]
493 ++ (map do_move amodes_with_offsets))) `thenC`
495 -- GENERATE CC PROFILING MESSAGES
496 costCentresC SLIT("CCS_ALLOC") [blame_cc, mkIntCLit closure_size]
499 -- BUMP THE VIRTUAL HEAP POINTER
500 setVirtHp (virtHp + closure_size) `thenC`
502 -- RETURN PTR TO START OF OBJECT
505 closure_size = closureSize closure_info
506 slop_size = slopSize closure_info
509 Occasionally we can update a closure in place instead of allocating
510 new space for it. This is the function that does the business, assuming:
512 - node points to the closure to be overwritten
514 - the new closure doesn't contain any pointers if we're
515 using a generational collector.
518 inPlaceAllocDynClosure
520 -> CAddrMode -- Pointer to beginning of closure
521 -> CAddrMode -- Cost Centre to stick in the object
523 -> [(CAddrMode, VirtualHeapOffset)] -- Offsets from start of the object
524 -- ie Info ptr has offset zero.
527 inPlaceAllocDynClosure closure_info head use_cc amodes_with_offsets
528 = let -- do_move IS THE ASSIGNMENT FUNCTION
529 do_move (amode, offset_from_start)
530 = CAssign (CVal (CIndex head (mkIntCLit offset_from_start) WordRep)
535 absC ( mkAbstractCs (
536 [ CInitHdr closure_info head use_cc ]
537 ++ (map do_move amodes_with_offsets)))
539 -- Avoid hanging on to anything in the CC field when we're not profiling.
541 cInitHdr closure_info amode cc
542 | opt_SccProfilingOn = CInitHdr closure_info (CAddr amode) cc
543 | otherwise = CInitHdr closure_info (CAddr amode) (panic "absent cc")