2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4 % $Id: CgHeapery.lhs,v 1.43 2005/02/10 13:01:53 simonmar Exp $
6 \section[CgHeapery]{Heap management functions}
10 initHeapUsage, getVirtHp, setVirtHp, setRealHp,
11 getHpRelOffset, hpRel,
13 funEntryChecks, thunkEntryChecks,
14 altHeapCheck, unbxTupleHeapCheck,
15 hpChkGen, hpChkNodePointsAssignSp0,
16 stkChkGen, stkChkNodePoints,
18 layOutDynConstr, layOutStaticConstr,
19 mkVirtHeapOffsets, mkStaticClosureFields, mkStaticClosure,
21 allocDynClosure, emitSetDynHdr
24 #include "HsVersions.h"
26 import Constants ( mIN_UPD_SIZE )
27 import StgSyn ( AltType(..) )
28 import CLabel ( CLabel, mkRtsCodeLabel )
29 import CgUtils ( mkWordCLit, cmmRegOffW, cmmOffsetW,
32 import CgProf ( staticProfHdr, profDynAlloc, dynProfHdr )
33 import CgTicky ( staticTickyHdr, tickyDynAlloc, tickyAllocHeap )
34 import CgParallel ( staticGranHdr, staticParHdr, doGranAllocate )
35 import CgStackery ( getFinalStackHW, getRealSp )
36 import CgCallConv ( mkRegLiveness )
37 import ClosureInfo ( closureSize, staticClosureNeedsLink,
38 mkConInfo, closureNeedsUpdSpace,
39 infoTableLabelFromCI, closureLabelFromCI,
40 nodeMustPointToIt, closureLFInfo,
42 import SMRep ( CgRep(..), cgRepSizeW, separateByPtrFollowness,
43 WordOff, fixedHdrSize, isVoidArg, primRepToCgRep )
45 import Cmm ( CmmLit(..), CmmStmt(..), CmmExpr(..), GlobalReg(..),
46 CmmReg(..), hpReg, nodeReg, spReg )
47 import MachOp ( mo_wordULt, mo_wordUGt, mo_wordSub )
48 import CmmUtils ( mkIntCLit, CmmStmts, noStmts, oneStmt, plusStmts,
51 import DataCon ( DataCon )
52 import TyCon ( tyConPrimRep )
53 import CostCentre ( CostCentreStack )
54 import Util ( mapAccumL, filterOut )
55 import Constants ( wORD_SIZE )
56 import CmdLineOpts ( DynFlags )
64 %************************************************************************
66 \subsection[CgUsages-heapery]{Monad things for fiddling with heap usage}
68 %************************************************************************
70 The heap always grows upwards, so hpRel is easy
73 hpRel :: VirtualHpOffset -- virtual offset of Hp
74 -> VirtualHpOffset -- virtual offset of The Thing
75 -> WordOff -- integer word offset
76 hpRel hp off = off - hp
79 @initHeapUsage@ applies a function to the amount of heap that it uses.
80 It initialises the heap usage to zeros, and passes on an unchanged
83 It is usually a prelude to performing a GC check, so everything must
84 be in a tidy and consistent state.
86 rje: Note the slightly suble fixed point behaviour needed here
89 initHeapUsage :: (VirtualHpOffset -> Code) -> Code
91 = do { orig_hp_usage <- getHpUsage
92 ; setHpUsage initHpUsage
93 ; fixC (\heap_usage2 -> do
94 { fcode (heapHWM heap_usage2)
96 ; setHpUsage orig_hp_usage }
98 setVirtHp :: VirtualHpOffset -> Code
100 = do { hp_usage <- getHpUsage
101 ; setHpUsage (hp_usage {virtHp = new_virtHp}) }
103 getVirtHp :: FCode VirtualHpOffset
105 = do { hp_usage <- getHpUsage
106 ; return (virtHp hp_usage) }
108 setRealHp :: VirtualHpOffset -> Code
110 = do { hp_usage <- getHpUsage
111 ; setHpUsage (hp_usage {realHp = new_realHp}) }
113 getHpRelOffset :: VirtualHpOffset -> FCode CmmExpr
114 getHpRelOffset virtual_offset
115 = do { hp_usg <- getHpUsage
116 ; return (cmmRegOffW hpReg (hpRel (realHp hp_usg) virtual_offset)) }
120 %************************************************************************
122 Layout of heap objects
124 %************************************************************************
127 layOutDynConstr, layOutStaticConstr
132 [(a,VirtualHpOffset)])
134 layOutDynConstr = layOutConstr False
135 layOutStaticConstr = layOutConstr True
137 layOutConstr is_static dflags data_con args
138 = (mkConInfo dflags is_static data_con tot_wds ptr_wds,
141 (tot_wds, -- #ptr_wds + #nonptr_wds
143 things_w_offsets) = mkVirtHeapOffsets args
146 @mkVirtHeapOffsets@ always returns boxed things with smaller offsets
147 than the unboxed things, and furthermore, the offsets in the result
152 :: [(CgRep,a)] -- Things to make offsets for
153 -> (WordOff, -- *Total* number of words allocated
154 WordOff, -- Number of words allocated for *pointers*
155 [(a, VirtualHpOffset)])
156 -- Things with their offsets from start of
157 -- object in order of increasing offset
159 -- First in list gets lowest offset, which is initial offset + 1.
161 mkVirtHeapOffsets things
162 = let non_void_things = filterOut (isVoidArg . fst) things
163 (ptrs, non_ptrs) = separateByPtrFollowness non_void_things
164 (wds_of_ptrs, ptrs_w_offsets) = mapAccumL computeOffset 0 ptrs
165 (tot_wds, non_ptrs_w_offsets) = mapAccumL computeOffset wds_of_ptrs non_ptrs
167 (tot_wds, wds_of_ptrs, ptrs_w_offsets ++ non_ptrs_w_offsets)
169 computeOffset wds_so_far (rep, thing)
170 = (wds_so_far + cgRepSizeW rep, (thing, fixedHdrSize + wds_so_far))
174 %************************************************************************
176 Lay out a static closure
178 %************************************************************************
180 Make a static closure, adding on any extra padding needed for CAFs,
181 and adding a static link field if necessary.
184 mkStaticClosureFields
187 -> Bool -- Has CAF refs
188 -> [CmmLit] -- Payload
189 -> [CmmLit] -- The full closure
190 mkStaticClosureFields cl_info ccs caf_refs payload
191 = mkStaticClosure info_lbl ccs payload padding_wds
192 static_link_field saved_info_field
194 info_lbl = infoTableLabelFromCI cl_info
196 -- CAFs must have consistent layout, regardless of whether they
197 -- are actually updatable or not. The layout of a CAF is:
204 -- the static_link and saved_info fields must always be in the same
205 -- place. So we use closureNeedsUpdSpace rather than
206 -- closureUpdReqd here:
208 is_caf = closureNeedsUpdSpace cl_info
212 | otherwise = replicate n (mkIntCLit 0) -- a bunch of 0s
213 where n = max 0 (mIN_UPD_SIZE - length payload)
216 | is_caf || staticClosureNeedsLink cl_info = [static_link_value]
220 | is_caf = [mkIntCLit 0]
223 -- for a static constructor which has NoCafRefs, we set the
224 -- static link field to a non-zero value so the garbage
225 -- collector will ignore it.
227 | caf_refs = mkIntCLit 0
228 | otherwise = mkIntCLit 1
230 mkStaticClosure :: CLabel -> CostCentreStack -> [CmmLit]
231 -> [CmmLit] -> [CmmLit] -> [CmmLit] -> [CmmLit]
232 mkStaticClosure info_lbl ccs payload padding_wds static_link_field saved_info_field
233 = [CmmLabel info_lbl]
234 ++ variable_header_words
240 variable_header_words
247 %************************************************************************
249 \subsection[CgHeapery-heap-overflow]{Heap overflow checking}
251 %************************************************************************
253 The new code for heapChecks. For GrAnSim the code for doing a heap check
254 and doing a context switch has been separated. Especially, the HEAP_CHK
255 macro only performs a heap check. THREAD_CONTEXT_SWITCH should be used for
256 doing a context switch. GRAN_FETCH_AND_RESCHEDULE must be put at the
257 beginning of every slow entry code in order to simulate the fetching of
258 closures. If fetching is necessary (i.e. current closure is not local) then
259 an automatic context switch is done.
261 --------------------------------------------------------------
262 A heap/stack check at a function or thunk entry point.
265 funEntryChecks :: ClosureInfo -> CmmStmts -> Code -> Code
266 funEntryChecks cl_info reg_save_code code
267 = hpStkCheck cl_info True reg_save_code code
269 thunkEntryChecks :: ClosureInfo -> Code -> Code
270 thunkEntryChecks cl_info code
271 = hpStkCheck cl_info False noStmts code
273 hpStkCheck :: ClosureInfo -- Function closure
274 -> Bool -- Is a function? (not a thunk)
275 -> CmmStmts -- Register saves
279 hpStkCheck cl_info is_fun reg_save_code code
280 = getFinalStackHW $ \ spHw -> do
282 ; let stk_words = spHw - sp
283 ; initHeapUsage $ \ hpHw -> do
284 { -- Emit heap checks, but be sure to do it lazily so
285 -- that the conditionals on hpHw don't cause a black hole
287 { do_checks stk_words hpHw full_save_code rts_label
288 ; tickyAllocHeap hpHw }
294 | nodeMustPointToIt (closureLFInfo cl_info)
297 = oneStmt (CmmAssign nodeReg (CmmLit (CmmLabel closure_lbl)))
298 closure_lbl = closureLabelFromCI cl_info
300 full_save_code = node_asst `plusStmts` reg_save_code
302 rts_label | is_fun = CmmReg (CmmGlobal GCFun)
303 -- Function entry point
304 | otherwise = CmmReg (CmmGlobal GCEnter1)
305 -- Thunk or case return
306 -- In the thunk/case-return case, R1 points to a closure
307 -- which should be (re)-entered after GC
310 Heap checks in a case alternative are nice and easy, provided this is
311 a bog-standard algebraic case. We have in our hand:
313 * one return address, on the stack,
314 * one return value, in Node.
316 the canned code for this heap check failure just pushes Node on the
317 stack, saying 'EnterGHC' to return. The scheduler will return by
318 entering the top value on the stack, which in turn will return through
319 the return address, getting us back to where we were. This is
320 therefore only valid if the return value is *lifted* (just being
321 boxed isn't good enough).
323 For primitive returns, we have an unlifted value in some register
324 (either R1 or FloatReg1 or DblReg1). This means using specialised
325 heap-check code for these cases.
329 :: AltType -- PolyAlt, PrimAlt, AlgAlt, but *not* UbxTupAlt
330 -- (Unboxed tuples are dealt with by ubxTupleHeapCheck)
331 -> Code -- Continuation
333 altHeapCheck alt_type code
334 = initHeapUsage $ \ hpHw -> do
336 { do_checks 0 {- no stack chk -} hpHw
337 noStmts {- nothign to save -}
339 ; tickyAllocHeap hpHw }
343 rts_label PolyAlt = CmmLit (CmmLabel (mkRtsCodeLabel SLIT( "stg_gc_unpt_r1")))
344 -- Do *not* enter R1 after a heap check in
345 -- a polymorphic case. It might be a function
346 -- and the entry code for a function (currently)
349 -- However R1 is guaranteed to be a pointer
351 rts_label (AlgAlt tc) = stg_gc_enter1
352 -- Enter R1 after the heap check; it's a pointer
354 rts_label (PrimAlt tc)
355 = CmmLit $ CmmLabel $
356 case primRepToCgRep (tyConPrimRep tc) of
357 VoidArg -> mkRtsCodeLabel SLIT( "stg_gc_noregs")
358 FloatArg -> mkRtsCodeLabel SLIT( "stg_gc_f1")
359 DoubleArg -> mkRtsCodeLabel SLIT( "stg_gc_d1")
360 LongArg -> mkRtsCodeLabel SLIT( "stg_gc_l1")
361 -- R1 is boxed but unlifted:
362 PtrArg -> mkRtsCodeLabel SLIT( "stg_gc_unpt_r1")
364 NonPtrArg -> mkRtsCodeLabel SLIT( "stg_gc_unbx_r1")
366 rts_label (UbxTupAlt _) = panic "altHeapCheck"
370 Unboxed tuple alternatives and let-no-escapes (the two most annoying
371 constructs to generate code for!) For unboxed tuple returns, there
372 are an arbitrary number of possibly unboxed return values, some of
373 which will be in registers, and the others will be on the stack. We
374 always organise the stack-resident fields into pointers &
375 non-pointers, and pass the number of each to the heap check code.
379 :: [(Id, GlobalReg)] -- Live registers
380 -> WordOff -- no. of stack slots containing ptrs
381 -> WordOff -- no. of stack slots containing nonptrs
382 -> CmmStmts -- code to insert in the failure path
386 unbxTupleHeapCheck regs ptrs nptrs fail_code code
387 -- We can't manage more than 255 pointers/non-pointers
388 -- in a generic heap check.
389 | ptrs > 255 || nptrs > 255 = panic "altHeapCheck"
391 = initHeapUsage $ \ hpHw -> do
392 { codeOnly $ do { do_checks 0 {- no stack check -} hpHw
393 full_fail_code rts_label
394 ; tickyAllocHeap hpHw }
398 full_fail_code = fail_code `plusStmts` oneStmt assign_liveness
399 assign_liveness = CmmAssign (CmmGlobal (VanillaReg 9)) -- Ho ho ho!
400 (CmmLit (mkWordCLit liveness))
401 liveness = mkRegLiveness regs ptrs nptrs
402 rts_label = CmmLit (CmmLabel (mkRtsCodeLabel SLIT("stg_gc_ut")))
407 %************************************************************************
411 %************************************************************************
413 When failing a check, we save a return address on the stack and
414 jump to a pre-compiled code fragment that saves the live registers
415 and returns to the scheduler.
417 The return address in most cases will be the beginning of the basic
418 block in which the check resides, since we need to perform the check
419 again on re-entry because someone else might have stolen the resource
423 do_checks :: WordOff -- Stack headroom
424 -> WordOff -- Heap headroom
425 -> CmmStmts -- Assignments to perform on failure
426 -> CmmExpr -- Rts address to jump to on failure
428 do_checks 0 0 _ _ = nopC
429 do_checks stk hp reg_save_code rts_lbl
430 = do_checks' (CmmLit (mkIntCLit (stk*wORD_SIZE)))
431 (CmmLit (mkIntCLit (hp*wORD_SIZE)))
432 (stk /= 0) (hp /= 0) reg_save_code rts_lbl
434 -- The offsets are now in *bytes*
435 do_checks' stk_expr hp_expr stk_nonzero hp_nonzero reg_save_code rts_lbl
436 = do { doGranAllocate hp_expr
438 -- Emit a block for the heap-check-failure code
439 ; blk_id <- forkLabelledCode $ do
441 stmtC (CmmAssign (CmmGlobal HpAlloc) hp_expr)
442 ; emitStmts reg_save_code
443 ; stmtC (CmmJump rts_lbl []) }
445 -- Check for stack overflow *FIRST*; otherwise
446 -- we might bumping Hp and then failing stack oflo
448 (stmtC (CmmCondBranch stk_oflo blk_id))
451 (stmtsC [CmmAssign hpReg
452 (cmmOffsetExprB (CmmReg hpReg) hp_expr),
453 CmmCondBranch hp_oflo blk_id])
454 -- Bump heap pointer, and test for heap exhaustion
455 -- Note that we don't move the heap pointer unless the
456 -- stack check succeeds. Otherwise we might end up
457 -- with slop at the end of the current block, which can
458 -- confuse the LDV profiler.
461 -- Stk overflow if (Sp - stk_bytes < SpLim)
462 stk_oflo = CmmMachOp mo_wordULt
463 [CmmMachOp mo_wordSub [CmmReg spReg, stk_expr],
464 CmmReg (CmmGlobal SpLim)]
466 -- Hp overflow if (Hpp > HpLim)
467 -- (Hp has been incremented by now)
468 -- HpLim points to the LAST WORD of valid allocation space.
469 hp_oflo = CmmMachOp mo_wordUGt
470 [CmmReg hpReg, CmmReg (CmmGlobal HpLim)]
473 %************************************************************************
475 Generic Heap/Stack Checks - used in the RTS
477 %************************************************************************
480 hpChkGen :: CmmExpr -> CmmExpr -> CmmExpr -> Code
481 hpChkGen bytes liveness reentry
482 = do_checks' (CmmLit (mkIntCLit 0)) bytes False True assigns stg_gc_gen
485 CmmAssign (CmmGlobal (VanillaReg 9)) liveness,
486 CmmAssign (CmmGlobal (VanillaReg 10)) reentry
489 -- a heap check where R1 points to the closure to enter on return, and
490 -- we want to assign to Sp[0] on failure (used in AutoApply.cmm:BUILD_PAP).
491 hpChkNodePointsAssignSp0 :: CmmExpr -> CmmExpr -> Code
492 hpChkNodePointsAssignSp0 bytes sp0
493 = do_checks' (CmmLit (mkIntCLit 0)) bytes False True assign stg_gc_enter1
494 where assign = oneStmt (CmmStore (CmmReg spReg) sp0)
496 stkChkGen :: CmmExpr -> CmmExpr -> CmmExpr -> Code
497 stkChkGen bytes liveness reentry
498 = do_checks' bytes (CmmLit (mkIntCLit 0)) True False assigns stg_gc_gen
501 CmmAssign (CmmGlobal (VanillaReg 9)) liveness,
502 CmmAssign (CmmGlobal (VanillaReg 10)) reentry
505 stkChkNodePoints :: CmmExpr -> Code
506 stkChkNodePoints bytes
507 = do_checks' bytes (CmmLit (mkIntCLit 0)) True False noStmts stg_gc_enter1
509 stg_gc_gen = CmmLit (CmmLabel (mkRtsCodeLabel SLIT("stg_gc_gen")))
510 stg_gc_enter1 = CmmReg (CmmGlobal GCEnter1)
513 %************************************************************************
515 \subsection[initClosure]{Initialise a dynamic closure}
517 %************************************************************************
519 @allocDynClosure@ puts the thing in the heap, and modifies the virtual Hp
525 -> CmmExpr -- Cost Centre to stick in the object
526 -> CmmExpr -- Cost Centre to blame for this alloc
527 -- (usually the same; sometimes "OVERHEAD")
529 -> [(CmmExpr, VirtualHpOffset)] -- Offsets from start of the object
530 -- ie Info ptr has offset zero.
531 -> FCode VirtualHpOffset -- Returns virt offset of object
533 allocDynClosure cl_info use_cc blame_cc amodes_with_offsets
534 = do { virt_hp <- getVirtHp
536 -- FIND THE OFFSET OF THE INFO-PTR WORD
537 ; let info_offset = virt_hp + 1
538 -- info_offset is the VirtualHpOffset of the first
539 -- word of the new object
540 -- Remember, virtHp points to last allocated word,
541 -- ie 1 *before* the info-ptr word of new object.
543 info_ptr = CmmLit (CmmLabel (infoTableLabelFromCI cl_info))
544 hdr_w_offsets = initDynHdr info_ptr use_cc `zip` [0..]
546 -- SAY WHAT WE ARE ABOUT TO DO
547 ; profDynAlloc cl_info use_cc
548 -- ToDo: This is almost certainly wrong
549 -- We're ignoring blame_cc. But until we've
550 -- fixed the boxing hack in chooseDynCostCentres etc,
551 -- we're worried about making things worse by "fixing"
552 -- this part to use blame_cc!
554 ; tickyDynAlloc cl_info
556 -- ALLOCATE THE OBJECT
557 ; base <- getHpRelOffset info_offset
558 ; hpStore base (hdr_w_offsets ++ amodes_with_offsets)
560 -- BUMP THE VIRTUAL HEAP POINTER
561 ; setVirtHp (virt_hp + closureSize cl_info)
563 -- RETURN PTR TO START OF OBJECT
564 ; returnFC info_offset }
567 initDynHdr :: CmmExpr
568 -> CmmExpr -- Cost centre to put in object
570 initDynHdr info_ptr cc
572 -- ToDo: Gransim stuff
573 -- ToDo: Parallel stuff
577 hpStore :: CmmExpr -> [(CmmExpr, VirtualHpOffset)] -> Code
578 -- Store the item (expr,off) in base[off]
580 = stmtsC [ CmmStore (cmmOffsetW base off) val
583 emitSetDynHdr :: CmmExpr -> CmmExpr -> CmmExpr -> Code
584 emitSetDynHdr base info_ptr ccs
585 = hpStore base (zip (initDynHdr info_ptr ccs) [0..])