2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4 % $Id: CgHeapery.lhs,v 1.20 2000/01/13 14:33:58 hwloidl 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 SMRep ( fixedHdrSize )
25 import AbsCUtils ( mkAbstractCs, getAmodeRep )
26 import CgUsages ( getVirtAndRealHp, getRealSp, setVirtHp, setRealHp,
29 import ClosureInfo ( closureSize, closureGoodStuffSize,
30 slopSize, allocProfilingMsg, ClosureInfo,
33 import PrimRep ( PrimRep(..), isFollowableRep )
34 import Unique ( Unique )
35 import CmdLineOpts ( opt_SccProfilingOn, opt_GranMacros )
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 getTickyCtrLabel `thenFC` \ ticky_ctr ->
80 ( if all_pointers then -- heap checks are quite easy
81 -- HWL: gran-yield immediately before heap check proper
82 --(if node `elem` regs
83 -- then yield regs True
84 -- else absC AbsCNop ) `thenC`
85 absC (checking_code stk_words hp_words tag_assts
86 free_reg (length regs) ticky_ctr)
88 else -- they are complicated
90 -- save all registers on the stack and adjust the stack pointer.
91 -- ToDo: find the initial all-pointer segment and don't save them.
93 mkTaggedStkAmodes sp addrmode_regs
94 `thenFC` \(new_sp, stk_assts, more_tag_assts) ->
96 -- only let the extra stack assignments affect the stack
97 -- high water mark if we were doing a stack check anyway;
98 -- otherwise we end up generating unnecessary stack checks.
99 -- Careful about knot-tying loops!
100 let real_stk_words = if new_sp - sp > stk_words && stk_words /= 0
105 let adjust_sp = CAssign (CReg Sp) (CAddr (spRel sp new_sp)) in
107 absC (checking_code real_stk_words hp_words
108 (mkAbstractCs [tag_assts, stk_assts, more_tag_assts,
110 (CReg node) 0 ticky_ctr)
114 setRealHp hp_words `thenC`
119 checking_code stk hp assts ret regs ctr
122 if hp == 0 then AbsCNop
123 else profCtrAbsC SLIT("TICK_ALLOC_HEAP")
124 [ mkIntCLit hp, CLbl ctr DataPtrRep ]
128 | node_points = do_checks_np stk hp assts (regs+1)
129 | otherwise = do_checks stk hp assts ret regs
131 -- When node points to the closure for the function:
134 :: Int -- stack headroom
135 -> Int -- heap headroom
136 -> AbstractC -- assignments to perform on failure
137 -> Int -- number of pointer registers live
139 do_checks_np 0 0 _ _ = AbsCNop
140 do_checks_np 0 hp_words tag_assts ptrs =
146 do_checks_np stk_words 0 tag_assts ptrs =
152 do_checks_np stk_words hp_words tag_assts ptrs =
153 CCheck HP_STK_CHK_NP [
160 -- When node doesn't point to the closure (we need an explicit retn addr)
163 :: Int -- stack headroom
164 -> Int -- heap headroom
165 -> AbstractC -- assignments to perform on failure
166 -> CAddrMode -- a register to hold the retn addr.
167 -> Int -- number of pointer registers live
170 do_checks 0 0 _ _ _ = AbsCNop
171 do_checks 0 hp_words tag_assts ret_reg ptrs =
179 do_checks stk_words 0 tag_assts ret_reg ptrs =
187 do_checks stk_words hp_words tag_assts ret_reg ptrs =
197 free_reg = case length regs + 1 of
198 IBOX(x) -> CReg (VanillaReg PtrRep x)
200 all_pointers = all pointer regs
201 pointer (VanillaReg rep _) = isFollowableRep rep
204 addrmode_regs = map CReg regs
206 -- Checking code for thunks is just a special case of fast entry points:
208 thunkChecks :: CLabel -> Bool -> Code -> Code
209 thunkChecks ret node_points code = fastEntryChecks [] [] ret node_points code
212 Heap checks in a case alternative are nice and easy, provided this is
213 a bog-standard algebraic case. We have in our hand:
215 * one return address, on the stack,
216 * one return value, in Node.
218 the canned code for this heap check failure just pushes Node on the
219 stack, saying 'EnterGHC' to return. The scheduler will return by
220 entering the top value on the stack, which in turn will return through
221 the return address, getting us back to where we were. This is
222 therefore only valid if the return value is *lifted* (just being
223 boxed isn't good enough). Only a PtrRep will do.
225 For primitive returns, we have an unlifted value in some register
226 (either R1 or FloatReg1 or DblReg1). This means using specialised
227 heap-check code for these cases.
229 For unboxed tuple returns, there are an arbitrary number of possibly
230 unboxed return values, some of which will be in registers, and the
231 others will be on the stack, with gaps left for tagging the unboxed
232 objects. If a heap check is required, we need to fill in these tags.
234 The code below will cover all cases for the x86 architecture (where R1
235 is the only VanillaReg ever used). For other architectures, we'll
236 have to do something about saving and restoring the other registers.
240 :: Bool -- is an algebraic alternative
241 -> [MagicId] -- live registers
242 -> [(VirtualSpOffset,Int)] -- stack slots to tag
244 -> Maybe Unique -- uniq of ret address (possibly)
248 -- unboxed tuple alternatives and let-no-escapes (the two most annoying
249 -- constructs to generate code for!):
251 altHeapCheck is_fun regs tags fail_code (Just ret_addr) code
252 = mkTagAssts tags `thenFC` \tag_assts1 ->
253 let tag_assts = mkAbstractCs [fail_code, tag_assts1]
255 initHeapUsage (\ hHw -> do_heap_chk hHw tag_assts `thenC` code)
257 do_heap_chk words_required tag_assts
258 = getTickyCtrLabel `thenFC` \ ctr ->
259 absC ( if words_required == 0
262 [ checking_code tag_assts,
263 profCtrAbsC SLIT("TICK_ALLOC_HEAP")
264 [ mkIntCLit words_required, CLbl ctr DataPtrRep ]
267 setRealHp words_required
270 non_void_regs = filter (/= VoidReg) regs
272 checking_code tag_assts =
273 case non_void_regs of
275 {- no: there might be stuff on top of the retn. addr. on the stack.
278 [mkIntCLit words_required]
281 -- this will cover all cases for x86
282 [VanillaReg rep ILIT(1)]
284 | isFollowableRep rep ->
286 [mkIntCLit words_required, mkIntCLit 1, mkIntCLit 0,
287 CReg (VanillaReg RetRep ILIT(2)),
288 CLbl (mkReturnInfoLabel ret_addr) RetRep]
293 [mkIntCLit words_required, mkIntCLit 0, mkIntCLit 1,
294 CReg (VanillaReg RetRep ILIT(2)),
295 CLbl (mkReturnInfoLabel ret_addr) RetRep]
299 let liveness = mkRegLiveness several_regs
302 [mkIntCLit words_required,
303 mkIntCLit (IBOX(word2Int# liveness)),
304 -- HP_CHK_GEN needs a direct return address,
305 -- not an info table (might be different if
306 -- we're not assembly-mangling/tail-jumping etc.)
307 CLbl (mkReturnPtLabel ret_addr) RetRep]
310 -- normal algebraic and primitive case alternatives:
312 altHeapCheck is_fun regs [] AbsCNop Nothing code
313 = initHeapUsage (\ hHw -> do_heap_chk hHw `thenC` code)
316 do_heap_chk :: HeapOffset -> Code
317 do_heap_chk words_required
318 = getTickyCtrLabel `thenFC` \ ctr ->
319 absC ( if words_required == 0
323 profCtrAbsC SLIT("TICK_ALLOC_HEAP")
324 [ mkIntCLit words_required, CLbl ctr DataPtrRep ]
327 setRealHp words_required
330 non_void_regs = filter (/= VoidReg) regs
333 case non_void_regs of
335 -- No regs live: probably a Void return
337 CCheck HP_CHK_NOREGS [mkIntCLit words_required] AbsCNop
339 -- The SEQ case (polymophic/function typed case branch)
340 -- We need this case because the closure in Node won't return
341 -- directly when we enter it (it could be a function), so the
342 -- heap check code needs to push a seq frame on top of the stack.
343 [VanillaReg rep ILIT(1)]
347 [mkIntCLit words_required, mkIntCLit 1{-regs live-}]
350 -- R1 is lifted (the common case)
351 [VanillaReg rep ILIT(1)]
354 [mkIntCLit words_required, mkIntCLit 1{-regs live-}]
357 -- R1 is boxed, but unlifted
358 | isFollowableRep rep ->
359 CCheck HP_CHK_UNPT_R1 [mkIntCLit words_required] AbsCNop
363 CCheck HP_CHK_UNBX_R1 [mkIntCLit words_required] AbsCNop
366 [FloatReg ILIT(1)] ->
367 CCheck HP_CHK_F1 [mkIntCLit words_required] AbsCNop
370 [DoubleReg ILIT(1)] ->
371 CCheck HP_CHK_D1 [mkIntCLit words_required] AbsCNop
374 [LongReg _ ILIT(1)] ->
375 CCheck HP_CHK_L1 [mkIntCLit words_required] AbsCNop
378 _ -> panic ("CgHeapery.altHeapCheck: unimplemented heap-check, live regs = " ++ showSDoc (sep (map pprMagicId non_void_regs)))
381 -- build up a bitmap of the live pointer registers
383 mkRegLiveness :: [MagicId] -> Word#
384 mkRegLiveness [] = int2Word# 0#
385 mkRegLiveness (VanillaReg rep i : regs) | isFollowableRep rep
386 = ((int2Word# 1#) `shiftL#` (i -# 1#)) `or#` mkRegLiveness regs
387 mkRegLiveness (_ : regs) = mkRegLiveness regs
389 -- The two functions below are only used in a GranSim setup
390 -- Emit macro for simulating a fetch and then reschedule
392 fetchAndReschedule :: [MagicId] -- Live registers
393 -> Bool -- Node reqd?
396 fetchAndReschedule regs node_reqd =
397 if (node `elem` regs || node_reqd)
398 then fetch_code `thenC` reschedule_code
401 all_regs = if node_reqd then node:regs else regs
402 liveness_mask = mkRegLiveness regs
403 reschedule_code = absC (CMacroStmt GRAN_RESCHEDULE [
404 mkIntCLit (IBOX(word2Int# liveness_mask)),
405 mkIntCLit (if node_reqd then 1 else 0)])
407 --HWL: generate GRAN_FETCH macro for GrAnSim
408 -- currently GRAN_FETCH and GRAN_FETCH_AND_RESCHEDULE are miai
409 fetch_code = absC (CMacroStmt GRAN_FETCH [])
412 The @GRAN_YIELD@ macro is taken from JSM's code for Concurrent Haskell. It
413 allows to context-switch at places where @node@ is not alive (it uses the
414 @Continue@ rather than the @EnterNodeCode@ function in the RTS). We emit
415 this kind of macro at the beginning of the following kinds of basic bocks:
417 \item Slow entry code where node is not alive (see @CgClosure.lhs@). Normally
418 we use @fetchAndReschedule@ at a slow entry code.
419 \item Fast entry code (see @CgClosure.lhs@).
420 \item Alternatives in case expressions (@CLabelledCode@ structures), provided
421 that they are not inlined (see @CgCases.lhs@). These alternatives will
422 be turned into separate functions.
426 yield :: [MagicId] -- Live registers
427 -> Bool -- Node reqd?
430 yield regs node_reqd =
431 if opt_GranMacros && node_reqd
435 -- all_regs = if node_reqd then node:regs else regs
436 liveness_mask = mkRegLiveness regs
438 absC (CMacroStmt GRAN_YIELD
439 [mkIntCLit (IBOX(word2Int# liveness_mask))])
442 %************************************************************************
444 \subsection[initClosure]{Initialise a dynamic closure}
446 %************************************************************************
448 @allocDynClosure@ puts the thing in the heap, and modifies the virtual Hp
454 -> CAddrMode -- Cost Centre to stick in the object
455 -> CAddrMode -- Cost Centre to blame for this alloc
456 -- (usually the same; sometimes "OVERHEAD")
458 -> [(CAddrMode, VirtualHeapOffset)] -- Offsets from start of the object
459 -- ie Info ptr has offset zero.
460 -> FCode VirtualHeapOffset -- Returns virt offset of object
462 allocDynClosure closure_info use_cc blame_cc amodes_with_offsets
463 = getVirtAndRealHp `thenFC` \ (virtHp, realHp) ->
465 -- FIND THE OFFSET OF THE INFO-PTR WORD
466 -- virtHp points to last allocated word, ie 1 *before* the
467 -- info-ptr word of new object.
468 let info_offset = virtHp + 1
470 -- do_move IS THE ASSIGNMENT FUNCTION
471 do_move (amode, offset_from_start)
472 = CAssign (CVal (hpRel realHp
473 (info_offset + offset_from_start))
477 -- SAY WHAT WE ARE ABOUT TO DO
478 profCtrC (allocProfilingMsg closure_info)
479 [mkIntCLit (closureGoodStuffSize closure_info),
480 mkIntCLit slop_size] `thenC`
483 absC ( mkAbstractCs (
484 [ cInitHdr closure_info (hpRel realHp info_offset) use_cc ]
485 ++ (map do_move amodes_with_offsets))) `thenC`
487 -- GENERATE CC PROFILING MESSAGES
488 costCentresC SLIT("CCS_ALLOC") [blame_cc, mkIntCLit closure_size]
491 -- BUMP THE VIRTUAL HEAP POINTER
492 setVirtHp (virtHp + closure_size) `thenC`
494 -- RETURN PTR TO START OF OBJECT
497 closure_size = closureSize closure_info
498 slop_size = slopSize closure_info
501 Occasionally we can update a closure in place instead of allocating
502 new space for it. This is the function that does the business, assuming:
504 - node points to the closure to be overwritten
506 - the new closure doesn't contain any pointers if we're
507 using a generational collector.
510 inPlaceAllocDynClosure
512 -> CAddrMode -- Pointer to beginning of closure
513 -> CAddrMode -- Cost Centre to stick in the object
515 -> [(CAddrMode, VirtualHeapOffset)] -- Offsets from start of the object
516 -- ie Info ptr has offset zero.
519 inPlaceAllocDynClosure closure_info head use_cc amodes_with_offsets
520 = let -- do_move IS THE ASSIGNMENT FUNCTION
521 do_move (amode, offset_from_start)
522 = CAssign (CVal (CIndex head (mkIntCLit offset_from_start) WordRep)
527 absC ( mkAbstractCs (
528 [ CInitHdr closure_info head use_cc ]
529 ++ (map do_move amodes_with_offsets)))
531 -- Avoid hanging on to anything in the CC field when we're not profiling.
533 cInitHdr closure_info amode cc
534 | opt_SccProfilingOn = CInitHdr closure_info (CAddr amode) cc
535 | otherwise = CInitHdr closure_info (CAddr amode) (panic "absent cc")