2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4 % $Id: CgHeapery.lhs,v 1.36 2002/12/18 16:15:43 simonmar Exp $
6 \section[CgHeapery]{Heap management functions}
10 funEntryChecks, altHeapCheck, unbxTupleHeapCheck, 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 )
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 CmdLineOpts ( opt_GranMacros )
36 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 function or thunk entry point.
60 funEntryChecks :: Maybe CLabel -> AbstractC -> Code -> Code
61 funEntryChecks closure_lbl reg_save_code code
62 = hpStkCheck closure_lbl True reg_save_code code
64 thunkChecks :: Maybe CLabel -> Code -> Code
65 thunkChecks closure_lbl code
66 = hpStkCheck closure_lbl False AbsCNop code
69 :: Maybe CLabel -- function closure
70 -> Bool -- is a function? (not a thunk)
71 -> AbstractC -- register saves
75 hpStkCheck closure_lbl is_fun reg_save_code code
76 = getFinalStackHW (\ spHw ->
77 getRealSp `thenFC` \ sp ->
78 let stk_words = spHw - sp in
79 initHeapUsage (\ hHw ->
81 getTickyCtrLabel `thenFC` \ ticky_ctr ->
83 absC (checking_code stk_words hHw ticky_ctr) `thenC`
90 | Just lbl <- closure_lbl = CAssign nodeReg (CLbl lbl PtrRep)
93 save_code = mkAbstractCs [node_asst, reg_save_code]
95 checking_code stk hp ctr
98 then do_checks_fun stk hp save_code
99 else do_checks_np stk hp save_code,
102 else profCtrAbsC FSLIT("TICK_ALLOC_HEAP")
103 [ mkIntCLit hp, CLbl ctr DataPtrRep ]
110 :: Int -- stack headroom
111 -> Int -- heap headroom
112 -> AbstractC -- assignments to perform on failure
114 do_checks_fun 0 0 _ = AbsCNop
115 do_checks_fun 0 hp_words assts =
116 CCheck HP_CHK_FUN [ mkIntCLit hp_words ] assts
117 do_checks_fun stk_words 0 assts =
118 CCheck STK_CHK_FUN [ mkIntCLit stk_words ] assts
119 do_checks_fun stk_words hp_words assts =
120 CCheck HP_STK_CHK_FUN [ mkIntCLit stk_words, mkIntCLit hp_words ] assts
125 :: Int -- stack headroom
126 -> Int -- heap headroom
127 -> AbstractC -- assignments to perform on failure
129 do_checks_np 0 0 _ = AbsCNop
130 do_checks_np 0 hp_words assts =
131 CCheck HP_CHK_NP [ mkIntCLit hp_words ] assts
132 do_checks_np stk_words 0 assts =
133 CCheck STK_CHK_NP [ mkIntCLit stk_words ] assts
134 do_checks_np stk_words hp_words assts =
135 CCheck HP_STK_CHK_NP [ mkIntCLit stk_words, mkIntCLit hp_words ] assts
138 Heap checks in a case alternative are nice and easy, provided this is
139 a bog-standard algebraic case. We have in our hand:
141 * one return address, on the stack,
142 * one return value, in Node.
144 the canned code for this heap check failure just pushes Node on the
145 stack, saying 'EnterGHC' to return. The scheduler will return by
146 entering the top value on the stack, which in turn will return through
147 the return address, getting us back to where we were. This is
148 therefore only valid if the return value is *lifted* (just being
149 boxed isn't good enough).
151 For primitive returns, we have an unlifted value in some register
152 (either R1 or FloatReg1 or DblReg1). This means using specialised
153 heap-check code for these cases.
155 For unboxed tuple returns, there are an arbitrary number of possibly
156 unboxed return values, some of which will be in registers, and the
157 others will be on the stack. We always organise the stack-resident
158 fields into pointers & non-pointers, and pass the number of each to
163 :: Bool -- do not enter node on return
164 -> [MagicId] -- live registers
165 -> Code -- continuation
169 -- normal algebraic and primitive case alternatives:
171 altHeapCheck no_enter regs code
172 = initHeapUsage (\ hHw -> do_heap_chk hHw `thenC` code)
174 do_heap_chk :: HeapOffset -> Code
175 do_heap_chk words_required
176 = getTickyCtrLabel `thenFC` \ ctr ->
177 absC ( if words_required == 0
181 profCtrAbsC FSLIT("TICK_ALLOC_HEAP")
182 [ mkIntCLit words_required, CLbl ctr DataPtrRep ]
185 setRealHp words_required
188 non_void_regs = filter (/= VoidReg) regs
191 case non_void_regs of
193 -- No regs live: probably a Void return
195 CCheck HP_CHK_NOREGS [mkIntCLit words_required] AbsCNop
198 -- R1 is boxed, but unlifted: DO NOT enter R1 when we return.
199 | isFollowableRep rep && no_enter ->
200 CCheck HP_CHK_UNPT_R1 [mkIntCLit words_required] AbsCNop
202 -- R1 is lifted (the common case)
203 | isFollowableRep rep ->
205 [mkIntCLit words_required]
210 CCheck HP_CHK_UNBX_R1 [mkIntCLit words_required] AbsCNop
214 CCheck HP_CHK_F1 [mkIntCLit words_required] AbsCNop
218 CCheck HP_CHK_D1 [mkIntCLit words_required] AbsCNop
222 CCheck HP_CHK_L1 [mkIntCLit words_required] AbsCNop
225 _ -> panic ("CgHeapery.altHeapCheck: unimplemented heap-check, live regs = " ++ showSDoc (sep (map pprMagicId non_void_regs)))
228 -- unboxed tuple alternatives and let-no-escapes (the two most annoying
229 -- constructs to generate code for!):
232 :: [MagicId] -- live registers
233 -> Int -- no. of stack slots containing ptrs
234 -> Int -- no. of stack slots containing nonptrs
235 -> AbstractC -- code to insert in the failure path
239 unbxTupleHeapCheck regs ptrs nptrs fail_code code
240 -- we can't manage more than 255 pointers/non-pointers in a generic
242 | ptrs > 255 || nptrs > 255 = panic "altHeapCheck"
243 | otherwise = initHeapUsage (\ hHw -> do_heap_chk hHw `thenC` code)
245 do_heap_chk words_required
246 = getTickyCtrLabel `thenFC` \ ctr ->
247 absC ( if words_required == 0
251 profCtrAbsC FSLIT("TICK_ALLOC_HEAP")
252 [ mkIntCLit words_required, CLbl ctr DataPtrRep ]
255 setRealHp words_required
259 let liveness = mkRegLiveness regs ptrs nptrs
261 CCheck HP_CHK_UNBX_TUPLE
262 [mkIntCLit words_required,
263 mkIntCLit (I# (word2Int# liveness))]
266 -- build up a bitmap of the live pointer registers
268 #if __GLASGOW_HASKELL__ >= 503
269 shiftL = uncheckedShiftL#
274 mkRegLiveness :: [MagicId] -> Int -> Int -> Word#
275 mkRegLiveness [] (I# ptrs) (I# nptrs) =
276 (int2Word# nptrs `shiftL` 16#) `or#` (int2Word# ptrs `shiftL` 24#)
277 mkRegLiveness (VanillaReg rep i : regs) ptrs nptrs | isFollowableRep rep
278 = ((int2Word# 1#) `shiftL` (i -# 1#)) `or#` mkRegLiveness regs ptrs nptrs
279 mkRegLiveness (_ : regs) ptrs nptrs = mkRegLiveness regs ptrs nptrs
281 -- The two functions below are only used in a GranSim setup
282 -- Emit macro for simulating a fetch and then reschedule
284 fetchAndReschedule :: [MagicId] -- Live registers
285 -> Bool -- Node reqd?
288 fetchAndReschedule regs node_reqd =
289 if (node `elem` regs || node_reqd)
290 then fetch_code `thenC` reschedule_code
293 liveness_mask = mkRegLiveness regs 0 0
294 reschedule_code = absC (CMacroStmt GRAN_RESCHEDULE [
295 mkIntCLit (I# (word2Int# liveness_mask)),
296 mkIntCLit (if node_reqd then 1 else 0)])
298 --HWL: generate GRAN_FETCH macro for GrAnSim
299 -- currently GRAN_FETCH and GRAN_FETCH_AND_RESCHEDULE are miai
300 fetch_code = absC (CMacroStmt GRAN_FETCH [])
303 The @GRAN_YIELD@ macro is taken from JSM's code for Concurrent Haskell. It
304 allows to context-switch at places where @node@ is not alive (it uses the
305 @Continue@ rather than the @EnterNodeCode@ function in the RTS). We emit
306 this kind of macro at the beginning of the following kinds of basic bocks:
308 \item Slow entry code where node is not alive (see @CgClosure.lhs@). Normally
309 we use @fetchAndReschedule@ at a slow entry code.
310 \item Fast entry code (see @CgClosure.lhs@).
311 \item Alternatives in case expressions (@CLabelledCode@ structures), provided
312 that they are not inlined (see @CgCases.lhs@). These alternatives will
313 be turned into separate functions.
317 yield :: [MagicId] -- Live registers
318 -> Bool -- Node reqd?
321 yield regs node_reqd =
322 if opt_GranMacros && node_reqd
326 liveness_mask = mkRegLiveness regs 0 0
328 absC (CMacroStmt GRAN_YIELD
329 [mkIntCLit (I# (word2Int# liveness_mask))])
332 %************************************************************************
334 \subsection[initClosure]{Initialise a dynamic closure}
336 %************************************************************************
338 @allocDynClosure@ puts the thing in the heap, and modifies the virtual Hp
344 -> CAddrMode -- Cost Centre to stick in the object
345 -> CAddrMode -- Cost Centre to blame for this alloc
346 -- (usually the same; sometimes "OVERHEAD")
348 -> [(CAddrMode, VirtualHeapOffset)] -- Offsets from start of the object
349 -- ie Info ptr has offset zero.
350 -> FCode VirtualHeapOffset -- Returns virt offset of object
352 allocDynClosure closure_info use_cc blame_cc amodes_with_offsets
353 = getVirtAndRealHp `thenFC` \ (virtHp, realHp) ->
355 -- FIND THE OFFSET OF THE INFO-PTR WORD
356 -- virtHp points to last allocated word, ie 1 *before* the
357 -- info-ptr word of new object.
358 let info_offset = virtHp + 1
360 -- do_move IS THE ASSIGNMENT FUNCTION
361 do_move (amode, offset_from_start)
362 = CAssign (CVal (hpRel realHp
363 (info_offset + offset_from_start))
367 -- SAY WHAT WE ARE ABOUT TO DO
368 profCtrC (allocProfilingMsg closure_info)
369 [mkIntCLit (closureGoodStuffSize closure_info),
370 mkIntCLit slop_size] `thenC`
373 absC ( mkAbstractCs (
374 [ CInitHdr closure_info
375 (CAddr (hpRel realHp info_offset))
376 use_cc closure_size ]
377 ++ (map do_move amodes_with_offsets))) `thenC`
379 -- BUMP THE VIRTUAL HEAP POINTER
380 setVirtHp (virtHp + closure_size) `thenC`
382 -- RETURN PTR TO START OF OBJECT
385 closure_size = closureSize closure_info
386 slop_size = slopSize closure_info
389 Occasionally we can update a closure in place instead of allocating
390 new space for it. This is the function that does the business, assuming:
392 - node points to the closure to be overwritten
394 - the new closure doesn't contain any pointers if we're
395 using a generational collector.
398 inPlaceAllocDynClosure
400 -> CAddrMode -- Pointer to beginning of closure
401 -> CAddrMode -- Cost Centre to stick in the object
403 -> [(CAddrMode, VirtualHeapOffset)] -- Offsets from start of the object
404 -- ie Info ptr has offset zero.
407 inPlaceAllocDynClosure closure_info head use_cc amodes_with_offsets
408 = let -- do_move IS THE ASSIGNMENT FUNCTION
409 do_move (amode, offset_from_start)
410 = CAssign (CVal (CIndex head (mkIntCLit offset_from_start) WordRep)
415 absC ( mkAbstractCs (
416 [ CInitHdr closure_info head use_cc 0{-no alloc-} ]
417 ++ (map do_move amodes_with_offsets)))