%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
-% $Id: CgHeapery.lhs,v 1.16 1999/05/13 17:30:56 simonm Exp $
+% $Id: CgHeapery.lhs,v 1.34 2002/09/13 15:02:28 simonpj Exp $
%
\section[CgHeapery]{Heap management functions}
\begin{code}
module CgHeapery (
fastEntryChecks, altHeapCheck, thunkChecks,
- allocDynClosure
+ allocDynClosure, inPlaceAllocDynClosure
-- new functions, basically inserting macro calls into Code -- HWL
,fetchAndReschedule, yield
import CgMonad
import CgStackery ( getFinalStackHW, mkTaggedStkAmodes, mkTagAssts )
-import SMRep ( fixedHdrSize )
import AbsCUtils ( mkAbstractCs, getAmodeRep )
import CgUsages ( getVirtAndRealHp, getRealSp, setVirtHp, setRealHp,
initHeapUsage
)
import ClosureInfo ( closureSize, closureGoodStuffSize,
- slopSize, allocProfilingMsg, ClosureInfo,
- closureSMRep
+ slopSize, allocProfilingMsg, ClosureInfo
)
import PrimRep ( PrimRep(..), isFollowableRep )
import Unique ( Unique )
-import CmdLineOpts ( opt_SccProfilingOn )
-import GlaExts
+import CmdLineOpts ( opt_GranMacros )
import Outputable
#ifdef DEBUG
import PprAbsC ( pprMagicId ) -- tmp
#endif
+
+import GLAEXTS
\end{code}
%************************************************************************
getFinalStackHW (\ spHw ->
getRealSp `thenFC` \ sp ->
let stk_words = spHw - sp in
- initHeapUsage (\ hp_words ->
+ initHeapUsage (\ hHw ->
+
+ getTickyCtrLabel `thenFC` \ ticky_ctr ->
( if all_pointers then -- heap checks are quite easy
- absC (checking_code stk_words hp_words tag_assts
- free_reg (length regs))
+ -- 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)
else -- they are complicated
let adjust_sp = CAssign (CReg Sp) (CAddr (spRel sp new_sp)) in
- absC (checking_code real_stk_words hp_words
+ absC (checking_code real_stk_words hHw
(mkAbstractCs [tag_assts, stk_assts, more_tag_assts,
adjust_sp])
- (CReg node) 0)
+ (CReg node) 0 ticky_ctr)
) `thenC`
- setRealHp hp_words `thenC`
+ 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
+ checking_code stk hp assts ret regs ctr
+ = mkAbstractCs
+ [ real_check,
+ if hp == 0 then AbsCNop
+ else profCtrAbsC FSLIT("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:
tag_assts
free_reg = case length regs + 1 of
- IBOX(x) -> CReg (VanillaReg PtrRep x)
+ I# x -> CReg (VanillaReg PtrRep x)
all_pointers = all pointer regs
pointer (VanillaReg rep _) = isFollowableRep rep
\begin{code}
altHeapCheck
- :: Bool -- is an algebraic alternative
+ :: Bool -- is a polymorphic case alt
+ -> Bool -- is an primitive case alt
-> [MagicId] -- live registers
-> [(VirtualSpOffset,Int)] -- stack slots to tag
-> AbstractC
-- 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
+altHeapCheck is_poly is_prim 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`
+ = getTickyCtrLabel `thenFC` \ ctr ->
+ absC ( if words_required == 0
+ then AbsCNop
+ else mkAbstractCs
+ [ checking_code tag_assts,
+ profCtrAbsC FSLIT("TICK_ALLOC_HEAP")
+ [ mkIntCLit words_required, CLbl ctr DataPtrRep ]
+ ]
+ ) `thenC`
setRealHp words_required
where
tag_assts
-}
-- this will cover all cases for x86
- [VanillaReg rep ILIT(1)]
+ [VanillaReg rep 1#]
| isFollowableRep rep ->
CCheck HP_CHK_UT_ALT
[mkIntCLit words_required, mkIntCLit 1, mkIntCLit 0,
- CReg (VanillaReg RetRep ILIT(2)),
+ 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 ILIT(2)),
+ CReg (VanillaReg RetRep 2#),
CLbl (mkReturnInfoLabel ret_addr) RetRep]
tag_assts
in
CCheck HP_CHK_GEN
[mkIntCLit words_required,
- mkIntCLit (IBOX(word2Int# liveness)),
+ 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.)
-- normal algebraic and primitive case alternatives:
-altHeapCheck is_fun regs [] AbsCNop Nothing code
+altHeapCheck is_poly is_prim regs [] AbsCNop Nothing code
= 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`
+ = getTickyCtrLabel `thenFC` \ ctr ->
+ absC ( if words_required == 0
+ then AbsCNop
+ else mkAbstractCs
+ [ checking_code,
+ profCtrAbsC FSLIT("TICK_ALLOC_HEAP")
+ [ mkIntCLit words_required, CLbl ctr DataPtrRep ]
+ ]
+ ) `thenC`
setRealHp words_required
where
[] ->
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 boxed, but unlifted: DO NOT enter R1 when we return.
+ --
+ -- We also lump the polymorphic case in here, because we don't
+ -- want to enter R1 if it is a function, and we're guarnateed
+ -- that the return point has a direct return.
+ [VanillaReg rep 1#]
+ | isFollowableRep rep && (is_poly || is_prim) ->
+ CCheck HP_CHK_UNPT_R1 [mkIntCLit words_required] AbsCNop
-- R1 is lifted (the common case)
- [VanillaReg rep ILIT(1)]
- | rep == PtrRep ->
- CCheck HP_CHK_NP
+ | isFollowableRep rep ->
+ 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)] ->
+ [FloatReg 1#] ->
CCheck HP_CHK_F1 [mkIntCLit words_required] AbsCNop
-- DblReg1
- [DoubleReg ILIT(1)] ->
+ [DoubleReg 1#] ->
CCheck HP_CHK_D1 [mkIntCLit words_required] AbsCNop
-- LngReg1
- [LongReg _ ILIT(1)] ->
+ [LongReg _ 1#] ->
CCheck HP_CHK_L1 [mkIntCLit words_required] AbsCNop
#ifdef DEBUG
-- 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
+ = ((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 =
+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
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
+ 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
+\end{code}
--- Avoid hanging on to anything in the CC field when we're not profiling.
+Occasionally we can update a closure in place instead of allocating
+new space for it. This is the function that does the business, assuming:
-cInitHdr closure_info amode cc
- | opt_SccProfilingOn = CInitHdr closure_info amode cc
- | otherwise = CInitHdr closure_info amode (panic "absent cc")
-
+ - node points to the closure to be overwritten
+
+ - the new closure doesn't contain any pointers if we're
+ using a generational collector.
+
+\begin{code}
+inPlaceAllocDynClosure
+ :: ClosureInfo
+ -> CAddrMode -- Pointer to beginning of closure
+ -> CAddrMode -- Cost Centre to stick in the object
+
+ -> [(CAddrMode, VirtualHeapOffset)] -- Offsets from start of the object
+ -- ie Info ptr has offset zero.
+ -> Code
+
+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)))
\end{code}