%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1994
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
+%
+% $Id: CgHeapery.lhs,v 1.36 2002/12/18 16:15:43 simonmar Exp $
%
\section[CgHeapery]{Heap management functions}
\begin{code}
-#include "HsVersions.h"
-
module CgHeapery (
- heapCheck,
- allocHeap, allocDynClosure,
-
-#ifdef GRAN
- -- new for GrAnSim HWL
- heapCheckOnly, fetchAndReschedule,
-#endif {- GRAN -}
+ funEntryChecks, altHeapCheck, unbxTupleHeapCheck, thunkChecks,
+ allocDynClosure, inPlaceAllocDynClosure
- -- and to make the interface self-sufficient...
- AbstractC, CAddrMode, HeapOffset,
- CgState, ClosureInfo, Id
+ -- new functions, basically inserting macro calls into Code -- HWL
+ ,fetchAndReschedule, yield
) where
+#include "HsVersions.h"
+
import AbsCSyn
+import CLabel
import CgMonad
-import CgRetConv ( mkLiveRegsBitMask )
-import CgUsages ( getVirtAndRealHp, setVirtHp, setRealHp,
+import CgStackery ( getFinalStackHW )
+import AbsCUtils ( mkAbstractCs, getAmodeRep )
+import CgUsages ( getVirtAndRealHp, getRealSp, setVirtHp, setRealHp,
initHeapUsage
)
-import ClosureInfo ( closureSize, closureHdrSize, closureGoodStuffSize, slopSize,
- layOutDynClosure,
- allocProfilingMsg, closureKind
+import ClosureInfo ( closureSize, closureGoodStuffSize,
+ slopSize, allocProfilingMsg, ClosureInfo
)
-import Util
+import PrimRep ( PrimRep(..), isFollowableRep )
+import CmdLineOpts ( opt_GranMacros )
+import Outputable
+
+#ifdef DEBUG
+import PprAbsC ( pprMagicId ) -- tmp
+#endif
+
+import GLAEXTS
\end{code}
%************************************************************************
%* *
%************************************************************************
-This is std code we replaced by the bits below for GrAnSim. -- HWL
+The new code for heapChecks. For GrAnSim the code for doing a heap check
+and doing a context switch has been separated. Especially, the HEAP_CHK
+macro only performs a heap check. THREAD_CONTEXT_SWITCH should be used for
+doing a context switch. GRAN_FETCH_AND_RESCHEDULE must be put at the
+beginning of every slow entry code in order to simulate the fetching of
+closures. If fetching is necessary (i.e. current closure is not local) then
+an automatic context switch is done.
+
+-----------------------------------------------------------------------------
+A heap/stack check at a function or thunk entry point.
\begin{code}
-#ifndef GRAN
+funEntryChecks :: Maybe CLabel -> AbstractC -> Code -> Code
+funEntryChecks closure_lbl reg_save_code code
+ = hpStkCheck closure_lbl True reg_save_code code
-heapCheck :: [MagicId] -- Live registers
- -> Bool -- Node reqd after GC?
- -> Code
- -> Code
+thunkChecks :: Maybe CLabel -> Code -> Code
+thunkChecks closure_lbl code
+ = hpStkCheck closure_lbl False AbsCNop code
-heapCheck regs node_reqd code
- = initHeapUsage (\ hHw -> do_heap_chk hHw `thenC` code)
- where
+hpStkCheck
+ :: Maybe CLabel -- function closure
+ -> Bool -- is a function? (not a thunk)
+ -> AbstractC -- register saves
+ -> Code
+ -> Code
- do_heap_chk :: HeapOffset -> Code
- do_heap_chk words_required
- = absC (if isZeroOff(words_required) then AbsCNop else checking_code) `thenC`
- -- The test is *inside* the absC, to avoid black holes!
+hpStkCheck closure_lbl is_fun reg_save_code code
+ = getFinalStackHW (\ spHw ->
+ getRealSp `thenFC` \ sp ->
+ let stk_words = spHw - sp in
+ initHeapUsage (\ hHw ->
- -- Now we have set up the real heap pointer and checked there is
- -- enough space. It remains only to reflect this in the environment
+ getTickyCtrLabel `thenFC` \ ticky_ctr ->
- setRealHp words_required
+ absC (checking_code stk_words hHw ticky_ctr) `thenC`
- -- The "word_required" here is a fudge.
- -- *** IT DEPENDS ON THE DIRECTION ***, and on
- -- whether the Hp is moved the whole way all
- -- at once or not.
- where
- all_regs = if node_reqd then node:regs else regs
- liveness_mask = mkLiveRegsBitMask all_regs
-
- checking_code = CMacroStmt HEAP_CHK [
- mkIntCLit liveness_mask,
- COffset words_required,
- mkIntCLit (if node_reqd then 1 else 0)]
-#endif {- GRAN -}
+ setRealHp hHw `thenC`
+ code))
+
+ where
+ 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_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_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}
-The GrAnSim code for heapChecks. The code for doing a heap check and
-doing a context switch has been separated. Especially, the HEAP_CHK
-macro only performs a heap check. THREAD_CONTEXT_SWITCH should be used
-for doing a context switch. GRAN_FETCH_AND_RESCHEDULE must be put at
-the beginning of every slow entry code in order to simulate the
-fetching of closures. If fetching is necessary (i.e. current closure
-is not local) then an automatic context switch is done.
+Heap checks in a case alternative are nice and easy, provided this is
+a bog-standard algebraic case. We have in our hand:
-\begin{code}
-#ifdef GRAN
+ * one return address, on the stack,
+ * one return value, in Node.
-heapCheck :: [MagicId] -- Live registers
- -> Bool -- Node reqd after GC?
- -> Code
- -> Code
+the canned code for this heap check failure just pushes Node on the
+stack, saying 'EnterGHC' to return. The scheduler will return by
+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).
-heapCheck = heapCheck' False
+For primitive returns, we have an unlifted value in some register
+(either R1 or FloatReg1 or DblReg1). This means using specialised
+heap-check code for these cases.
-heapCheckOnly :: [MagicId] -- Live registers
- -> Bool -- Node reqd after GC?
- -> Code
- -> Code
+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. We always organise the stack-resident
+fields into pointers & non-pointers, and pass the number of each to
+the heap check code.
-heapCheckOnly = heapCheck' False
+\begin{code}
+altHeapCheck
+ :: Bool -- do not enter node on return
+ -> [MagicId] -- live registers
+ -> Code -- continuation
+ -> Code
--- May be emit context switch and emit heap check macro
-heapCheck' :: Bool -- context switch here?
- -> [MagicId] -- Live registers
- -> Bool -- Node reqd after GC?
- -> Code
- -> Code
+-- normal algebraic and primitive case alternatives:
-heapCheck' do_context_switch regs node_reqd code
+altHeapCheck no_enter regs code
= initHeapUsage (\ hHw -> do_heap_chk hHw `thenC` code)
where
-
do_heap_chk :: HeapOffset -> Code
do_heap_chk words_required
- =
- -- HWL:: absC (CComment "Forced heap check --- HWL") `thenC`
- --absC (if do_context_switch
- -- then context_switch_code
- -- else AbsCNop) `thenC`
-
- absC (if do_context_switch && not (isZeroOff words_required)
- then context_switch_code
- else AbsCNop) `thenC`
- absC (if isZeroOff(words_required)
- then AbsCNop
- else checking_code) `thenC`
-
- -- HWL was here:
- -- For GrAnSim we want heap checks even if no heap is allocated in
- -- the basic block to make context switches possible.
- -- So, the if construct has been replaced by its else branch.
-
- -- The test is *inside* the absC, to avoid black holes!
-
- -- Now we have set up the real heap pointer and checked there is
- -- enough space. It remains only to reflect this in the environment
-
+ = 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
- -- The "word_required" here is a fudge.
- -- *** IT DEPENDS ON THE DIRECTION ***, and on
- -- whether the Hp is moved the whole way all
- -- at once or not.
where
- all_regs = if node_reqd then node:regs else regs
- liveness_mask = mkLiveRegsBitMask all_regs
-
- maybe_context_switch = if do_context_switch
- then context_switch_code
- else AbsCNop
-
- context_switch_code = CMacroStmt THREAD_CONTEXT_SWITCH [
- mkIntCLit liveness_mask,
- mkIntCLit (if node_reqd then 1 else 0)]
-
- -- Good old heap check (excluding context switch)
- checking_code = CMacroStmt HEAP_CHK [
- mkIntCLit liveness_mask,
- COffset words_required,
- mkIntCLit (if node_reqd then 1 else 0)]
+ 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
+
+ [VanillaReg rep 1#]
+ -- R1 is boxed, but unlifted: DO NOT enter R1 when we return.
+ | isFollowableRep rep && no_enter ->
+ CCheck HP_CHK_UNPT_R1 [mkIntCLit words_required] AbsCNop
+
+ -- R1 is lifted (the common case)
+ | isFollowableRep rep ->
+ CCheck HP_CHK_NP
+ [mkIntCLit words_required]
+ AbsCNop
+
+ -- R1 is unboxed
+ | otherwise ->
+ CCheck HP_CHK_UNBX_R1 [mkIntCLit words_required] AbsCNop
+
+ -- FloatReg1
+ [FloatReg 1#] ->
+ CCheck HP_CHK_F1 [mkIntCLit words_required] AbsCNop
+
+ -- DblReg1
+ [DoubleReg 1#] ->
+ CCheck HP_CHK_D1 [mkIntCLit words_required] AbsCNop
+
+ -- LngReg1
+ [LongReg _ 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
+
+-- unboxed tuple alternatives and let-no-escapes (the two most annoying
+-- constructs to generate code for!):
+
+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
+
+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 words_required
+ = 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
+ checking_code =
+ let liveness = mkRegLiveness regs ptrs nptrs
+ in
+ CCheck HP_CHK_UNBX_TUPLE
+ [mkIntCLit words_required,
+ mkIntCLit (I# (word2Int# liveness))]
+ fail_code
+
+-- build up a bitmap of the live pointer registers
+
+#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
+ -> 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 = mkLiveRegsBitMask 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
-- currently GRAN_FETCH and GRAN_FETCH_AND_RESCHEDULE are miai
fetch_code = absC (CMacroStmt GRAN_FETCH [])
+\end{code}
+
+The @GRAN_YIELD@ macro is taken from JSM's code for Concurrent Haskell. It
+allows to context-switch at places where @node@ is not alive (it uses the
+@Continue@ rather than the @EnterNodeCode@ function in the RTS). We emit
+this kind of macro at the beginning of the following kinds of basic bocks:
+\begin{itemize}
+ \item Slow entry code where node is not alive (see @CgClosure.lhs@). Normally
+ we use @fetchAndReschedule@ at a slow entry code.
+ \item Fast entry code (see @CgClosure.lhs@).
+ \item Alternatives in case expressions (@CLabelledCode@ structures), provided
+ that they are not inlined (see @CgCases.lhs@). These alternatives will
+ be turned into separate functions.
+\end{itemize}
-#endif {- GRAN -}
+\begin{code}
+yield :: [MagicId] -- Live registers
+ -> Bool -- Node reqd?
+ -> Code
+
+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}
%************************************************************************
-- FIND THE OFFSET OF THE INFO-PTR WORD
-- virtHp points to last allocated word, ie 1 *before* the
-- info-ptr word of new object.
- let info_offset = addOff virtHp (intOff 1)
+ let info_offset = virtHp + 1
-- do_move IS THE ASSIGNMENT FUNCTION
do_move (amode, offset_from_start)
- = CAssign (CVal (HpRel realHp
- (info_offset `addOff` offset_from_start))
+ = CAssign (CVal (hpRel realHp
+ (info_offset + offset_from_start))
(getAmodeRep amode))
amode
in
-- SAY WHAT WE ARE ABOUT TO DO
profCtrC (allocProfilingMsg closure_info)
- [COffset (closureHdrSize closure_info),
- mkIntCLit (closureGoodStuffSize closure_info),
- mkIntCLit slop_size,
- COffset closure_size] `thenC`
+ [mkIntCLit (closureGoodStuffSize closure_info),
+ mkIntCLit slop_size] `thenC`
-- GENERATE THE CODE
absC ( mkAbstractCs (
- [ CInitHdr closure_info (HpRel realHp info_offset) use_cc False ]
+ [ 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("CC_ALLOC") [blame_cc,
- COffset closure_size,
- CLitLit (_PK_ (closureKind closure_info)) IntRep]
- `thenC`
-
-- BUMP THE VIRTUAL HEAP POINTER
- setVirtHp (virtHp `addOff` closure_size) `thenC`
+ setVirtHp (virtHp + closure_size) `thenC`
-- RETURN PTR TO START OF OBJECT
returnFC info_offset
slop_size = slopSize closure_info
\end{code}
-%************************************************************************
-%* *
-\subsection{Allocate uninitialized heap space}
-%* *
-%************************************************************************
+Occasionally we can update a closure in place instead of allocating
+new space for it. This is the function that does the business, assuming:
-\begin{code}
-allocHeap :: HeapOffset -- Size of the space required
- -> FCode CAddrMode -- Addr mode for first word of object
+ - node points to the closure to be overwritten
-allocHeap space
- = getVirtAndRealHp `thenFC` \ (virtHp, realHp) ->
- let block_start = addOff virtHp (intOff 1)
- in
- -- We charge the allocation to "PRIM" (which is probably right)
- profCtrC SLIT("ALLOC_PRIM2") [COffset space] `thenC`
+ - the new closure doesn't contain any pointers if we're
+ using a generational collector.
- -- BUMP THE VIRTUAL HEAP POINTER
- setVirtHp (virtHp `addOff` space) `thenC`
+\begin{code}
+inPlaceAllocDynClosure
+ :: ClosureInfo
+ -> CAddrMode -- Pointer to beginning of closure
+ -> CAddrMode -- Cost Centre to stick in the object
- -- RETURN PTR TO START OF OBJECT
- returnFC (CAddr (HpRel realHp block_start))
+ -> [(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}
projects / ghc-hetmet.git / blobdiff