X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FcodeGen%2FCgHeapery.lhs;h=f2707955d161ae877b408e39d61ec37ed93021b3;hb=23d366594eec3e60a86ea90e4edc42fd5f1d88ee;hp=80d968f8ebf6671985923264b114ce578d822f4f;hpb=451a8613203721d344e26eb043e8af827c58cd7b;p=ghc-hetmet.git diff --git a/ghc/compiler/codeGen/CgHeapery.lhs b/ghc/compiler/codeGen/CgHeapery.lhs index 80d968f..f270795 100644 --- a/ghc/compiler/codeGen/CgHeapery.lhs +++ b/ghc/compiler/codeGen/CgHeapery.lhs @@ -1,14 +1,14 @@ % % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 % -% $Id: CgHeapery.lhs,v 1.17 1999/05/26 14:12:13 simonmar Exp $ +% $Id: CgHeapery.lhs,v 1.29 2001/12/12 12:19:11 simonmar 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 @@ -21,18 +21,16 @@ import CLabel 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 CmdLineOpts ( opt_SccProfilingOn, opt_GranMacros ) import GlaExts import Outputable @@ -73,11 +71,17 @@ fastEntryChecks regs tags ret node_points 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 @@ -98,21 +102,29 @@ fastEntryChecks regs tags ret node_points code 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 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: @@ -181,7 +193,7 @@ fastEntryChecks regs tags ret node_points code 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 @@ -241,9 +253,15 @@ altHeapCheck is_fun regs tags fail_code (Just ret_addr) code 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 SLIT("TICK_ALLOC_HEAP") + [ mkIntCLit words_required, CLbl ctr DataPtrRep ] + ] + ) `thenC` setRealHp words_required where @@ -259,19 +277,19 @@ altHeapCheck is_fun regs tags fail_code (Just ret_addr) code 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 @@ -280,7 +298,7 @@ altHeapCheck is_fun regs tags fail_code (Just ret_addr) code 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.) @@ -294,9 +312,15 @@ altHeapCheck is_fun regs [] AbsCNop Nothing 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 SLIT("TICK_ALLOC_HEAP") + [ mkIntCLit words_required, CLbl ctr DataPtrRep ] + ] + ) `thenC` setRealHp words_required where @@ -313,7 +337,7 @@ altHeapCheck is_fun regs [] AbsCNop Nothing code -- 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 ILIT(1)] + [VanillaReg rep 1#] | rep == PtrRep && is_fun -> CCheck HP_CHK_SEQ_NP @@ -321,7 +345,7 @@ altHeapCheck is_fun regs [] AbsCNop Nothing code AbsCNop -- R1 is lifted (the common case) - [VanillaReg rep ILIT(1)] + [VanillaReg rep 1#] | rep == PtrRep -> CCheck HP_CHK_NP [mkIntCLit words_required, mkIntCLit 1{-regs live-}] @@ -336,15 +360,15 @@ altHeapCheck is_fun regs [] AbsCNop Nothing code 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 @@ -353,28 +377,33 @@ altHeapCheck is_fun regs [] AbsCNop Nothing code -- 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 @@ -400,15 +429,15 @@ yield :: [MagicId] -- Live registers -> 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} %************************************************************************ @@ -453,13 +482,11 @@ allocDynClosure closure_info use_cc blame_cc amodes_with_offsets -- 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` @@ -468,11 +495,35 @@ allocDynClosure closure_info use_cc blame_cc amodes_with_offsets 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}