%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
-% $Id: CgHeapery.lhs,v 1.29 2001/12/12 12:19:11 simonmar Exp $
+% $Id: CgHeapery.lhs,v 1.47 2005/06/21 10:44:41 simonmar Exp $
%
\section[CgHeapery]{Heap management functions}
\begin{code}
module CgHeapery (
- fastEntryChecks, altHeapCheck, thunkChecks,
- allocDynClosure, inPlaceAllocDynClosure
+ initHeapUsage, getVirtHp, setVirtHp, setRealHp,
+ getHpRelOffset, hpRel,
- -- new functions, basically inserting macro calls into Code -- HWL
- ,fetchAndReschedule, yield
+ funEntryChecks, thunkEntryChecks,
+ altHeapCheck, unbxTupleHeapCheck,
+ hpChkGen, hpChkNodePointsAssignSp0,
+ stkChkGen, stkChkNodePoints,
+
+ layOutDynConstr, layOutStaticConstr,
+ mkVirtHeapOffsets, mkStaticClosureFields, mkStaticClosure,
+
+ allocDynClosure, emitSetDynHdr
) where
#include "HsVersions.h"
-import AbsCSyn
-import CLabel
+import StgSyn ( AltType(..) )
+import CLabel ( CLabel, mkRtsCodeLabel )
+import CgUtils ( mkWordCLit, cmmRegOffW, cmmOffsetW,
+ cmmOffsetExprB )
import CgMonad
-
-import CgStackery ( getFinalStackHW, mkTaggedStkAmodes, mkTagAssts )
-import AbsCUtils ( mkAbstractCs, getAmodeRep )
-import CgUsages ( getVirtAndRealHp, getRealSp, setVirtHp, setRealHp,
- initHeapUsage
- )
-import ClosureInfo ( closureSize, closureGoodStuffSize,
- slopSize, allocProfilingMsg, ClosureInfo
- )
-import PrimRep ( PrimRep(..), isFollowableRep )
-import Unique ( Unique )
-import CmdLineOpts ( opt_SccProfilingOn, opt_GranMacros )
-import GlaExts
+import CgProf ( staticProfHdr, profDynAlloc, dynProfHdr )
+import CgTicky ( staticTickyHdr, tickyDynAlloc, tickyAllocHeap )
+import CgParallel ( staticGranHdr, staticParHdr, doGranAllocate )
+import CgStackery ( getFinalStackHW, getRealSp )
+import CgCallConv ( mkRegLiveness )
+import ClosureInfo ( closureSize, staticClosureNeedsLink,
+ mkConInfo, closureNeedsUpdSpace,
+ infoTableLabelFromCI, closureLabelFromCI,
+ nodeMustPointToIt, closureLFInfo,
+ ClosureInfo )
+import SMRep ( CgRep(..), cgRepSizeW, separateByPtrFollowness,
+ WordOff, fixedHdrSize, thunkHdrSize,
+ isVoidArg, primRepToCgRep )
+
+import Cmm ( CmmLit(..), CmmStmt(..), CmmExpr(..), GlobalReg(..),
+ CmmReg(..), hpReg, nodeReg, spReg )
+import MachOp ( mo_wordULt, mo_wordUGt, mo_wordSub )
+import CmmUtils ( mkIntCLit, CmmStmts, noStmts, oneStmt, plusStmts,
+ mkStmts )
+import Id ( Id )
+import DataCon ( DataCon )
+import TyCon ( tyConPrimRep )
+import CostCentre ( CostCentreStack )
+import Util ( mapAccumL, filterOut )
+import Constants ( wORD_SIZE )
+import Packages ( HomeModules )
import Outputable
-#ifdef DEBUG
-import PprAbsC ( pprMagicId ) -- tmp
-#endif
\end{code}
+
%************************************************************************
%* *
-\subsection[CgHeapery-heap-overflow]{Heap overflow checking}
+\subsection[CgUsages-heapery]{Monad things for fiddling with heap usage}
%* *
%************************************************************************
-The new code for heapChecks. For GrAnSim the code for doing a heap check
-and doing a context switch has been separated. Especially, the HEAP_CHK
-macro only performs a heap check. THREAD_CONTEXT_SWITCH should be used for
-doing a context switch. GRAN_FETCH_AND_RESCHEDULE must be put at the
-beginning of every slow entry code in order to simulate the fetching of
-closures. If fetching is necessary (i.e. current closure is not local) then
-an automatic context switch is done.
+The heap always grows upwards, so hpRel is easy
------------------------------------------------------------------------------
-A heap/stack check at a fast entry point.
+\begin{code}
+hpRel :: VirtualHpOffset -- virtual offset of Hp
+ -> VirtualHpOffset -- virtual offset of The Thing
+ -> WordOff -- integer word offset
+hpRel hp off = off - hp
+\end{code}
+
+@initHeapUsage@ applies a function to the amount of heap that it uses.
+It initialises the heap usage to zeros, and passes on an unchanged
+heap usage.
+
+It is usually a prelude to performing a GC check, so everything must
+be in a tidy and consistent state.
+
+rje: Note the slightly suble fixed point behaviour needed here
\begin{code}
+initHeapUsage :: (VirtualHpOffset -> Code) -> Code
+initHeapUsage fcode
+ = do { orig_hp_usage <- getHpUsage
+ ; setHpUsage initHpUsage
+ ; fixC (\heap_usage2 -> do
+ { fcode (heapHWM heap_usage2)
+ ; getHpUsage })
+ ; setHpUsage orig_hp_usage }
+
+setVirtHp :: VirtualHpOffset -> Code
+setVirtHp new_virtHp
+ = do { hp_usage <- getHpUsage
+ ; setHpUsage (hp_usage {virtHp = new_virtHp}) }
+
+getVirtHp :: FCode VirtualHpOffset
+getVirtHp
+ = do { hp_usage <- getHpUsage
+ ; return (virtHp hp_usage) }
+
+setRealHp :: VirtualHpOffset -> Code
+setRealHp new_realHp
+ = do { hp_usage <- getHpUsage
+ ; setHpUsage (hp_usage {realHp = new_realHp}) }
+
+getHpRelOffset :: VirtualHpOffset -> FCode CmmExpr
+getHpRelOffset virtual_offset
+ = do { hp_usg <- getHpUsage
+ ; return (cmmRegOffW hpReg (hpRel (realHp hp_usg) virtual_offset)) }
+\end{code}
-fastEntryChecks
- :: [MagicId] -- Live registers
- -> [(VirtualSpOffset,Int)] -- stack slots to tag
- -> CLabel -- return point
- -> Bool -- node points to closure
- -> Code
- -> Code
-fastEntryChecks regs tags ret node_points code
- = mkTagAssts tags `thenFC` \tag_assts ->
- getFinalStackHW (\ spHw ->
- getRealSp `thenFC` \ sp ->
- let stk_words = spHw - sp in
- initHeapUsage (\ hHw ->
+%************************************************************************
+%* *
+ Layout of heap objects
+%* *
+%************************************************************************
+
+\begin{code}
+layOutDynConstr, layOutStaticConstr
+ :: HomeModules
+ -> DataCon
+ -> [(CgRep,a)]
+ -> (ClosureInfo,
+ [(a,VirtualHpOffset)])
+
+layOutDynConstr = layOutConstr False
+layOutStaticConstr = layOutConstr True
+
+layOutConstr is_static hmods data_con args
+ = (mkConInfo hmods is_static data_con tot_wds ptr_wds,
+ things_w_offsets)
+ where
+ (tot_wds, -- #ptr_wds + #nonptr_wds
+ ptr_wds, -- #ptr_wds
+ things_w_offsets) = mkVirtHeapOffsets False{-not a thunk-} args
+\end{code}
- getTickyCtrLabel `thenFC` \ ticky_ctr ->
+@mkVirtHeapOffsets@ always returns boxed things with smaller offsets
+than the unboxed things, and furthermore, the offsets in the result
+list
- ( if all_pointers then -- heap checks are quite easy
- -- HWL: gran-yield immediately before heap check proper
- --(if node `elem` regs
- -- then yield regs True
- -- else absC AbsCNop ) `thenC`
- absC (checking_code stk_words hHw tag_assts
- free_reg (length regs) ticky_ctr)
+\begin{code}
+mkVirtHeapOffsets
+ :: Bool -- True <=> is a thunk
+ -> [(CgRep,a)] -- Things to make offsets for
+ -> (WordOff, -- _Total_ number of words allocated
+ WordOff, -- Number of words allocated for *pointers*
+ [(a, VirtualHpOffset)])
+ -- Things with their offsets from start of
+ -- object in order of increasing offset
+
+-- First in list gets lowest offset, which is initial offset + 1.
+
+mkVirtHeapOffsets is_thunk things
+ = let non_void_things = filterOut (isVoidArg . fst) things
+ (ptrs, non_ptrs) = separateByPtrFollowness non_void_things
+ (wds_of_ptrs, ptrs_w_offsets) = mapAccumL computeOffset 0 ptrs
+ (tot_wds, non_ptrs_w_offsets) = mapAccumL computeOffset wds_of_ptrs non_ptrs
+ in
+ (tot_wds, wds_of_ptrs, ptrs_w_offsets ++ non_ptrs_w_offsets)
+ where
+ hdr_size | is_thunk = thunkHdrSize
+ | otherwise = fixedHdrSize
- else -- they are complicated
+ computeOffset wds_so_far (rep, thing)
+ = (wds_so_far + cgRepSizeW rep, (thing, hdr_size + wds_so_far))
+\end{code}
- -- save all registers on the stack and adjust the stack pointer.
- -- ToDo: find the initial all-pointer segment and don't save them.
- mkTaggedStkAmodes sp addrmode_regs
- `thenFC` \(new_sp, stk_assts, more_tag_assts) ->
+%************************************************************************
+%* *
+ Lay out a static closure
+%* *
+%************************************************************************
- -- only let the extra stack assignments affect the stack
- -- high water mark if we were doing a stack check anyway;
- -- otherwise we end up generating unnecessary stack checks.
- -- Careful about knot-tying loops!
- let real_stk_words = if new_sp - sp > stk_words && stk_words /= 0
- then new_sp - sp
- else stk_words
- in
+Make a static closure, adding on any extra padding needed for CAFs,
+and adding a static link field if necessary.
- let adjust_sp = CAssign (CReg Sp) (CAddr (spRel sp new_sp)) in
+\begin{code}
+mkStaticClosureFields
+ :: ClosureInfo
+ -> CostCentreStack
+ -> Bool -- Has CAF refs
+ -> [CmmLit] -- Payload
+ -> [CmmLit] -- The full closure
+mkStaticClosureFields cl_info ccs caf_refs payload
+ = mkStaticClosure info_lbl ccs payload padding_wds
+ static_link_field saved_info_field
+ where
+ info_lbl = infoTableLabelFromCI cl_info
+
+ -- CAFs must have consistent layout, regardless of whether they
+ -- are actually updatable or not. The layout of a CAF is:
+ --
+ -- 3 saved_info
+ -- 2 static_link
+ -- 1 indirectee
+ -- 0 info ptr
+ --
+ -- the static_link and saved_info fields must always be in the same
+ -- place. So we use closureNeedsUpdSpace rather than
+ -- closureUpdReqd here:
+
+ is_caf = closureNeedsUpdSpace cl_info
+
+ padding_wds
+ | not is_caf = []
+ | otherwise = ASSERT(null payload) [mkIntCLit 0]
+
+ static_link_field
+ | is_caf || staticClosureNeedsLink cl_info = [static_link_value]
+ | otherwise = []
+
+ saved_info_field
+ | is_caf = [mkIntCLit 0]
+ | otherwise = []
+
+ -- for a static constructor which has NoCafRefs, we set the
+ -- static link field to a non-zero value so the garbage
+ -- collector will ignore it.
+ static_link_value
+ | caf_refs = mkIntCLit 0
+ | otherwise = mkIntCLit 1
+
+
+mkStaticClosure :: CLabel -> CostCentreStack -> [CmmLit]
+ -> [CmmLit] -> [CmmLit] -> [CmmLit] -> [CmmLit]
+mkStaticClosure info_lbl ccs payload padding_wds static_link_field saved_info_field
+ = [CmmLabel info_lbl]
+ ++ variable_header_words
+ ++ payload
+ ++ padding_wds
+ ++ static_link_field
+ ++ saved_info_field
+ where
+ variable_header_words
+ = staticGranHdr
+ ++ staticParHdr
+ ++ staticProfHdr ccs
+ ++ staticTickyHdr
+\end{code}
- absC (checking_code real_stk_words hHw
- (mkAbstractCs [tag_assts, stk_assts, more_tag_assts,
- adjust_sp])
- (CReg node) 0 ticky_ctr)
+%************************************************************************
+%* *
+\subsection[CgHeapery-heap-overflow]{Heap overflow checking}
+%* *
+%************************************************************************
- ) `thenC`
+The new code for heapChecks. For GrAnSim the code for doing a heap check
+and doing a context switch has been separated. Especially, the HEAP_CHK
+macro only performs a heap check. THREAD_CONTEXT_SWITCH should be used for
+doing a context switch. GRAN_FETCH_AND_RESCHEDULE must be put at the
+beginning of every slow entry code in order to simulate the fetching of
+closures. If fetching is necessary (i.e. current closure is not local) then
+an automatic context switch is done.
- setRealHp hHw `thenC`
- code))
+--------------------------------------------------------------
+A heap/stack check at a function or thunk entry point.
+\begin{code}
+funEntryChecks :: ClosureInfo -> CmmStmts -> Code -> Code
+funEntryChecks cl_info reg_save_code code
+ = hpStkCheck cl_info True reg_save_code code
+
+thunkEntryChecks :: ClosureInfo -> Code -> Code
+thunkEntryChecks cl_info code
+ = hpStkCheck cl_info False noStmts code
+
+hpStkCheck :: ClosureInfo -- Function closure
+ -> Bool -- Is a function? (not a thunk)
+ -> CmmStmts -- Register saves
+ -> Code
+ -> Code
+
+hpStkCheck cl_info is_fun reg_save_code code
+ = getFinalStackHW $ \ spHw -> do
+ { sp <- getRealSp
+ ; let stk_words = spHw - sp
+ ; initHeapUsage $ \ hpHw -> do
+ { -- Emit heap checks, but be sure to do it lazily so
+ -- that the conditionals on hpHw don't cause a black hole
+ codeOnly $ do
+ { do_checks stk_words hpHw full_save_code rts_label
+ ; tickyAllocHeap hpHw }
+ ; setRealHp hpHw
+ ; code }
+ }
where
-
- checking_code stk hp assts ret regs ctr
- = mkAbstractCs
- [ real_check,
- if hp == 0 then AbsCNop
- else profCtrAbsC SLIT("TICK_ALLOC_HEAP")
- [ mkIntCLit hp, CLbl ctr DataPtrRep ]
- ]
-
- where real_check
- | node_points = do_checks_np stk hp assts (regs+1)
- | otherwise = do_checks stk hp assts ret regs
-
- -- When node points to the closure for the function:
-
- do_checks_np
- :: Int -- stack headroom
- -> Int -- heap headroom
- -> AbstractC -- assignments to perform on failure
- -> Int -- number of pointer registers live
- -> AbstractC
- do_checks_np 0 0 _ _ = AbsCNop
- do_checks_np 0 hp_words tag_assts ptrs =
- CCheck HP_CHK_NP [
- mkIntCLit hp_words,
- mkIntCLit ptrs
- ]
- tag_assts
- do_checks_np stk_words 0 tag_assts ptrs =
- CCheck STK_CHK_NP [
- mkIntCLit stk_words,
- mkIntCLit ptrs
- ]
- tag_assts
- do_checks_np stk_words hp_words tag_assts ptrs =
- CCheck HP_STK_CHK_NP [
- mkIntCLit stk_words,
- mkIntCLit hp_words,
- mkIntCLit ptrs
- ]
- tag_assts
-
- -- When node doesn't point to the closure (we need an explicit retn addr)
-
- do_checks
- :: Int -- stack headroom
- -> Int -- heap headroom
- -> AbstractC -- assignments to perform on failure
- -> CAddrMode -- a register to hold the retn addr.
- -> Int -- number of pointer registers live
- -> AbstractC
-
- do_checks 0 0 _ _ _ = AbsCNop
- do_checks 0 hp_words tag_assts ret_reg ptrs =
- CCheck HP_CHK [
- mkIntCLit hp_words,
- CLbl ret CodePtrRep,
- ret_reg,
- mkIntCLit ptrs
- ]
- tag_assts
- do_checks stk_words 0 tag_assts ret_reg ptrs =
- CCheck STK_CHK [
- mkIntCLit stk_words,
- CLbl ret CodePtrRep,
- ret_reg,
- mkIntCLit ptrs
- ]
- tag_assts
- do_checks stk_words hp_words tag_assts ret_reg ptrs =
- CCheck HP_STK_CHK [
- mkIntCLit stk_words,
- mkIntCLit hp_words,
- CLbl ret CodePtrRep,
- ret_reg,
- mkIntCLit ptrs
- ]
- tag_assts
-
- free_reg = case length regs + 1 of
- I# x -> CReg (VanillaReg PtrRep x)
-
- all_pointers = all pointer regs
- pointer (VanillaReg rep _) = isFollowableRep rep
- pointer _ = False
-
- addrmode_regs = map CReg regs
-
--- Checking code for thunks is just a special case of fast entry points:
-
-thunkChecks :: CLabel -> Bool -> Code -> Code
-thunkChecks ret node_points code = fastEntryChecks [] [] ret node_points code
+ node_asst
+ | nodeMustPointToIt (closureLFInfo cl_info)
+ = noStmts
+ | otherwise
+ = oneStmt (CmmAssign nodeReg (CmmLit (CmmLabel closure_lbl)))
+ closure_lbl = closureLabelFromCI cl_info
+
+ full_save_code = node_asst `plusStmts` reg_save_code
+
+ rts_label | is_fun = CmmReg (CmmGlobal GCFun)
+ -- Function entry point
+ | otherwise = CmmReg (CmmGlobal GCEnter1)
+ -- Thunk or case return
+ -- In the thunk/case-return case, R1 points to a closure
+ -- which should be (re)-entered after GC
\end{code}
Heap checks in a case alternative are nice and easy, provided this is
entering the top value on the stack, which in turn will return through
the return address, getting us back to where we were. This is
therefore only valid if the return value is *lifted* (just being
-boxed isn't good enough). Only a PtrRep will do.
+boxed isn't good enough).
For primitive returns, we have an unlifted value in some register
(either R1 or FloatReg1 or DblReg1). This means using specialised
heap-check code for these cases.
-For unboxed tuple returns, there are an arbitrary number of possibly
-unboxed return values, some of which will be in registers, and the
-others will be on the stack, with gaps left for tagging the unboxed
-objects. If a heap check is required, we need to fill in these tags.
+\begin{code}
+altHeapCheck
+ :: AltType -- PolyAlt, PrimAlt, AlgAlt, but *not* UbxTupAlt
+ -- (Unboxed tuples are dealt with by ubxTupleHeapCheck)
+ -> Code -- Continuation
+ -> Code
+altHeapCheck alt_type code
+ = initHeapUsage $ \ hpHw -> do
+ { codeOnly $ do
+ { do_checks 0 {- no stack chk -} hpHw
+ noStmts {- nothign to save -}
+ (rts_label alt_type)
+ ; tickyAllocHeap hpHw }
+ ; setRealHp hpHw
+ ; code }
+ where
+ rts_label PolyAlt = CmmLit (CmmLabel (mkRtsCodeLabel SLIT( "stg_gc_unpt_r1")))
+ -- Do *not* enter R1 after a heap check in
+ -- a polymorphic case. It might be a function
+ -- and the entry code for a function (currently)
+ -- applies it
+ --
+ -- However R1 is guaranteed to be a pointer
+
+ rts_label (AlgAlt tc) = stg_gc_enter1
+ -- Enter R1 after the heap check; it's a pointer
+
+ rts_label (PrimAlt tc)
+ = CmmLit $ CmmLabel $
+ case primRepToCgRep (tyConPrimRep tc) of
+ VoidArg -> mkRtsCodeLabel SLIT( "stg_gc_noregs")
+ FloatArg -> mkRtsCodeLabel SLIT( "stg_gc_f1")
+ DoubleArg -> mkRtsCodeLabel SLIT( "stg_gc_d1")
+ LongArg -> mkRtsCodeLabel SLIT( "stg_gc_l1")
+ -- R1 is boxed but unlifted:
+ PtrArg -> mkRtsCodeLabel SLIT( "stg_gc_unpt_r1")
+ -- R1 is unboxed:
+ NonPtrArg -> mkRtsCodeLabel SLIT( "stg_gc_unbx_r1")
+
+ rts_label (UbxTupAlt _) = panic "altHeapCheck"
+\end{code}
+
-The code below will cover all cases for the x86 architecture (where R1
-is the only VanillaReg ever used). For other architectures, we'll
-have to do something about saving and restoring the other registers.
+Unboxed tuple alternatives and let-no-escapes (the two most annoying
+constructs to generate code for!) For unboxed tuple returns, there
+are an arbitrary number of possibly unboxed return values, some of
+which will be in registers, and the others will be on the stack. We
+always organise the stack-resident fields into pointers &
+non-pointers, and pass the number of each to the heap check code.
\begin{code}
-altHeapCheck
- :: Bool -- is an algebraic alternative
- -> [MagicId] -- live registers
- -> [(VirtualSpOffset,Int)] -- stack slots to tag
- -> AbstractC
- -> Maybe Unique -- uniq of ret address (possibly)
+unbxTupleHeapCheck
+ :: [(Id, GlobalReg)] -- Live registers
+ -> WordOff -- no. of stack slots containing ptrs
+ -> WordOff -- no. of stack slots containing nonptrs
+ -> CmmStmts -- code to insert in the failure path
-> Code
-> Code
--- unboxed tuple alternatives and let-no-escapes (the two most annoying
--- constructs to generate code for!):
-
-altHeapCheck is_fun regs tags fail_code (Just ret_addr) code
- = mkTagAssts tags `thenFC` \tag_assts1 ->
- let tag_assts = mkAbstractCs [fail_code, tag_assts1]
- in
- initHeapUsage (\ hHw -> do_heap_chk hHw tag_assts `thenC` code)
+unbxTupleHeapCheck regs ptrs nptrs fail_code code
+ -- We can't manage more than 255 pointers/non-pointers
+ -- in a generic heap check.
+ | ptrs > 255 || nptrs > 255 = panic "altHeapCheck"
+ | otherwise
+ = initHeapUsage $ \ hpHw -> do
+ { codeOnly $ do { do_checks 0 {- no stack check -} hpHw
+ full_fail_code rts_label
+ ; tickyAllocHeap hpHw }
+ ; setRealHp hpHw
+ ; code }
where
- do_heap_chk words_required tag_assts
- = getTickyCtrLabel `thenFC` \ ctr ->
- absC ( if words_required == 0
- then AbsCNop
- else mkAbstractCs
- [ checking_code tag_assts,
- profCtrAbsC SLIT("TICK_ALLOC_HEAP")
- [ mkIntCLit words_required, CLbl ctr DataPtrRep ]
- ]
- ) `thenC`
- setRealHp words_required
-
- where
- non_void_regs = filter (/= VoidReg) regs
-
- checking_code tag_assts =
- case non_void_regs of
-
-{- no: there might be stuff on top of the retn. addr. on the stack.
- [{-no regs-}] ->
- CCheck HP_CHK_NOREGS
- [mkIntCLit words_required]
- tag_assts
--}
- -- this will cover all cases for x86
- [VanillaReg rep 1#]
-
- | isFollowableRep rep ->
- CCheck HP_CHK_UT_ALT
- [mkIntCLit words_required, mkIntCLit 1, mkIntCLit 0,
- CReg (VanillaReg RetRep 2#),
- CLbl (mkReturnInfoLabel ret_addr) RetRep]
- tag_assts
-
- | otherwise ->
- CCheck HP_CHK_UT_ALT
- [mkIntCLit words_required, mkIntCLit 0, mkIntCLit 1,
- CReg (VanillaReg RetRep 2#),
- CLbl (mkReturnInfoLabel ret_addr) RetRep]
- tag_assts
-
- several_regs ->
- let liveness = mkRegLiveness several_regs
- in
- CCheck HP_CHK_GEN
- [mkIntCLit words_required,
- mkIntCLit (I# (word2Int# liveness)),
- -- HP_CHK_GEN needs a direct return address,
- -- not an info table (might be different if
- -- we're not assembly-mangling/tail-jumping etc.)
- CLbl (mkReturnPtLabel ret_addr) RetRep]
- tag_assts
-
--- normal algebraic and primitive case alternatives:
-
-altHeapCheck is_fun regs [] AbsCNop Nothing code
- = initHeapUsage (\ hHw -> do_heap_chk hHw `thenC` code)
+ full_fail_code = fail_code `plusStmts` oneStmt assign_liveness
+ assign_liveness = CmmAssign (CmmGlobal (VanillaReg 9)) -- Ho ho ho!
+ (CmmLit (mkWordCLit liveness))
+ liveness = mkRegLiveness regs ptrs nptrs
+ rts_label = CmmLit (CmmLabel (mkRtsCodeLabel SLIT("stg_gc_ut")))
+
+\end{code}
+
+
+%************************************************************************
+%* *
+ Heap/Stack Checks.
+%* *
+%************************************************************************
+
+When failing a check, we save a return address on the stack and
+jump to a pre-compiled code fragment that saves the live registers
+and returns to the scheduler.
+
+The return address in most cases will be the beginning of the basic
+block in which the check resides, since we need to perform the check
+again on re-entry because someone else might have stolen the resource
+in the meantime.
+
+\begin{code}
+do_checks :: WordOff -- Stack headroom
+ -> WordOff -- Heap headroom
+ -> CmmStmts -- Assignments to perform on failure
+ -> CmmExpr -- Rts address to jump to on failure
+ -> Code
+do_checks 0 0 _ _ = nopC
+do_checks stk hp reg_save_code rts_lbl
+ = do_checks' (CmmLit (mkIntCLit (stk*wORD_SIZE)))
+ (CmmLit (mkIntCLit (hp*wORD_SIZE)))
+ (stk /= 0) (hp /= 0) reg_save_code rts_lbl
+
+-- The offsets are now in *bytes*
+do_checks' stk_expr hp_expr stk_nonzero hp_nonzero reg_save_code rts_lbl
+ = do { doGranAllocate hp_expr
+
+ -- Emit a block for the heap-check-failure code
+ ; blk_id <- forkLabelledCode $ do
+ { whenC hp_nonzero $
+ stmtC (CmmAssign (CmmGlobal HpAlloc) hp_expr)
+ ; emitStmts reg_save_code
+ ; stmtC (CmmJump rts_lbl []) }
+
+ -- Check for stack overflow *FIRST*; otherwise
+ -- we might bumping Hp and then failing stack oflo
+ ; whenC stk_nonzero
+ (stmtC (CmmCondBranch stk_oflo blk_id))
+
+ ; whenC hp_nonzero
+ (stmtsC [CmmAssign hpReg
+ (cmmOffsetExprB (CmmReg hpReg) hp_expr),
+ CmmCondBranch hp_oflo blk_id])
+ -- Bump heap pointer, and test for heap exhaustion
+ -- Note that we don't move the heap pointer unless the
+ -- stack check succeeds. Otherwise we might end up
+ -- with slop at the end of the current block, which can
+ -- confuse the LDV profiler.
+ }
where
- do_heap_chk :: HeapOffset -> Code
- do_heap_chk words_required
- = getTickyCtrLabel `thenFC` \ ctr ->
- absC ( if words_required == 0
- then AbsCNop
- else mkAbstractCs
- [ checking_code,
- profCtrAbsC SLIT("TICK_ALLOC_HEAP")
- [ mkIntCLit words_required, CLbl ctr DataPtrRep ]
- ]
- ) `thenC`
- setRealHp words_required
-
- where
- non_void_regs = filter (/= VoidReg) regs
-
- checking_code =
- case non_void_regs of
-
- -- No regs live: probably a Void return
- [] ->
- CCheck HP_CHK_NOREGS [mkIntCLit words_required] AbsCNop
-
- -- The SEQ case (polymophic/function typed case branch)
- -- We need this case because the closure in Node won't return
- -- directly when we enter it (it could be a function), so the
- -- heap check code needs to push a seq frame on top of the stack.
- [VanillaReg rep 1#]
- | rep == PtrRep
- && is_fun ->
- CCheck HP_CHK_SEQ_NP
- [mkIntCLit words_required, mkIntCLit 1{-regs live-}]
- AbsCNop
-
- -- R1 is lifted (the common case)
- [VanillaReg rep 1#]
- | rep == PtrRep ->
- CCheck HP_CHK_NP
- [mkIntCLit words_required, mkIntCLit 1{-regs live-}]
- AbsCNop
-
- -- R1 is boxed, but unlifted
- | isFollowableRep rep ->
- CCheck HP_CHK_UNPT_R1 [mkIntCLit words_required] AbsCNop
-
- -- R1 is unboxed
- | otherwise ->
- CCheck HP_CHK_UNBX_R1 [mkIntCLit words_required] AbsCNop
-
- -- FloatReg1
- [FloatReg 1#] ->
- CCheck HP_CHK_F1 [mkIntCLit words_required] AbsCNop
-
- -- DblReg1
- [DoubleReg 1#] ->
- CCheck HP_CHK_D1 [mkIntCLit words_required] AbsCNop
-
- -- LngReg1
- [LongReg _ 1#] ->
- CCheck HP_CHK_L1 [mkIntCLit words_required] AbsCNop
-
-#ifdef DEBUG
- _ -> panic ("CgHeapery.altHeapCheck: unimplemented heap-check, live regs = " ++ showSDoc (sep (map pprMagicId non_void_regs)))
-#endif
-
--- build up a bitmap of the live pointer registers
-
-#if __GLASGOW_HASKELL__ >= 503
-shiftL = uncheckedShiftL#
-#else
-shiftL = shiftL#
-#endif
-
-mkRegLiveness :: [MagicId] -> Word#
-mkRegLiveness [] = int2Word# 0#
-mkRegLiveness (VanillaReg rep i : regs) | isFollowableRep rep
- = ((int2Word# 1#) `shiftL` (i -# 1#)) `or#` mkRegLiveness regs
-mkRegLiveness (_ : regs) = mkRegLiveness regs
-
--- The two functions below are only used in a GranSim setup
--- Emit macro for simulating a fetch and then reschedule
-
-fetchAndReschedule :: [MagicId] -- Live registers
- -> Bool -- Node reqd?
- -> Code
-
-fetchAndReschedule regs node_reqd =
- if (node `elem` regs || node_reqd)
- then fetch_code `thenC` reschedule_code
- else absC AbsCNop
- where
- liveness_mask = mkRegLiveness regs
- reschedule_code = absC (CMacroStmt GRAN_RESCHEDULE [
- mkIntCLit (I# (word2Int# liveness_mask)),
- mkIntCLit (if node_reqd then 1 else 0)])
-
- --HWL: generate GRAN_FETCH macro for GrAnSim
- -- currently GRAN_FETCH and GRAN_FETCH_AND_RESCHEDULE are miai
- fetch_code = absC (CMacroStmt GRAN_FETCH [])
+ -- Stk overflow if (Sp - stk_bytes < SpLim)
+ stk_oflo = CmmMachOp mo_wordULt
+ [CmmMachOp mo_wordSub [CmmReg spReg, stk_expr],
+ CmmReg (CmmGlobal SpLim)]
+
+ -- Hp overflow if (Hpp > HpLim)
+ -- (Hp has been incremented by now)
+ -- HpLim points to the LAST WORD of valid allocation space.
+ hp_oflo = CmmMachOp mo_wordUGt
+ [CmmReg hpReg, CmmReg (CmmGlobal HpLim)]
\end{code}
-The @GRAN_YIELD@ macro is taken from JSM's code for Concurrent Haskell. It
-allows to context-switch at places where @node@ is not alive (it uses the
-@Continue@ rather than the @EnterNodeCode@ function in the RTS). We emit
-this kind of macro at the beginning of the following kinds of basic bocks:
-\begin{itemize}
- \item Slow entry code where node is not alive (see @CgClosure.lhs@). Normally
- we use @fetchAndReschedule@ at a slow entry code.
- \item Fast entry code (see @CgClosure.lhs@).
- \item Alternatives in case expressions (@CLabelledCode@ structures), provided
- that they are not inlined (see @CgCases.lhs@). These alternatives will
- be turned into separate functions.
-\end{itemize}
+%************************************************************************
+%* *
+ Generic Heap/Stack Checks - used in the RTS
+%* *
+%************************************************************************
\begin{code}
-yield :: [MagicId] -- Live registers
- -> Bool -- Node reqd?
- -> Code
-
-yield regs node_reqd =
- if opt_GranMacros && node_reqd
- then yield_code
- else absC AbsCNop
- where
- liveness_mask = mkRegLiveness regs
- yield_code =
- absC (CMacroStmt GRAN_YIELD
- [mkIntCLit (I# (word2Int# liveness_mask))])
+hpChkGen :: CmmExpr -> CmmExpr -> CmmExpr -> Code
+hpChkGen bytes liveness reentry
+ = do_checks' (CmmLit (mkIntCLit 0)) bytes False True assigns stg_gc_gen
+ where
+ assigns = mkStmts [
+ CmmAssign (CmmGlobal (VanillaReg 9)) liveness,
+ CmmAssign (CmmGlobal (VanillaReg 10)) reentry
+ ]
+
+-- a heap check where R1 points to the closure to enter on return, and
+-- we want to assign to Sp[0] on failure (used in AutoApply.cmm:BUILD_PAP).
+hpChkNodePointsAssignSp0 :: CmmExpr -> CmmExpr -> Code
+hpChkNodePointsAssignSp0 bytes sp0
+ = do_checks' (CmmLit (mkIntCLit 0)) bytes False True assign stg_gc_enter1
+ where assign = oneStmt (CmmStore (CmmReg spReg) sp0)
+
+stkChkGen :: CmmExpr -> CmmExpr -> CmmExpr -> Code
+stkChkGen bytes liveness reentry
+ = do_checks' bytes (CmmLit (mkIntCLit 0)) True False assigns stg_gc_gen
+ where
+ assigns = mkStmts [
+ CmmAssign (CmmGlobal (VanillaReg 9)) liveness,
+ CmmAssign (CmmGlobal (VanillaReg 10)) reentry
+ ]
+
+stkChkNodePoints :: CmmExpr -> Code
+stkChkNodePoints bytes
+ = do_checks' bytes (CmmLit (mkIntCLit 0)) True False noStmts stg_gc_enter1
+
+stg_gc_gen = CmmLit (CmmLabel (mkRtsCodeLabel SLIT("stg_gc_gen")))
+stg_gc_enter1 = CmmReg (CmmGlobal GCEnter1)
\end{code}
%************************************************************************
\begin{code}
allocDynClosure
:: ClosureInfo
- -> CAddrMode -- Cost Centre to stick in the object
- -> CAddrMode -- Cost Centre to blame for this alloc
+ -> CmmExpr -- Cost Centre to stick in the object
+ -> CmmExpr -- Cost Centre to blame for this alloc
-- (usually the same; sometimes "OVERHEAD")
- -> [(CAddrMode, VirtualHeapOffset)] -- Offsets from start of the object
- -- ie Info ptr has offset zero.
- -> FCode VirtualHeapOffset -- Returns virt offset of object
+ -> [(CmmExpr, VirtualHpOffset)] -- Offsets from start of the object
+ -- ie Info ptr has offset zero.
+ -> FCode VirtualHpOffset -- Returns virt offset of object
-allocDynClosure closure_info use_cc blame_cc amodes_with_offsets
- = getVirtAndRealHp `thenFC` \ (virtHp, realHp) ->
+allocDynClosure cl_info use_cc blame_cc amodes_with_offsets
+ = do { virt_hp <- getVirtHp
-- FIND THE OFFSET OF THE INFO-PTR WORD
- -- virtHp points to last allocated word, ie 1 *before* the
- -- info-ptr word of new object.
- let info_offset = virtHp + 1
-
- -- do_move IS THE ASSIGNMENT FUNCTION
- do_move (amode, offset_from_start)
- = CAssign (CVal (hpRel realHp
- (info_offset + offset_from_start))
- (getAmodeRep amode))
- amode
- in
- -- SAY WHAT WE ARE ABOUT TO DO
- profCtrC (allocProfilingMsg closure_info)
- [mkIntCLit (closureGoodStuffSize closure_info),
- mkIntCLit slop_size] `thenC`
-
- -- GENERATE THE CODE
- absC ( mkAbstractCs (
- [ CInitHdr closure_info
- (CAddr (hpRel realHp info_offset))
- use_cc closure_size ]
- ++ (map do_move amodes_with_offsets))) `thenC`
+ ; let info_offset = virt_hp + 1
+ -- info_offset is the VirtualHpOffset of the first
+ -- word of the new object
+ -- Remember, virtHp points to last allocated word,
+ -- ie 1 *before* the info-ptr word of new object.
- -- BUMP THE VIRTUAL HEAP POINTER
- setVirtHp (virtHp + closure_size) `thenC`
+ info_ptr = CmmLit (CmmLabel (infoTableLabelFromCI cl_info))
+ hdr_w_offsets = initDynHdr info_ptr use_cc `zip` [0..]
- -- RETURN PTR TO START OF OBJECT
- returnFC info_offset
- where
- closure_size = closureSize closure_info
- slop_size = slopSize closure_info
-\end{code}
-
-Occasionally we can update a closure in place instead of allocating
-new space for it. This is the function that does the business, assuming:
-
- - node points to the closure to be overwritten
-
- - the new closure doesn't contain any pointers if we're
- using a generational collector.
+ -- SAY WHAT WE ARE ABOUT TO DO
+ ; profDynAlloc cl_info use_cc
+ -- ToDo: This is almost certainly wrong
+ -- We're ignoring blame_cc. But until we've
+ -- fixed the boxing hack in chooseDynCostCentres etc,
+ -- we're worried about making things worse by "fixing"
+ -- this part to use blame_cc!
-\begin{code}
-inPlaceAllocDynClosure
- :: ClosureInfo
- -> CAddrMode -- Pointer to beginning of closure
- -> CAddrMode -- Cost Centre to stick in the object
+ ; tickyDynAlloc cl_info
- -> [(CAddrMode, VirtualHeapOffset)] -- Offsets from start of the object
- -- ie Info ptr has offset zero.
- -> Code
+ -- ALLOCATE THE OBJECT
+ ; base <- getHpRelOffset info_offset
+ ; hpStore base (hdr_w_offsets ++ amodes_with_offsets)
-inPlaceAllocDynClosure closure_info head use_cc amodes_with_offsets
- = let -- do_move IS THE ASSIGNMENT FUNCTION
- do_move (amode, offset_from_start)
- = CAssign (CVal (CIndex head (mkIntCLit offset_from_start) WordRep)
- (getAmodeRep amode))
- amode
- in
- -- GENERATE THE CODE
- absC ( mkAbstractCs (
- [ CInitHdr closure_info head use_cc 0{-no alloc-} ]
- ++ (map do_move amodes_with_offsets)))
+ -- BUMP THE VIRTUAL HEAP POINTER
+ ; setVirtHp (virt_hp + closureSize cl_info)
+
+ -- RETURN PTR TO START OF OBJECT
+ ; returnFC info_offset }
+
+
+initDynHdr :: CmmExpr
+ -> CmmExpr -- Cost centre to put in object
+ -> [CmmExpr]
+initDynHdr info_ptr cc
+ = [info_ptr]
+ -- ToDo: Gransim stuff
+ -- ToDo: Parallel stuff
+ ++ dynProfHdr cc
+ -- No ticky header
+
+hpStore :: CmmExpr -> [(CmmExpr, VirtualHpOffset)] -> Code
+-- Store the item (expr,off) in base[off]
+hpStore base es
+ = stmtsC [ CmmStore (cmmOffsetW base off) val
+ | (val, off) <- es ]
+
+emitSetDynHdr :: CmmExpr -> CmmExpr -> CmmExpr -> Code
+emitSetDynHdr base info_ptr ccs
+ = hpStore base (zip (initDynHdr info_ptr ccs) [0..])
\end{code}
projects / ghc-hetmet.git / blobdiff