2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4 % $Id: CgHeapery.lhs,v 1.10 1998/12/02 13:17:50 simonm Exp $
6 \section[CgHeapery]{Heap management functions}
10 fastEntryChecks, altHeapCheck, thunkChecks,
11 allocHeap, allocDynClosure
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, getSMRepStr )
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 )
35 import CmdLineOpts ( opt_SccProfilingOn )
39 import PprAbsC ( pprMagicId ) -- tmp
40 import Outputable -- 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 ( if all_pointers then -- heap checks are quite easy
79 absC (checking_code stk_words hp_words tag_assts
80 free_reg (length regs))
82 else -- they are complicated
84 -- save all registers on the stack and adjust the stack pointer.
85 -- ToDo: find the initial all-pointer segment and don't save them.
87 mkTaggedStkAmodes sp addrmode_regs
88 `thenFC` \(new_sp, stk_assts, more_tag_assts) ->
90 -- only let the extra stack assignments affect the stack
91 -- high water mark if we were doing a stack check anyway;
92 -- otherwise we end up generating unnecessary stack checks.
93 -- Careful about knot-tying loops!
94 let real_stk_words = if new_sp - sp > stk_words && stk_words /= 0
99 let adjust_sp = CAssign (CReg Sp) (CAddr (spRel sp new_sp)) in
101 absC (checking_code real_stk_words hp_words
102 (mkAbstractCs [tag_assts, stk_assts, more_tag_assts,
108 setRealHp hp_words `thenC`
113 checking_code stk hp assts ret regs
114 | node_points = do_checks_np stk hp assts (regs+1) -- ret not required
115 | otherwise = do_checks stk hp assts ret regs
117 -- When node points to the closure for the function:
120 :: Int -- stack headroom
121 -> Int -- heap headroom
122 -> AbstractC -- assignments to perform on failure
123 -> Int -- number of pointer registers live
125 do_checks_np 0 0 _ _ = AbsCNop
126 do_checks_np 0 hp_words tag_assts ptrs =
132 do_checks_np stk_words 0 tag_assts ptrs =
138 do_checks_np stk_words hp_words tag_assts ptrs =
139 CCheck HP_STK_CHK_NP [
146 -- When node doesn't point to the closure (we need an explicit retn addr)
149 :: Int -- stack headroom
150 -> Int -- heap headroom
151 -> AbstractC -- assignments to perform on failure
152 -> CAddrMode -- a register to hold the retn addr.
153 -> Int -- number of pointer registers live
156 do_checks 0 0 _ _ _ = AbsCNop
157 do_checks 0 hp_words tag_assts ret_reg ptrs =
165 do_checks stk_words 0 tag_assts ret_reg ptrs =
173 do_checks stk_words hp_words tag_assts ret_reg ptrs =
183 free_reg = case length regs + 1 of
184 IBOX(x) -> CReg (VanillaReg PtrRep x)
186 all_pointers = all pointer regs
187 pointer (VanillaReg rep _) = isFollowableRep rep
190 addrmode_regs = map CReg regs
192 -- Checking code for thunks is just a special case of fast entry points:
194 thunkChecks :: CLabel -> Bool -> Code -> Code
195 thunkChecks ret node_points code = fastEntryChecks [] [] ret node_points code
198 Heap checks in a case alternative are nice and easy, provided this is
199 a bog-standard algebraic case. We have in our hand:
201 * one return address, on the stack,
202 * one return value, in Node.
204 the canned code for this heap check failure just pushes Node on the
205 stack, saying 'EnterGHC' to return. The scheduler will return by
206 entering the top value on the stack, which in turn will return through
207 the return address, getting us back to where we were. This is
208 therefore only valid if the return value is *lifted* (just being
209 boxed isn't good enough). Only a PtrRep will do.
211 For primitive returns, we have an unlifted value in some register
212 (either R1 or FloatReg1 or DblReg1). This means using specialised
213 heap-check code for these cases.
215 For unboxed tuple returns, there are an arbitrary number of possibly
216 unboxed return values, some of which will be in registers, and the
217 others will be on the stack, with gaps left for tagging the unboxed
218 objects. If a heap check is required, we need to fill in these tags.
220 The code below will cover all cases for the x86 architecture (where R1
221 is the only VanillaReg ever used). For other architectures, we'll
222 have to do something about saving and restoring the other registers.
226 :: Bool -- is an algebraic alternative
227 -> [MagicId] -- live registers
228 -> [(VirtualSpOffset,Int)] -- stack slots to tag
230 -> Maybe CLabel -- ret address if not on top of stack.
234 -- unboxed tuple alternatives and let-no-escapes (the two most annoying
235 -- constructs to generate code for!):
237 altHeapCheck is_fun regs tags fail_code (Just ret_addr) code
238 = mkTagAssts tags `thenFC` \tag_assts1 ->
239 let tag_assts = mkAbstractCs [fail_code, tag_assts1]
241 initHeapUsage (\ hHw -> do_heap_chk hHw tag_assts `thenC` code)
243 do_heap_chk words_required tag_assts
244 = absC (if words_required == 0
246 else checking_code tag_assts) `thenC`
247 setRealHp words_required
250 non_void_regs = filter (/= VoidReg) regs
252 checking_code tag_assts =
253 case non_void_regs of
255 -- this will cover all cases for x86
256 [VanillaReg rep ILIT(1)]
258 | isFollowableRep rep ->
260 [mkIntCLit words_required, mkIntCLit 1, mkIntCLit 0,
261 CReg (VanillaReg RetRep ILIT(2)),
262 CLbl ret_addr RetRep]
267 [mkIntCLit words_required, mkIntCLit 0, mkIntCLit 1,
268 CReg (VanillaReg RetRep ILIT(2)),
269 CLbl ret_addr RetRep]
273 let liveness = mkRegLiveness several_regs
276 [mkIntCLit words_required,
277 mkIntCLit (IBOX(word2Int# liveness)),
278 CLbl ret_addr RetRep]
281 -- normal algebraic and primitive case alternatives:
283 altHeapCheck is_fun regs [] AbsCNop Nothing code
284 = initHeapUsage (\ hHw -> do_heap_chk hHw `thenC` code)
286 do_heap_chk :: HeapOffset -> Code
287 do_heap_chk words_required
288 = absC (if words_required == 0
290 else checking_code) `thenC`
291 setRealHp words_required
294 non_void_regs = filter (/= VoidReg) regs
297 case non_void_regs of
299 -- No regs live: probably a Void return
301 CCheck HP_CHK_NOREGS [mkIntCLit words_required] AbsCNop
303 -- The SEQ case (polymophic/function typed case branch)
304 [VanillaReg rep ILIT(1)]
308 [mkIntCLit words_required, mkIntCLit 1{-regs live-}]
311 -- R1 is lifted (the common case)
312 [VanillaReg rep ILIT(1)]
315 [mkIntCLit words_required, mkIntCLit 1{-regs live-}]
318 -- R1 is boxed, but unlifted
319 | isFollowableRep rep ->
320 CCheck HP_CHK_UNPT_R1 [mkIntCLit words_required] AbsCNop
324 CCheck HP_CHK_UNBX_R1 [mkIntCLit words_required] AbsCNop
327 [FloatReg ILIT(1)] ->
328 CCheck HP_CHK_F1 [mkIntCLit words_required] AbsCNop
331 [DoubleReg ILIT(1)] ->
332 CCheck HP_CHK_D1 [mkIntCLit words_required] AbsCNop
335 [LongReg _ ILIT(1)] ->
336 CCheck HP_CHK_L1 [mkIntCLit words_required] AbsCNop
339 _ -> panic ("CgHeapery.altHeapCheck: unimplemented heap-check, live regs = " ++ showSDoc (sep (map pprMagicId non_void_regs)))
342 -- build up a bitmap of the live pointer registers
344 mkRegLiveness :: [MagicId] -> Word#
345 mkRegLiveness [] = int2Word# 0#
346 mkRegLiveness (VanillaReg rep i : regs)
347 | isFollowableRep rep = ((int2Word# 1#) `shiftL#` (i -# 1#))
348 `or#` mkRegLiveness regs
349 | otherwise = mkRegLiveness regs
351 -- Emit macro for simulating a fetch and then reschedule
353 fetchAndReschedule :: [MagicId] -- Live registers
354 -> Bool -- Node reqd?
357 fetchAndReschedule regs node_reqd =
358 if (node `elem` regs || node_reqd)
359 then fetch_code `thenC` reschedule_code
362 all_regs = if node_reqd then node:regs else regs
363 liveness_mask = 0 {-XXX: mkLiveRegsMask all_regs-}
365 reschedule_code = absC (CMacroStmt GRAN_RESCHEDULE [
366 mkIntCLit liveness_mask,
367 mkIntCLit (if node_reqd then 1 else 0)])
369 --HWL: generate GRAN_FETCH macro for GrAnSim
370 -- currently GRAN_FETCH and GRAN_FETCH_AND_RESCHEDULE are miai
371 fetch_code = absC (CMacroStmt GRAN_FETCH [])
374 The @GRAN_YIELD@ macro is taken from JSM's code for Concurrent Haskell. It
375 allows to context-switch at places where @node@ is not alive (it uses the
376 @Continue@ rather than the @EnterNodeCode@ function in the RTS). We emit
377 this kind of macro at the beginning of the following kinds of basic bocks:
379 \item Slow entry code where node is not alive (see @CgClosure.lhs@). Normally
380 we use @fetchAndReschedule@ at a slow entry code.
381 \item Fast entry code (see @CgClosure.lhs@).
382 \item Alternatives in case expressions (@CLabelledCode@ structures), provided
383 that they are not inlined (see @CgCases.lhs@). These alternatives will
384 be turned into separate functions.
388 yield :: [MagicId] -- Live registers
389 -> Bool -- Node reqd?
392 yield regs node_reqd =
393 -- NB: node is not alive; that's why we use DO_YIELD rather than
397 all_regs = if node_reqd then node:regs else regs
398 liveness_mask = 0 {-XXX: mkLiveRegsMask all_regs-}
400 yield_code = absC (CMacroStmt GRAN_YIELD [mkIntCLit liveness_mask])
403 %************************************************************************
405 \subsection[initClosure]{Initialise a dynamic closure}
407 %************************************************************************
409 @allocDynClosure@ puts the thing in the heap, and modifies the virtual Hp
415 -> CAddrMode -- Cost Centre to stick in the object
416 -> CAddrMode -- Cost Centre to blame for this alloc
417 -- (usually the same; sometimes "OVERHEAD")
419 -> [(CAddrMode, VirtualHeapOffset)] -- Offsets from start of the object
420 -- ie Info ptr has offset zero.
421 -> FCode VirtualHeapOffset -- Returns virt offset of object
423 allocDynClosure closure_info use_cc blame_cc amodes_with_offsets
424 = getVirtAndRealHp `thenFC` \ (virtHp, realHp) ->
426 -- FIND THE OFFSET OF THE INFO-PTR WORD
427 -- virtHp points to last allocated word, ie 1 *before* the
428 -- info-ptr word of new object.
429 let info_offset = virtHp + 1
431 -- do_move IS THE ASSIGNMENT FUNCTION
432 do_move (amode, offset_from_start)
433 = CAssign (CVal (hpRel realHp
434 (info_offset + offset_from_start))
438 -- SAY WHAT WE ARE ABOUT TO DO
439 profCtrC (allocProfilingMsg closure_info)
440 [mkIntCLit fixedHdrSize,
441 mkIntCLit (closureGoodStuffSize closure_info),
443 mkIntCLit closure_size] `thenC`
446 absC ( mkAbstractCs (
447 [ cInitHdr closure_info (hpRel realHp info_offset) use_cc ]
448 ++ (map do_move amodes_with_offsets))) `thenC`
450 -- GENERATE CC PROFILING MESSAGES
451 costCentresC SLIT("CCS_ALLOC") [blame_cc, mkIntCLit closure_size]
452 -- CLitLit (_PK_ type_str) IntRep] -- not necessary? --SDM
455 -- BUMP THE VIRTUAL HEAP POINTER
456 setVirtHp (virtHp + closure_size) `thenC`
458 -- RETURN PTR TO START OF OBJECT
461 closure_size = closureSize closure_info
462 slop_size = slopSize closure_info
463 type_str = getSMRepStr (closureSMRep closure_info)
465 -- Avoid hanging on to anything in the CC field when we're not profiling.
467 cInitHdr closure_info amode cc
468 | opt_SccProfilingOn = CInitHdr closure_info amode cc
469 | otherwise = CInitHdr closure_info amode (panic "absent cc")
473 %************************************************************************
475 \subsection{Allocate uninitialized heap space}
477 %************************************************************************
480 allocHeap :: HeapOffset -- Size of the space required
481 -> FCode CAddrMode -- Addr mode for first word of object
484 = getVirtAndRealHp `thenFC` \ (virtHp, realHp) ->
485 let block_start = virtHp + 1
487 -- We charge the allocation to "PRIM" (which is probably right)
488 profCtrC SLIT("ALLOC_PRIM2") [mkIntCLit space] `thenC`
490 -- BUMP THE VIRTUAL HEAP POINTER
491 setVirtHp (virtHp + space) `thenC`
493 -- RETURN PTR TO START OF OBJECT
494 returnFC (CAddr (hpRel realHp block_start))