2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4 % $Id: CgHeapery.lhs,v 1.33 2002/09/04 10:00:46 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
31 import PrimRep ( PrimRep(..), isFollowableRep )
32 import Unique ( Unique )
33 import CmdLineOpts ( opt_GranMacros )
37 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 (\ hHw ->
77 getTickyCtrLabel `thenFC` \ ticky_ctr ->
79 ( if all_pointers then -- heap checks are quite easy
80 -- HWL: gran-yield immediately before heap check proper
81 --(if node `elem` regs
82 -- then yield regs True
83 -- else absC AbsCNop ) `thenC`
84 absC (checking_code stk_words hHw tag_assts
85 free_reg (length regs) ticky_ctr)
87 else -- they are complicated
89 -- save all registers on the stack and adjust the stack pointer.
90 -- ToDo: find the initial all-pointer segment and don't save them.
92 mkTaggedStkAmodes sp addrmode_regs
93 `thenFC` \(new_sp, stk_assts, more_tag_assts) ->
95 -- only let the extra stack assignments affect the stack
96 -- high water mark if we were doing a stack check anyway;
97 -- otherwise we end up generating unnecessary stack checks.
98 -- Careful about knot-tying loops!
99 let real_stk_words = if new_sp - sp > stk_words && stk_words /= 0
104 let adjust_sp = CAssign (CReg Sp) (CAddr (spRel sp new_sp)) in
106 absC (checking_code real_stk_words hHw
107 (mkAbstractCs [tag_assts, stk_assts, more_tag_assts,
109 (CReg node) 0 ticky_ctr)
113 setRealHp hHw `thenC`
118 checking_code stk hp assts ret regs ctr
121 if hp == 0 then AbsCNop
122 else profCtrAbsC FSLIT("TICK_ALLOC_HEAP")
123 [ mkIntCLit hp, CLbl ctr DataPtrRep ]
127 | node_points = do_checks_np stk hp assts (regs+1)
128 | otherwise = do_checks stk hp assts ret regs
130 -- When node points to the closure for the function:
133 :: Int -- stack headroom
134 -> Int -- heap headroom
135 -> AbstractC -- assignments to perform on failure
136 -> Int -- number of pointer registers live
138 do_checks_np 0 0 _ _ = AbsCNop
139 do_checks_np 0 hp_words tag_assts ptrs =
145 do_checks_np stk_words 0 tag_assts ptrs =
151 do_checks_np stk_words hp_words tag_assts ptrs =
152 CCheck HP_STK_CHK_NP [
159 -- When node doesn't point to the closure (we need an explicit retn addr)
162 :: Int -- stack headroom
163 -> Int -- heap headroom
164 -> AbstractC -- assignments to perform on failure
165 -> CAddrMode -- a register to hold the retn addr.
166 -> Int -- number of pointer registers live
169 do_checks 0 0 _ _ _ = AbsCNop
170 do_checks 0 hp_words tag_assts ret_reg ptrs =
178 do_checks stk_words 0 tag_assts ret_reg ptrs =
186 do_checks stk_words hp_words tag_assts ret_reg ptrs =
196 free_reg = case length regs + 1 of
197 I# x -> CReg (VanillaReg PtrRep x)
199 all_pointers = all pointer regs
200 pointer (VanillaReg rep _) = isFollowableRep rep
203 addrmode_regs = map CReg regs
205 -- Checking code for thunks is just a special case of fast entry points:
207 thunkChecks :: CLabel -> Bool -> Code -> Code
208 thunkChecks ret node_points code = fastEntryChecks [] [] ret node_points code
211 Heap checks in a case alternative are nice and easy, provided this is
212 a bog-standard algebraic case. We have in our hand:
214 * one return address, on the stack,
215 * one return value, in Node.
217 the canned code for this heap check failure just pushes Node on the
218 stack, saying 'EnterGHC' to return. The scheduler will return by
219 entering the top value on the stack, which in turn will return through
220 the return address, getting us back to where we were. This is
221 therefore only valid if the return value is *lifted* (just being
222 boxed isn't good enough). Only a PtrRep will do.
224 For primitive returns, we have an unlifted value in some register
225 (either R1 or FloatReg1 or DblReg1). This means using specialised
226 heap-check code for these cases.
228 For unboxed tuple returns, there are an arbitrary number of possibly
229 unboxed return values, some of which will be in registers, and the
230 others will be on the stack, with gaps left for tagging the unboxed
231 objects. If a heap check is required, we need to fill in these tags.
233 The code below will cover all cases for the x86 architecture (where R1
234 is the only VanillaReg ever used). For other architectures, we'll
235 have to do something about saving and restoring the other registers.
239 :: Bool -- is a polymorphic case alt
240 -> Bool -- is an primitive case alt
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_poly is_prim 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 FSLIT("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
284 | isFollowableRep rep ->
286 [mkIntCLit words_required, mkIntCLit 1, mkIntCLit 0,
287 CReg (VanillaReg RetRep 2#),
288 CLbl (mkReturnInfoLabel ret_addr) RetRep]
293 [mkIntCLit words_required, mkIntCLit 0, mkIntCLit 1,
294 CReg (VanillaReg RetRep 2#),
295 CLbl (mkReturnInfoLabel ret_addr) RetRep]
299 let liveness = mkRegLiveness several_regs
302 [mkIntCLit words_required,
303 mkIntCLit (I# (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_poly is_prim regs [] AbsCNop Nothing code
313 = initHeapUsage (\ hHw -> do_heap_chk hHw `thenC` code)
315 do_heap_chk :: HeapOffset -> Code
316 do_heap_chk words_required
317 = getTickyCtrLabel `thenFC` \ ctr ->
318 absC ( if words_required == 0
322 profCtrAbsC FSLIT("TICK_ALLOC_HEAP")
323 [ mkIntCLit words_required, CLbl ctr DataPtrRep ]
326 setRealHp words_required
329 non_void_regs = filter (/= VoidReg) regs
332 case non_void_regs of
334 -- No regs live: probably a Void return
336 CCheck HP_CHK_NOREGS [mkIntCLit words_required] AbsCNop
338 -- R1 is boxed, but unlifted: DO NOT enter R1 when we return.
340 -- We also lump the polymorphic case in here, because we don't
341 -- want to enter R1 if it is a function, and we're guarnateed
342 -- that the return point has a direct return.
344 | isFollowableRep rep && (is_poly || is_prim) ->
345 CCheck HP_CHK_UNPT_R1 [mkIntCLit words_required] AbsCNop
347 -- R1 is lifted (the common case)
348 | isFollowableRep rep ->
350 [mkIntCLit words_required, mkIntCLit 1{-regs live-}]
355 CCheck HP_CHK_UNBX_R1 [mkIntCLit words_required] AbsCNop
359 CCheck HP_CHK_F1 [mkIntCLit words_required] AbsCNop
363 CCheck HP_CHK_D1 [mkIntCLit words_required] AbsCNop
367 CCheck HP_CHK_L1 [mkIntCLit words_required] AbsCNop
370 _ -> panic ("CgHeapery.altHeapCheck: unimplemented heap-check, live regs = " ++ showSDoc (sep (map pprMagicId non_void_regs)))
373 -- build up a bitmap of the live pointer registers
375 #if __GLASGOW_HASKELL__ >= 503
376 shiftL = uncheckedShiftL#
381 mkRegLiveness :: [MagicId] -> Word#
382 mkRegLiveness [] = int2Word# 0#
383 mkRegLiveness (VanillaReg rep i : regs) | isFollowableRep rep
384 = ((int2Word# 1#) `shiftL` (i -# 1#)) `or#` mkRegLiveness regs
385 mkRegLiveness (_ : regs) = mkRegLiveness regs
387 -- The two functions below are only used in a GranSim setup
388 -- Emit macro for simulating a fetch and then reschedule
390 fetchAndReschedule :: [MagicId] -- Live registers
391 -> Bool -- Node reqd?
394 fetchAndReschedule regs node_reqd =
395 if (node `elem` regs || node_reqd)
396 then fetch_code `thenC` reschedule_code
399 liveness_mask = mkRegLiveness regs
400 reschedule_code = absC (CMacroStmt GRAN_RESCHEDULE [
401 mkIntCLit (I# (word2Int# liveness_mask)),
402 mkIntCLit (if node_reqd then 1 else 0)])
404 --HWL: generate GRAN_FETCH macro for GrAnSim
405 -- currently GRAN_FETCH and GRAN_FETCH_AND_RESCHEDULE are miai
406 fetch_code = absC (CMacroStmt GRAN_FETCH [])
409 The @GRAN_YIELD@ macro is taken from JSM's code for Concurrent Haskell. It
410 allows to context-switch at places where @node@ is not alive (it uses the
411 @Continue@ rather than the @EnterNodeCode@ function in the RTS). We emit
412 this kind of macro at the beginning of the following kinds of basic bocks:
414 \item Slow entry code where node is not alive (see @CgClosure.lhs@). Normally
415 we use @fetchAndReschedule@ at a slow entry code.
416 \item Fast entry code (see @CgClosure.lhs@).
417 \item Alternatives in case expressions (@CLabelledCode@ structures), provided
418 that they are not inlined (see @CgCases.lhs@). These alternatives will
419 be turned into separate functions.
423 yield :: [MagicId] -- Live registers
424 -> Bool -- Node reqd?
427 yield regs node_reqd =
428 if opt_GranMacros && node_reqd
432 liveness_mask = mkRegLiveness regs
434 absC (CMacroStmt GRAN_YIELD
435 [mkIntCLit (I# (word2Int# liveness_mask))])
438 %************************************************************************
440 \subsection[initClosure]{Initialise a dynamic closure}
442 %************************************************************************
444 @allocDynClosure@ puts the thing in the heap, and modifies the virtual Hp
450 -> CAddrMode -- Cost Centre to stick in the object
451 -> CAddrMode -- Cost Centre to blame for this alloc
452 -- (usually the same; sometimes "OVERHEAD")
454 -> [(CAddrMode, VirtualHeapOffset)] -- Offsets from start of the object
455 -- ie Info ptr has offset zero.
456 -> FCode VirtualHeapOffset -- Returns virt offset of object
458 allocDynClosure closure_info use_cc blame_cc amodes_with_offsets
459 = getVirtAndRealHp `thenFC` \ (virtHp, realHp) ->
461 -- FIND THE OFFSET OF THE INFO-PTR WORD
462 -- virtHp points to last allocated word, ie 1 *before* the
463 -- info-ptr word of new object.
464 let info_offset = virtHp + 1
466 -- do_move IS THE ASSIGNMENT FUNCTION
467 do_move (amode, offset_from_start)
468 = CAssign (CVal (hpRel realHp
469 (info_offset + offset_from_start))
473 -- SAY WHAT WE ARE ABOUT TO DO
474 profCtrC (allocProfilingMsg closure_info)
475 [mkIntCLit (closureGoodStuffSize closure_info),
476 mkIntCLit slop_size] `thenC`
479 absC ( mkAbstractCs (
480 [ CInitHdr closure_info
481 (CAddr (hpRel realHp info_offset))
482 use_cc closure_size ]
483 ++ (map do_move amodes_with_offsets))) `thenC`
485 -- BUMP THE VIRTUAL HEAP POINTER
486 setVirtHp (virtHp + closure_size) `thenC`
488 -- RETURN PTR TO START OF OBJECT
491 closure_size = closureSize closure_info
492 slop_size = slopSize closure_info
495 Occasionally we can update a closure in place instead of allocating
496 new space for it. This is the function that does the business, assuming:
498 - node points to the closure to be overwritten
500 - the new closure doesn't contain any pointers if we're
501 using a generational collector.
504 inPlaceAllocDynClosure
506 -> CAddrMode -- Pointer to beginning of closure
507 -> CAddrMode -- Cost Centre to stick in the object
509 -> [(CAddrMode, VirtualHeapOffset)] -- Offsets from start of the object
510 -- ie Info ptr has offset zero.
513 inPlaceAllocDynClosure closure_info head use_cc amodes_with_offsets
514 = let -- do_move IS THE ASSIGNMENT FUNCTION
515 do_move (amode, offset_from_start)
516 = CAssign (CVal (CIndex head (mkIntCLit offset_from_start) WordRep)
521 absC ( mkAbstractCs (
522 [ CInitHdr closure_info head use_cc 0{-no alloc-} ]
523 ++ (map do_move amodes_with_offsets)))