X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FcodeGen%2FCgHeapery.lhs;h=d41fcaf6b0bf514a0fb34dfa663fe2b66848be0c;hb=f05e7d3f77664119bcb0fed7776ad030563de0bb;hp=ba26f4d6226de651b894249f426f8fc1b345070e;hpb=589b7946b0847a47d1a5493dcec0976c84814312;p=ghc-hetmet.git diff --git a/ghc/compiler/codeGen/CgHeapery.lhs b/ghc/compiler/codeGen/CgHeapery.lhs index ba26f4d..d41fcaf 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.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 @@ -21,24 +21,23 @@ 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 GlaExts +import CmdLineOpts ( opt_GranMacros ) import Outputable #ifdef DEBUG import PprAbsC ( pprMagicId ) -- tmp #endif + +import GLAEXTS \end{code} %************************************************************************ @@ -73,11 +72,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 +103,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 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: @@ -181,7 +194,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 @@ -223,7 +236,8 @@ have to do something about saving and restoring the other registers. \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 @@ -234,16 +248,22 @@ altHeapCheck -- 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 @@ -259,19 +279,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 +300,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.) @@ -289,14 +309,20 @@ altHeapCheck is_fun regs tags fail_code (Just ret_addr) code -- 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 @@ -309,39 +335,35 @@ altHeapCheck is_fun regs [] AbsCNop Nothing code [] -> 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 @@ -350,28 +372,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 @@ -397,15 +424,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} %************************************************************************ @@ -450,13 +477,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` @@ -465,11 +490,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}