%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
-% $Id: CgHeapery.lhs,v 1.15 1999/03/08 17:05:41 simonm Exp $
+% $Id: CgHeapery.lhs,v 1.39 2003/07/28 16:05:35 simonmar Exp $
%
\section[CgHeapery]{Heap management functions}
\begin{code}
module CgHeapery (
- fastEntryChecks, altHeapCheck, thunkChecks,
- allocDynClosure
+ funEntryChecks, altHeapCheck, unbxTupleHeapCheck, thunkChecks,
+ allocDynClosure,
-- new functions, basically inserting macro calls into Code -- HWL
,fetchAndReschedule, yield
#include "HsVersions.h"
import AbsCSyn
+import StgSyn ( AltType(..) )
import CLabel
import CgMonad
-
-import CgStackery ( getFinalStackHW, mkTaggedStkAmodes, mkTagAssts )
-import SMRep ( fixedHdrSize )
+import CgStackery ( getFinalStackHW )
import AbsCUtils ( mkAbstractCs, getAmodeRep )
import CgUsages ( getVirtAndRealHp, getRealSp, setVirtHp, setRealHp,
initHeapUsage
)
+import CgRetConv ( dataReturnConvPrim )
import ClosureInfo ( closureSize, closureGoodStuffSize,
- slopSize, allocProfilingMsg, ClosureInfo,
- closureSMRep
+ slopSize, allocProfilingMsg, ClosureInfo
)
+import TyCon ( tyConPrimRep )
import PrimRep ( PrimRep(..), isFollowableRep )
-import CmdLineOpts ( opt_SccProfilingOn )
-import GlaExts
+import CmdLineOpts ( opt_GranMacros )
import Outputable
-
#ifdef DEBUG
-import PprAbsC ( pprMagicId ) -- tmp
+import PprAbsC ( pprMagicId )
#endif
+
+import GLAEXTS
\end{code}
%************************************************************************
an automatic context switch is done.
-----------------------------------------------------------------------------
-A heap/stack check at a fast entry point.
+A heap/stack check at a function or thunk entry point.
\begin{code}
-
-fastEntryChecks
- :: [MagicId] -- Live registers
- -> [(VirtualSpOffset,Int)] -- stack slots to tag
- -> CLabel -- return point
- -> Bool -- node points to closure
+funEntryChecks :: Maybe CLabel -> AbstractC -> Code -> Code
+funEntryChecks closure_lbl reg_save_code code
+ = hpStkCheck closure_lbl True reg_save_code code
+
+thunkChecks :: Maybe CLabel -> Code -> Code
+thunkChecks closure_lbl code
+ = hpStkCheck closure_lbl False AbsCNop code
+
+hpStkCheck
+ :: Maybe CLabel -- function closure
+ -> Bool -- is a function? (not a thunk)
+ -> AbstractC -- register saves
-> Code
-> Code
-fastEntryChecks regs tags ret node_points code
- = mkTagAssts tags `thenFC` \tag_assts ->
- getFinalStackHW (\ spHw ->
+hpStkCheck closure_lbl is_fun reg_save_code code
+ = getFinalStackHW (\ spHw ->
getRealSp `thenFC` \ sp ->
let stk_words = spHw - sp in
- initHeapUsage (\ hp_words ->
-
- ( if all_pointers then -- heap checks are quite easy
- absC (checking_code stk_words hp_words tag_assts
- free_reg (length regs))
-
- else -- they are complicated
-
- -- 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) ->
-
- -- 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
-
- let adjust_sp = CAssign (CReg Sp) (CAddr (spRel sp new_sp)) in
+ initHeapUsage (\ hHw ->
- absC (checking_code real_stk_words hp_words
- (mkAbstractCs [tag_assts, stk_assts, more_tag_assts,
- adjust_sp])
- (CReg node) 0)
+ getTickyCtrLabel `thenFC` \ ticky_ctr ->
- ) `thenC`
+ absC (checking_code stk_words hHw ticky_ctr) `thenC`
- setRealHp hp_words `thenC`
- code))
+ setRealHp hHw `thenC`
+ code))
where
-
- checking_code stk hp assts ret regs
- | node_points = do_checks_np stk hp assts (regs+1) -- ret not required
- | 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
+ node_asst
+ | Just lbl <- closure_lbl = CAssign nodeReg (CLbl lbl PtrRep)
+ | otherwise = AbsCNop
+
+ save_code = mkAbstractCs [node_asst, reg_save_code]
+
+ checking_code stk hp ctr
+ = mkAbstractCs
+ [ if is_fun
+ then do_checks_fun stk hp save_code
+ else do_checks_np stk hp save_code,
+ if hp == 0
+ then AbsCNop
+ else profCtrAbsC FSLIT("TICK_ALLOC_HEAP")
+ [ mkIntCLit hp, CLbl ctr DataPtrRep ]
+ ]
+
+
+-- For functions:
+
+do_checks_fun
+ :: Int -- stack headroom
+ -> Int -- heap headroom
+ -> AbstractC -- assignments to perform on failure
-> 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
+do_checks_fun 0 0 _ = AbsCNop
+do_checks_fun 0 hp_words assts =
+ CCheck HP_CHK_FUN [ mkIntCLit hp_words ] assts
+do_checks_fun stk_words 0 assts =
+ CCheck STK_CHK_FUN [ mkIntCLit stk_words ] assts
+do_checks_fun stk_words hp_words assts =
+ CCheck HP_STK_CHK_FUN [ mkIntCLit stk_words, mkIntCLit hp_words ] assts
+
+-- For thunks:
+
+do_checks_np
+ :: Int -- stack headroom
+ -> Int -- heap headroom
+ -> AbstractC -- assignments to perform on failure
-> 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
- IBOX(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
+do_checks_np 0 0 _ = AbsCNop
+do_checks_np 0 hp_words assts =
+ CCheck HP_CHK_NP [ mkIntCLit hp_words ] assts
+do_checks_np stk_words 0 assts =
+ CCheck STK_CHK_NP [ mkIntCLit stk_words ] assts
+do_checks_np stk_words hp_words assts =
+ CCheck HP_STK_CHK_NP [ mkIntCLit stk_words, mkIntCLit hp_words ] assts
\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
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.
-
-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.
+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 CLabel -- ret address if not on top of stack.
- -> Code
- -> Code
+ :: AltType -- PolyAlt, PrimAlt, AlgAlt, but *not* UbxTupAlt
+ -- (Unboxed tuples are dealt with by ubxTupleHeapCheck)
+ -> Code -- Continuation
+ -> Code
+altHeapCheck alt_type code
+ = initHeapUsage (\ hHw ->
+ do_heap_chk hHw `thenC`
+ setRealHp hHw `thenC`
+ code)
+ where
+ do_heap_chk :: HeapOffset -> Code
+ do_heap_chk words_required
+ = getTickyCtrLabel `thenFC` \ ctr ->
+ absC ( -- NB The conditional is inside the absC,
+ -- so the monadic stuff doesn't depend on
+ -- the value of words_required!
+ if words_required == 0
+ then AbsCNop
+ else mkAbstractCs
+ [ CCheck (checking_code alt_type)
+ [mkIntCLit words_required] AbsCNop,
+ profCtrAbsC FSLIT("TICK_ALLOC_HEAP")
+ [ mkIntCLit words_required, CLbl ctr DataPtrRep ]
+ ])
+
+ checking_code PolyAlt
+ = HP_CHK_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
+
+ checking_code (AlgAlt tc)
+ = HP_CHK_NP -- Enter R1 after the heap check; it's a pointer
+ -- The "NP" is short for "Node (R1) Points to it"
+
+ checking_code (PrimAlt tc)
+ = case dataReturnConvPrim (tyConPrimRep tc) of
+ VoidReg -> HP_CHK_NOREGS
+ FloatReg 1# -> HP_CHK_F1
+ DoubleReg 1# -> HP_CHK_D1
+ LongReg _ 1# -> HP_CHK_L1
+ VanillaReg rep 1#
+ | isFollowableRep rep -> HP_CHK_UNPT_R1 -- R1 is boxed but unlifted:
+ | otherwise -> HP_CHK_UNBX_R1 -- R1 is unboxed
+#ifdef DEBUG
+ other_reg -> pprPanic "CgHeapery.altHeapCheck" (ppr tc <+> pprMagicId other_reg)
+#endif
--- unboxed tuple alternatives and let-no-escapes (the two most annoying
+-- 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)
- where
- do_heap_chk words_required tag_assts
- = absC (if words_required == 0
- then AbsCNop
- else checking_code tag_assts) `thenC`
- setRealHp words_required
+unbxTupleHeapCheck
+ :: [MagicId] -- live registers
+ -> Int -- no. of stack slots containing ptrs
+ -> Int -- no. of stack slots containing nonptrs
+ -> AbstractC -- code to insert in the failure path
+ -> Code
+ -> Code
- where
- non_void_regs = filter (/= VoidReg) regs
-
- checking_code tag_assts =
- case non_void_regs of
-
- -- this will cover all cases for x86
- [VanillaReg rep ILIT(1)]
-
- | isFollowableRep rep ->
- CCheck HP_CHK_UT_ALT
- [mkIntCLit words_required, mkIntCLit 1, mkIntCLit 0,
- CReg (VanillaReg RetRep ILIT(2)),
- CLbl ret_addr RetRep]
- tag_assts
-
- | otherwise ->
- CCheck HP_CHK_UT_ALT
- [mkIntCLit words_required, mkIntCLit 0, mkIntCLit 1,
- CReg (VanillaReg RetRep ILIT(2)),
- CLbl ret_addr RetRep]
- tag_assts
-
- several_regs ->
- let liveness = mkRegLiveness several_regs
- in
- CCheck HP_CHK_GEN
- [mkIntCLit words_required,
- mkIntCLit (IBOX(word2Int# liveness)),
- CLbl 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)
+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 (\ hHw -> do_heap_chk hHw `thenC` code)
where
- do_heap_chk :: HeapOffset -> Code
- do_heap_chk words_required
- = absC (if words_required == 0
- then AbsCNop
- else checking_code) `thenC`
+ do_heap_chk words_required
+ = getTickyCtrLabel `thenFC` \ ctr ->
+ absC ( if words_required == 0
+ then AbsCNop
+ else mkAbstractCs
+ [ checking_code words_required,
+ profCtrAbsC FSLIT("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)
- [VanillaReg rep ILIT(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 ILIT(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 ILIT(1)] ->
- CCheck HP_CHK_F1 [mkIntCLit words_required] AbsCNop
-
- -- DblReg1
- [DoubleReg ILIT(1)] ->
- CCheck HP_CHK_D1 [mkIntCLit words_required] AbsCNop
-
- -- LngReg1
- [LongReg _ ILIT(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
+ liveness = I# (word2Int# (mkRegLiveness regs ptrs nptrs))
+ checking_code words_required = CCheck HP_CHK_UNBX_TUPLE
+ [mkIntCLit words_required,
+ mkIntCLit liveness]
+ fail_code
-- build up a bitmap of the live pointer registers
-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
+#if __GLASGOW_HASKELL__ >= 503
+shiftL = uncheckedShiftL#
+#else
+shiftL = shiftL#
+#endif
+mkRegLiveness :: [MagicId] -> Int -> Int -> Word#
+mkRegLiveness [] (I# ptrs) (I# nptrs) =
+ (int2Word# nptrs `shiftL` 16#) `or#` (int2Word# ptrs `shiftL` 24#)
+mkRegLiveness (VanillaReg rep i : regs) ptrs nptrs | isFollowableRep rep
+ = ((int2Word# 1#) `shiftL` (i -# 1#)) `or#` mkRegLiveness regs ptrs nptrs
+mkRegLiveness (_ : regs) ptrs nptrs = mkRegLiveness regs ptrs nptrs
+
+-- 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 =
+fetchAndReschedule regs node_reqd =
if (node `elem` regs || node_reqd)
then fetch_code `thenC` reschedule_code
else absC AbsCNop
where
- all_regs = if node_reqd then node:regs else regs
- liveness_mask = 0 {-XXX: mkLiveRegsMask all_regs-}
-
+ liveness_mask = mkRegLiveness regs 0 0
reschedule_code = absC (CMacroStmt GRAN_RESCHEDULE [
- mkIntCLit liveness_mask,
+ mkIntCLit (I# (word2Int# liveness_mask)),
mkIntCLit (if node_reqd then 1 else 0)])
--HWL: generate GRAN_FETCH macro for GrAnSim
-> Bool -- Node reqd?
-> Code
-yield regs node_reqd =
- -- NB: node is not alive; that's why we use DO_YIELD rather than
- -- GRAN_RESCHEDULE
- yield_code
- where
- all_regs = if node_reqd then node:regs else regs
- liveness_mask = 0 {-XXX: mkLiveRegsMask all_regs-}
-
- yield_code = absC (CMacroStmt GRAN_YIELD [mkIntCLit liveness_mask])
+yield regs node_reqd =
+ if opt_GranMacros && node_reqd
+ then yield_code
+ else absC AbsCNop
+ where
+ liveness_mask = mkRegLiveness regs 0 0
+ yield_code =
+ absC (CMacroStmt GRAN_YIELD
+ [mkIntCLit (I# (word2Int# liveness_mask))])
\end{code}
%************************************************************************
-- GENERATE THE CODE
absC ( mkAbstractCs (
- [ cInitHdr closure_info (hpRel realHp info_offset) use_cc ]
+ [ CInitHdr closure_info
+ (CAddr (hpRel realHp info_offset))
+ use_cc closure_size ]
++ (map do_move amodes_with_offsets))) `thenC`
- -- GENERATE CC PROFILING MESSAGES
- costCentresC SLIT("CCS_ALLOC") [blame_cc, mkIntCLit closure_size]
- `thenC`
-
-- BUMP THE VIRTUAL HEAP POINTER
setVirtHp (virtHp + closure_size) `thenC`
where
closure_size = closureSize closure_info
slop_size = slopSize closure_info
-
--- Avoid hanging on to anything in the CC field when we're not profiling.
-
-cInitHdr closure_info amode cc
- | opt_SccProfilingOn = CInitHdr closure_info amode cc
- | otherwise = CInitHdr closure_info amode (panic "absent cc")
-
\end{code}
projects / ghc-hetmet.git / blobdiff