2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4 % $Id: CgHeapery.lhs,v 1.28 2001/11/23 11:58:00 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_SccProfilingOn, opt_GranMacros )
38 import PprAbsC ( pprMagicId ) -- tmp
42 %************************************************************************
44 \subsection[CgHeapery-heap-overflow]{Heap overflow checking}
46 %************************************************************************
48 The new code for heapChecks. For GrAnSim the code for doing a heap check
49 and doing a context switch has been separated. Especially, the HEAP_CHK
50 macro only performs a heap check. THREAD_CONTEXT_SWITCH should be used for
51 doing a context switch. GRAN_FETCH_AND_RESCHEDULE must be put at the
52 beginning of every slow entry code in order to simulate the fetching of
53 closures. If fetching is necessary (i.e. current closure is not local) then
54 an automatic context switch is done.
56 -----------------------------------------------------------------------------
57 A heap/stack check at a fast entry point.
62 :: [MagicId] -- Live registers
63 -> [(VirtualSpOffset,Int)] -- stack slots to tag
64 -> CLabel -- return point
65 -> Bool -- node points to closure
69 fastEntryChecks regs tags ret node_points code
70 = mkTagAssts tags `thenFC` \tag_assts ->
71 getFinalStackHW (\ spHw ->
72 getRealSp `thenFC` \ sp ->
73 let stk_words = spHw - sp in
74 initHeapUsage (\ hHw ->
76 getTickyCtrLabel `thenFC` \ ticky_ctr ->
78 ( if all_pointers then -- heap checks are quite easy
79 -- HWL: gran-yield immediately before heap check proper
80 --(if node `elem` regs
81 -- then yield regs True
82 -- else absC AbsCNop ) `thenC`
83 absC (checking_code stk_words hHw tag_assts
84 free_reg (length regs) ticky_ctr)
86 else -- they are complicated
88 -- save all registers on the stack and adjust the stack pointer.
89 -- ToDo: find the initial all-pointer segment and don't save them.
91 mkTaggedStkAmodes sp addrmode_regs
92 `thenFC` \(new_sp, stk_assts, more_tag_assts) ->
94 -- only let the extra stack assignments affect the stack
95 -- high water mark if we were doing a stack check anyway;
96 -- otherwise we end up generating unnecessary stack checks.
97 -- Careful about knot-tying loops!
98 let real_stk_words = if new_sp - sp > stk_words && stk_words /= 0
103 let adjust_sp = CAssign (CReg Sp) (CAddr (spRel sp new_sp)) in
105 absC (checking_code real_stk_words hHw
106 (mkAbstractCs [tag_assts, stk_assts, more_tag_assts,
108 (CReg node) 0 ticky_ctr)
112 setRealHp hHw `thenC`
117 checking_code stk hp assts ret regs ctr
120 if hp == 0 then AbsCNop
121 else profCtrAbsC SLIT("TICK_ALLOC_HEAP")
122 [ mkIntCLit hp, CLbl ctr DataPtrRep ]
126 | node_points = do_checks_np stk hp assts (regs+1)
127 | otherwise = do_checks stk hp assts ret regs
129 -- When node points to the closure for the function:
132 :: Int -- stack headroom
133 -> Int -- heap headroom
134 -> AbstractC -- assignments to perform on failure
135 -> Int -- number of pointer registers live
137 do_checks_np 0 0 _ _ = AbsCNop
138 do_checks_np 0 hp_words tag_assts ptrs =
144 do_checks_np stk_words 0 tag_assts ptrs =
150 do_checks_np stk_words hp_words tag_assts ptrs =
151 CCheck HP_STK_CHK_NP [
158 -- When node doesn't point to the closure (we need an explicit retn addr)
161 :: Int -- stack headroom
162 -> Int -- heap headroom
163 -> AbstractC -- assignments to perform on failure
164 -> CAddrMode -- a register to hold the retn addr.
165 -> Int -- number of pointer registers live
168 do_checks 0 0 _ _ _ = AbsCNop
169 do_checks 0 hp_words tag_assts ret_reg ptrs =
177 do_checks stk_words 0 tag_assts ret_reg ptrs =
185 do_checks stk_words hp_words tag_assts ret_reg ptrs =
195 free_reg = case length regs + 1 of
196 I# x -> CReg (VanillaReg PtrRep x)
198 all_pointers = all pointer regs
199 pointer (VanillaReg rep _) = isFollowableRep rep
202 addrmode_regs = map CReg regs
204 -- Checking code for thunks is just a special case of fast entry points:
206 thunkChecks :: CLabel -> Bool -> Code -> Code
207 thunkChecks ret node_points code = fastEntryChecks [] [] ret node_points code
210 Heap checks in a case alternative are nice and easy, provided this is
211 a bog-standard algebraic case. We have in our hand:
213 * one return address, on the stack,
214 * one return value, in Node.
216 the canned code for this heap check failure just pushes Node on the
217 stack, saying 'EnterGHC' to return. The scheduler will return by
218 entering the top value on the stack, which in turn will return through
219 the return address, getting us back to where we were. This is
220 therefore only valid if the return value is *lifted* (just being
221 boxed isn't good enough). Only a PtrRep will do.
223 For primitive returns, we have an unlifted value in some register
224 (either R1 or FloatReg1 or DblReg1). This means using specialised
225 heap-check code for these cases.
227 For unboxed tuple returns, there are an arbitrary number of possibly
228 unboxed return values, some of which will be in registers, and the
229 others will be on the stack, with gaps left for tagging the unboxed
230 objects. If a heap check is required, we need to fill in these tags.
232 The code below will cover all cases for the x86 architecture (where R1
233 is the only VanillaReg ever used). For other architectures, we'll
234 have to do something about saving and restoring the other registers.
238 :: Bool -- is an algebraic alternative
239 -> [MagicId] -- live registers
240 -> [(VirtualSpOffset,Int)] -- stack slots to tag
242 -> Maybe Unique -- uniq of ret address (possibly)
246 -- unboxed tuple alternatives and let-no-escapes (the two most annoying
247 -- constructs to generate code for!):
249 altHeapCheck is_fun regs tags fail_code (Just ret_addr) code
250 = mkTagAssts tags `thenFC` \tag_assts1 ->
251 let tag_assts = mkAbstractCs [fail_code, tag_assts1]
253 initHeapUsage (\ hHw -> do_heap_chk hHw tag_assts `thenC` code)
255 do_heap_chk words_required tag_assts
256 = getTickyCtrLabel `thenFC` \ ctr ->
257 absC ( if words_required == 0
260 [ checking_code tag_assts,
261 profCtrAbsC SLIT("TICK_ALLOC_HEAP")
262 [ mkIntCLit words_required, CLbl ctr DataPtrRep ]
265 setRealHp words_required
268 non_void_regs = filter (/= VoidReg) regs
270 checking_code tag_assts =
271 case non_void_regs of
273 {- no: there might be stuff on top of the retn. addr. on the stack.
276 [mkIntCLit words_required]
279 -- this will cover all cases for x86
282 | isFollowableRep rep ->
284 [mkIntCLit words_required, mkIntCLit 1, mkIntCLit 0,
285 CReg (VanillaReg RetRep 2#),
286 CLbl (mkReturnInfoLabel ret_addr) RetRep]
291 [mkIntCLit words_required, mkIntCLit 0, mkIntCLit 1,
292 CReg (VanillaReg RetRep 2#),
293 CLbl (mkReturnInfoLabel ret_addr) RetRep]
297 let liveness = mkRegLiveness several_regs
300 [mkIntCLit words_required,
301 mkIntCLit (I# (word2Int# liveness)),
302 -- HP_CHK_GEN needs a direct return address,
303 -- not an info table (might be different if
304 -- we're not assembly-mangling/tail-jumping etc.)
305 CLbl (mkReturnPtLabel ret_addr) RetRep]
308 -- normal algebraic and primitive case alternatives:
310 altHeapCheck is_fun regs [] AbsCNop Nothing code
311 = initHeapUsage (\ hHw -> do_heap_chk hHw `thenC` code)
313 do_heap_chk :: HeapOffset -> Code
314 do_heap_chk words_required
315 = getTickyCtrLabel `thenFC` \ ctr ->
316 absC ( if words_required == 0
320 profCtrAbsC SLIT("TICK_ALLOC_HEAP")
321 [ mkIntCLit words_required, CLbl ctr DataPtrRep ]
324 setRealHp words_required
327 non_void_regs = filter (/= VoidReg) regs
330 case non_void_regs of
332 -- No regs live: probably a Void return
334 CCheck HP_CHK_NOREGS [mkIntCLit words_required] AbsCNop
336 -- The SEQ case (polymophic/function typed case branch)
337 -- We need this case because the closure in Node won't return
338 -- directly when we enter it (it could be a function), so the
339 -- heap check code needs to push a seq frame on top of the stack.
344 [mkIntCLit words_required, mkIntCLit 1{-regs live-}]
347 -- R1 is lifted (the common case)
351 [mkIntCLit words_required, mkIntCLit 1{-regs live-}]
354 -- R1 is boxed, but unlifted
355 | isFollowableRep rep ->
356 CCheck HP_CHK_UNPT_R1 [mkIntCLit words_required] AbsCNop
360 CCheck HP_CHK_UNBX_R1 [mkIntCLit words_required] AbsCNop
364 CCheck HP_CHK_F1 [mkIntCLit words_required] AbsCNop
368 CCheck HP_CHK_D1 [mkIntCLit words_required] AbsCNop
372 CCheck HP_CHK_L1 [mkIntCLit words_required] AbsCNop
375 _ -> panic ("CgHeapery.altHeapCheck: unimplemented heap-check, live regs = " ++ showSDoc (sep (map pprMagicId non_void_regs)))
378 -- build up a bitmap of the live pointer registers
380 mkRegLiveness :: [MagicId] -> Word#
381 mkRegLiveness [] = int2Word# 0#
382 mkRegLiveness (VanillaReg rep i : regs) | isFollowableRep rep
383 = ((int2Word# 1#) `shiftL#` (i -# 1#)) `or#` mkRegLiveness regs
384 mkRegLiveness (_ : regs) = mkRegLiveness regs
386 -- The two functions below are only used in a GranSim setup
387 -- Emit macro for simulating a fetch and then reschedule
389 fetchAndReschedule :: [MagicId] -- Live registers
390 -> Bool -- Node reqd?
393 fetchAndReschedule regs node_reqd =
394 if (node `elem` regs || node_reqd)
395 then fetch_code `thenC` reschedule_code
398 liveness_mask = mkRegLiveness regs
399 reschedule_code = absC (CMacroStmt GRAN_RESCHEDULE [
400 mkIntCLit (I# (word2Int# liveness_mask)),
401 mkIntCLit (if node_reqd then 1 else 0)])
403 --HWL: generate GRAN_FETCH macro for GrAnSim
404 -- currently GRAN_FETCH and GRAN_FETCH_AND_RESCHEDULE are miai
405 fetch_code = absC (CMacroStmt GRAN_FETCH [])
408 The @GRAN_YIELD@ macro is taken from JSM's code for Concurrent Haskell. It
409 allows to context-switch at places where @node@ is not alive (it uses the
410 @Continue@ rather than the @EnterNodeCode@ function in the RTS). We emit
411 this kind of macro at the beginning of the following kinds of basic bocks:
413 \item Slow entry code where node is not alive (see @CgClosure.lhs@). Normally
414 we use @fetchAndReschedule@ at a slow entry code.
415 \item Fast entry code (see @CgClosure.lhs@).
416 \item Alternatives in case expressions (@CLabelledCode@ structures), provided
417 that they are not inlined (see @CgCases.lhs@). These alternatives will
418 be turned into separate functions.
422 yield :: [MagicId] -- Live registers
423 -> Bool -- Node reqd?
426 yield regs node_reqd =
427 if opt_GranMacros && node_reqd
431 liveness_mask = mkRegLiveness regs
433 absC (CMacroStmt GRAN_YIELD
434 [mkIntCLit (I# (word2Int# liveness_mask))])
437 %************************************************************************
439 \subsection[initClosure]{Initialise a dynamic closure}
441 %************************************************************************
443 @allocDynClosure@ puts the thing in the heap, and modifies the virtual Hp
449 -> CAddrMode -- Cost Centre to stick in the object
450 -> CAddrMode -- Cost Centre to blame for this alloc
451 -- (usually the same; sometimes "OVERHEAD")
453 -> [(CAddrMode, VirtualHeapOffset)] -- Offsets from start of the object
454 -- ie Info ptr has offset zero.
455 -> FCode VirtualHeapOffset -- Returns virt offset of object
457 allocDynClosure closure_info use_cc blame_cc amodes_with_offsets
458 = getVirtAndRealHp `thenFC` \ (virtHp, realHp) ->
460 -- FIND THE OFFSET OF THE INFO-PTR WORD
461 -- virtHp points to last allocated word, ie 1 *before* the
462 -- info-ptr word of new object.
463 let info_offset = virtHp + 1
465 -- do_move IS THE ASSIGNMENT FUNCTION
466 do_move (amode, offset_from_start)
467 = CAssign (CVal (hpRel realHp
468 (info_offset + offset_from_start))
472 -- SAY WHAT WE ARE ABOUT TO DO
473 profCtrC (allocProfilingMsg closure_info)
474 [mkIntCLit (closureGoodStuffSize closure_info),
475 mkIntCLit slop_size] `thenC`
478 absC ( mkAbstractCs (
479 [ CInitHdr closure_info
480 (CAddr (hpRel realHp info_offset))
481 use_cc closure_size ]
482 ++ (map do_move amodes_with_offsets))) `thenC`
484 -- BUMP THE VIRTUAL HEAP POINTER
485 setVirtHp (virtHp + closure_size) `thenC`
487 -- RETURN PTR TO START OF OBJECT
490 closure_size = closureSize closure_info
491 slop_size = slopSize closure_info
494 Occasionally we can update a closure in place instead of allocating
495 new space for it. This is the function that does the business, assuming:
497 - node points to the closure to be overwritten
499 - the new closure doesn't contain any pointers if we're
500 using a generational collector.
503 inPlaceAllocDynClosure
505 -> CAddrMode -- Pointer to beginning of closure
506 -> CAddrMode -- Cost Centre to stick in the object
508 -> [(CAddrMode, VirtualHeapOffset)] -- Offsets from start of the object
509 -- ie Info ptr has offset zero.
512 inPlaceAllocDynClosure closure_info head use_cc amodes_with_offsets
513 = let -- do_move IS THE ASSIGNMENT FUNCTION
514 do_move (amode, offset_from_start)
515 = CAssign (CVal (CIndex head (mkIntCLit offset_from_start) WordRep)
520 absC ( mkAbstractCs (
521 [ CInitHdr closure_info head use_cc 0{-no alloc-} ]
522 ++ (map do_move amodes_with_offsets)))