2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4 % $Id: CgHeapery.lhs,v 1.15 1999/03/08 17:05:41 simonm Exp $
6 \section[CgHeapery]{Heap management functions}
10 fastEntryChecks, altHeapCheck, thunkChecks,
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 CmdLineOpts ( opt_SccProfilingOn )
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 ( if all_pointers then -- heap checks are quite easy
78 absC (checking_code stk_words hp_words tag_assts
79 free_reg (length regs))
81 else -- they are complicated
83 -- save all registers on the stack and adjust the stack pointer.
84 -- ToDo: find the initial all-pointer segment and don't save them.
86 mkTaggedStkAmodes sp addrmode_regs
87 `thenFC` \(new_sp, stk_assts, more_tag_assts) ->
89 -- only let the extra stack assignments affect the stack
90 -- high water mark if we were doing a stack check anyway;
91 -- otherwise we end up generating unnecessary stack checks.
92 -- Careful about knot-tying loops!
93 let real_stk_words = if new_sp - sp > stk_words && stk_words /= 0
98 let adjust_sp = CAssign (CReg Sp) (CAddr (spRel sp new_sp)) in
100 absC (checking_code real_stk_words hp_words
101 (mkAbstractCs [tag_assts, stk_assts, more_tag_assts,
107 setRealHp hp_words `thenC`
112 checking_code stk hp assts ret regs
113 | node_points = do_checks_np stk hp assts (regs+1) -- ret not required
114 | otherwise = do_checks stk hp assts ret regs
116 -- When node points to the closure for the function:
119 :: Int -- stack headroom
120 -> Int -- heap headroom
121 -> AbstractC -- assignments to perform on failure
122 -> Int -- number of pointer registers live
124 do_checks_np 0 0 _ _ = AbsCNop
125 do_checks_np 0 hp_words tag_assts ptrs =
131 do_checks_np stk_words 0 tag_assts ptrs =
137 do_checks_np stk_words hp_words tag_assts ptrs =
138 CCheck HP_STK_CHK_NP [
145 -- When node doesn't point to the closure (we need an explicit retn addr)
148 :: Int -- stack headroom
149 -> Int -- heap headroom
150 -> AbstractC -- assignments to perform on failure
151 -> CAddrMode -- a register to hold the retn addr.
152 -> Int -- number of pointer registers live
155 do_checks 0 0 _ _ _ = AbsCNop
156 do_checks 0 hp_words tag_assts ret_reg ptrs =
164 do_checks stk_words 0 tag_assts ret_reg ptrs =
172 do_checks stk_words hp_words tag_assts ret_reg ptrs =
182 free_reg = case length regs + 1 of
183 IBOX(x) -> CReg (VanillaReg PtrRep x)
185 all_pointers = all pointer regs
186 pointer (VanillaReg rep _) = isFollowableRep rep
189 addrmode_regs = map CReg regs
191 -- Checking code for thunks is just a special case of fast entry points:
193 thunkChecks :: CLabel -> Bool -> Code -> Code
194 thunkChecks ret node_points code = fastEntryChecks [] [] ret node_points code
197 Heap checks in a case alternative are nice and easy, provided this is
198 a bog-standard algebraic case. We have in our hand:
200 * one return address, on the stack,
201 * one return value, in Node.
203 the canned code for this heap check failure just pushes Node on the
204 stack, saying 'EnterGHC' to return. The scheduler will return by
205 entering the top value on the stack, which in turn will return through
206 the return address, getting us back to where we were. This is
207 therefore only valid if the return value is *lifted* (just being
208 boxed isn't good enough). Only a PtrRep will do.
210 For primitive returns, we have an unlifted value in some register
211 (either R1 or FloatReg1 or DblReg1). This means using specialised
212 heap-check code for these cases.
214 For unboxed tuple returns, there are an arbitrary number of possibly
215 unboxed return values, some of which will be in registers, and the
216 others will be on the stack, with gaps left for tagging the unboxed
217 objects. If a heap check is required, we need to fill in these tags.
219 The code below will cover all cases for the x86 architecture (where R1
220 is the only VanillaReg ever used). For other architectures, we'll
221 have to do something about saving and restoring the other registers.
225 :: Bool -- is an algebraic alternative
226 -> [MagicId] -- live registers
227 -> [(VirtualSpOffset,Int)] -- stack slots to tag
229 -> Maybe CLabel -- ret address if not on top of stack.
233 -- unboxed tuple alternatives and let-no-escapes (the two most annoying
234 -- constructs to generate code for!):
236 altHeapCheck is_fun regs tags fail_code (Just ret_addr) code
237 = mkTagAssts tags `thenFC` \tag_assts1 ->
238 let tag_assts = mkAbstractCs [fail_code, tag_assts1]
240 initHeapUsage (\ hHw -> do_heap_chk hHw tag_assts `thenC` code)
242 do_heap_chk words_required tag_assts
243 = absC (if words_required == 0
245 else checking_code tag_assts) `thenC`
246 setRealHp words_required
249 non_void_regs = filter (/= VoidReg) regs
251 checking_code tag_assts =
252 case non_void_regs of
254 -- this will cover all cases for x86
255 [VanillaReg rep ILIT(1)]
257 | isFollowableRep rep ->
259 [mkIntCLit words_required, mkIntCLit 1, mkIntCLit 0,
260 CReg (VanillaReg RetRep ILIT(2)),
261 CLbl ret_addr RetRep]
266 [mkIntCLit words_required, mkIntCLit 0, mkIntCLit 1,
267 CReg (VanillaReg RetRep ILIT(2)),
268 CLbl ret_addr RetRep]
272 let liveness = mkRegLiveness several_regs
275 [mkIntCLit words_required,
276 mkIntCLit (IBOX(word2Int# liveness)),
277 CLbl ret_addr RetRep]
280 -- normal algebraic and primitive case alternatives:
282 altHeapCheck is_fun regs [] AbsCNop Nothing code
283 = initHeapUsage (\ hHw -> do_heap_chk hHw `thenC` code)
285 do_heap_chk :: HeapOffset -> Code
286 do_heap_chk words_required
287 = absC (if words_required == 0
289 else checking_code) `thenC`
290 setRealHp words_required
293 non_void_regs = filter (/= VoidReg) regs
296 case non_void_regs of
298 -- No regs live: probably a Void return
300 CCheck HP_CHK_NOREGS [mkIntCLit words_required] AbsCNop
302 -- The SEQ case (polymophic/function typed case branch)
303 [VanillaReg rep ILIT(1)]
307 [mkIntCLit words_required, mkIntCLit 1{-regs live-}]
310 -- R1 is lifted (the common case)
311 [VanillaReg rep ILIT(1)]
314 [mkIntCLit words_required, mkIntCLit 1{-regs live-}]
317 -- R1 is boxed, but unlifted
318 | isFollowableRep rep ->
319 CCheck HP_CHK_UNPT_R1 [mkIntCLit words_required] AbsCNop
323 CCheck HP_CHK_UNBX_R1 [mkIntCLit words_required] AbsCNop
326 [FloatReg ILIT(1)] ->
327 CCheck HP_CHK_F1 [mkIntCLit words_required] AbsCNop
330 [DoubleReg ILIT(1)] ->
331 CCheck HP_CHK_D1 [mkIntCLit words_required] AbsCNop
334 [LongReg _ ILIT(1)] ->
335 CCheck HP_CHK_L1 [mkIntCLit words_required] AbsCNop
338 _ -> panic ("CgHeapery.altHeapCheck: unimplemented heap-check, live regs = " ++ showSDoc (sep (map pprMagicId non_void_regs)))
341 -- build up a bitmap of the live pointer registers
343 mkRegLiveness :: [MagicId] -> Word#
344 mkRegLiveness [] = int2Word# 0#
345 mkRegLiveness (VanillaReg rep i : regs) | isFollowableRep rep
346 = ((int2Word# 1#) `shiftL#` (i -# 1#)) `or#` mkRegLiveness regs
347 mkRegLiveness (_ : regs) = mkRegLiveness regs
349 -- Emit macro for simulating a fetch and then reschedule
351 fetchAndReschedule :: [MagicId] -- Live registers
352 -> Bool -- Node reqd?
355 fetchAndReschedule regs node_reqd =
356 if (node `elem` regs || node_reqd)
357 then fetch_code `thenC` reschedule_code
360 all_regs = if node_reqd then node:regs else regs
361 liveness_mask = 0 {-XXX: mkLiveRegsMask all_regs-}
363 reschedule_code = absC (CMacroStmt GRAN_RESCHEDULE [
364 mkIntCLit liveness_mask,
365 mkIntCLit (if node_reqd then 1 else 0)])
367 --HWL: generate GRAN_FETCH macro for GrAnSim
368 -- currently GRAN_FETCH and GRAN_FETCH_AND_RESCHEDULE are miai
369 fetch_code = absC (CMacroStmt GRAN_FETCH [])
372 The @GRAN_YIELD@ macro is taken from JSM's code for Concurrent Haskell. It
373 allows to context-switch at places where @node@ is not alive (it uses the
374 @Continue@ rather than the @EnterNodeCode@ function in the RTS). We emit
375 this kind of macro at the beginning of the following kinds of basic bocks:
377 \item Slow entry code where node is not alive (see @CgClosure.lhs@). Normally
378 we use @fetchAndReschedule@ at a slow entry code.
379 \item Fast entry code (see @CgClosure.lhs@).
380 \item Alternatives in case expressions (@CLabelledCode@ structures), provided
381 that they are not inlined (see @CgCases.lhs@). These alternatives will
382 be turned into separate functions.
386 yield :: [MagicId] -- Live registers
387 -> Bool -- Node reqd?
390 yield regs node_reqd =
391 -- NB: node is not alive; that's why we use DO_YIELD rather than
395 all_regs = if node_reqd then node:regs else regs
396 liveness_mask = 0 {-XXX: mkLiveRegsMask all_regs-}
398 yield_code = absC (CMacroStmt GRAN_YIELD [mkIntCLit liveness_mask])
401 %************************************************************************
403 \subsection[initClosure]{Initialise a dynamic closure}
405 %************************************************************************
407 @allocDynClosure@ puts the thing in the heap, and modifies the virtual Hp
413 -> CAddrMode -- Cost Centre to stick in the object
414 -> CAddrMode -- Cost Centre to blame for this alloc
415 -- (usually the same; sometimes "OVERHEAD")
417 -> [(CAddrMode, VirtualHeapOffset)] -- Offsets from start of the object
418 -- ie Info ptr has offset zero.
419 -> FCode VirtualHeapOffset -- Returns virt offset of object
421 allocDynClosure closure_info use_cc blame_cc amodes_with_offsets
422 = getVirtAndRealHp `thenFC` \ (virtHp, realHp) ->
424 -- FIND THE OFFSET OF THE INFO-PTR WORD
425 -- virtHp points to last allocated word, ie 1 *before* the
426 -- info-ptr word of new object.
427 let info_offset = virtHp + 1
429 -- do_move IS THE ASSIGNMENT FUNCTION
430 do_move (amode, offset_from_start)
431 = CAssign (CVal (hpRel realHp
432 (info_offset + offset_from_start))
436 -- SAY WHAT WE ARE ABOUT TO DO
437 profCtrC (allocProfilingMsg closure_info)
438 [mkIntCLit (closureGoodStuffSize closure_info),
439 mkIntCLit slop_size] `thenC`
442 absC ( mkAbstractCs (
443 [ cInitHdr closure_info (hpRel realHp info_offset) use_cc ]
444 ++ (map do_move amodes_with_offsets))) `thenC`
446 -- GENERATE CC PROFILING MESSAGES
447 costCentresC SLIT("CCS_ALLOC") [blame_cc, mkIntCLit closure_size]
450 -- BUMP THE VIRTUAL HEAP POINTER
451 setVirtHp (virtHp + closure_size) `thenC`
453 -- RETURN PTR TO START OF OBJECT
456 closure_size = closureSize closure_info
457 slop_size = slopSize closure_info
459 -- Avoid hanging on to anything in the CC field when we're not profiling.
461 cInitHdr closure_info amode cc
462 | opt_SccProfilingOn = CInitHdr closure_info amode cc
463 | otherwise = CInitHdr closure_info amode (panic "absent cc")