%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
-% $Id: CgHeapery.lhs,v 1.25 2000/11/06 08:15:21 simonpj Exp $
+% $Id: CgHeapery.lhs,v 1.34 2002/09/13 15:02:28 simonpj Exp $
%
\section[CgHeapery]{Heap management functions}
)
import PrimRep ( PrimRep(..), isFollowableRep )
import Unique ( Unique )
-import CmdLineOpts ( opt_SccProfilingOn, opt_GranMacros )
-import Constants ( bLOCK_SIZE_W )
-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 ->
-
- let hHw = if hp_words > bLOCK_SIZE_W then hpChkTooBig else hp_words in
+ initHeapUsage (\ hHw ->
getTickyCtrLabel `thenFC` \ ticky_ctr ->
) `thenC`
- setRealHp hp_words `thenC`
+ setRealHp hHw `thenC`
code))
where
= mkAbstractCs
[ real_check,
if hp == 0 then AbsCNop
- else profCtrAbsC SLIT("TICK_ALLOC_HEAP")
+ else profCtrAbsC FSLIT("TICK_ALLOC_HEAP")
[ mkIntCLit hp, CLbl ctr DataPtrRep ]
]
\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 (if hHw > bLOCK_SIZE_W then hpChkTooBig else hHw) tag_assts
- `thenC` code)
+ initHeapUsage (\ hHw -> do_heap_chk hHw tag_assts `thenC` code)
where
do_heap_chk words_required tag_assts
= getTickyCtrLabel `thenFC` \ ctr ->
then AbsCNop
else mkAbstractCs
[ checking_code tag_assts,
- profCtrAbsC SLIT("TICK_ALLOC_HEAP")
+ profCtrAbsC FSLIT("TICK_ALLOC_HEAP")
[ mkIntCLit words_required, CLbl ctr DataPtrRep ]
]
) `thenC`
-- normal algebraic and primitive case alternatives:
-altHeapCheck is_fun regs [] AbsCNop Nothing code
- = initHeapUsage (\ hHw ->
- do_heap_chk (if hHw > bLOCK_SIZE_W then hpChkTooBig else hHw)
- `thenC` 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
then AbsCNop
else mkAbstractCs
[ checking_code,
- profCtrAbsC SLIT("TICK_ALLOC_HEAP")
+ profCtrAbsC FSLIT("TICK_ALLOC_HEAP")
[ mkIntCLit words_required, CLbl ctr DataPtrRep ]
]
) `thenC`
[] ->
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.
+ -- 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#]
- | rep == PtrRep
- && is_fun ->
- CCheck HP_CHK_SEQ_NP
- [mkIntCLit words_required, mkIntCLit 1{-regs live-}]
- AbsCNop
+ | isFollowableRep rep && (is_poly || is_prim) ->
+ CCheck HP_CHK_UNPT_R1 [mkIntCLit words_required] AbsCNop
-- R1 is lifted (the common case)
- [VanillaReg rep 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
-- 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
[mkIntCLit (I# (word2Int# liveness_mask))])
\end{code}
-\begin{code}
-hpChkTooBig = panic "Oversize heap check detected. Please try compiling with -O."
-\end{code}
-
%************************************************************************
%* *
\subsection[initClosure]{Initialise a dynamic closure}
-- 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`
in
-- GENERATE THE CODE
absC ( mkAbstractCs (
- [ CInitHdr closure_info head use_cc ]
+ [ CInitHdr closure_info head use_cc 0{-no alloc-} ]
++ (map do_move amodes_with_offsets)))
-
--- Avoid hanging on to anything in the CC field when we're not profiling.
-
-cInitHdr closure_info amode cc
- | opt_SccProfilingOn = CInitHdr closure_info (CAddr amode) cc
- | otherwise = CInitHdr closure_info (CAddr amode) (panic "absent cc")
-
\end{code}
projects / ghc-hetmet.git / blobdiff