%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1994
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
+%
+% $Id: CgHeapery.lhs,v 1.18 1999/06/24 13:04:19 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 -}
+ fastEntryChecks, altHeapCheck, 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, mkTaggedStkAmodes, mkTagAssts )
+import SMRep ( fixedHdrSize )
+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,
+ closureSMRep
)
-import Util
+import PrimRep ( PrimRep(..), isFollowableRep )
+import Unique ( Unique )
+import CmdLineOpts ( opt_SccProfilingOn )
+import GlaExts
+import Outputable
+
+#ifdef DEBUG
+import PprAbsC ( pprMagicId ) -- tmp
+#endif
\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 fast entry point.
\begin{code}
-#ifndef GRAN
-heapCheck :: [MagicId] -- Live registers
- -> Bool -- Node reqd after GC?
- -> Code
- -> Code
+fastEntryChecks
+ :: [MagicId] -- Live registers
+ -> [(VirtualSpOffset,Int)] -- stack slots to tag
+ -> CLabel -- return point
+ -> Bool -- node points to closure
+ -> Code
+ -> Code
-heapCheck regs node_reqd code
- = initHeapUsage (\ hHw -> do_heap_chk hHw `thenC` code)
- where
+fastEntryChecks regs tags ret node_points code
+ = mkTagAssts tags `thenFC` \tag_assts ->
+ getFinalStackHW (\ spHw ->
+ getRealSp `thenFC` \ sp ->
+ let stk_words = spHw - sp in
+ initHeapUsage (\ hp_words ->
- 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!
+ ( if all_pointers then -- heap checks are quite easy
+ absC (checking_code stk_words hp_words tag_assts
+ free_reg (length regs))
- -- Now we have set up the real heap pointer and checked there is
- -- enough space. It remains only to reflect this in the environment
+ else -- they are complicated
- setRealHp words_required
+ -- save all registers on the stack and adjust the stack pointer.
+ -- ToDo: find the initial all-pointer segment and don't save them.
- -- 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
+ mkTaggedStkAmodes sp addrmode_regs
+ `thenFC` \(new_sp, stk_assts, more_tag_assts) ->
- checking_code = CMacroStmt HEAP_CHK [
- mkIntCLit liveness_mask,
- COffset words_required,
- mkIntCLit (if node_reqd then 1 else 0)]
-#endif {- GRAN -}
-\end{code}
+ -- only let the extra stack assignments affect the stack
+ -- high water mark if we were doing a stack check anyway;
+ -- otherwise we end up generating unnecessary stack checks.
+ -- Careful about knot-tying loops!
+ let real_stk_words = if new_sp - sp > stk_words && stk_words /= 0
+ then new_sp - sp
+ else stk_words
+ in
-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.
+ let adjust_sp = CAssign (CReg Sp) (CAddr (spRel sp new_sp)) in
-\begin{code}
-#ifdef GRAN
+ absC (checking_code real_stk_words hp_words
+ (mkAbstractCs [tag_assts, stk_assts, more_tag_assts,
+ adjust_sp])
+ (CReg node) 0)
-heapCheck :: [MagicId] -- Live registers
- -> Bool -- Node reqd after GC?
- -> Code
- -> Code
+ ) `thenC`
-heapCheck = heapCheck' False
+ setRealHp hp_words `thenC`
+ code))
-heapCheckOnly :: [MagicId] -- Live registers
- -> Bool -- Node reqd after GC?
- -> Code
- -> 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
+
+ -- When node points to the closure for the function:
+
+ do_checks_np
+ :: Int -- stack headroom
+ -> Int -- heap headroom
+ -> AbstractC -- assignments to perform on failure
+ -> Int -- number of pointer registers live
+ -> AbstractC
+ do_checks_np 0 0 _ _ = AbsCNop
+ do_checks_np 0 hp_words tag_assts ptrs =
+ CCheck HP_CHK_NP [
+ mkIntCLit hp_words,
+ mkIntCLit ptrs
+ ]
+ tag_assts
+ do_checks_np stk_words 0 tag_assts ptrs =
+ CCheck STK_CHK_NP [
+ mkIntCLit stk_words,
+ mkIntCLit ptrs
+ ]
+ tag_assts
+ do_checks_np stk_words hp_words tag_assts ptrs =
+ CCheck HP_STK_CHK_NP [
+ mkIntCLit stk_words,
+ mkIntCLit hp_words,
+ mkIntCLit ptrs
+ ]
+ tag_assts
+
+ -- When node doesn't point to the closure (we need an explicit retn addr)
+
+ do_checks
+ :: Int -- stack headroom
+ -> Int -- heap headroom
+ -> AbstractC -- assignments to perform on failure
+ -> CAddrMode -- a register to hold the retn addr.
+ -> Int -- number of pointer registers live
+ -> AbstractC
+
+ do_checks 0 0 _ _ _ = AbsCNop
+ do_checks 0 hp_words tag_assts ret_reg ptrs =
+ CCheck HP_CHK [
+ mkIntCLit hp_words,
+ CLbl ret CodePtrRep,
+ ret_reg,
+ mkIntCLit ptrs
+ ]
+ tag_assts
+ do_checks stk_words 0 tag_assts ret_reg ptrs =
+ CCheck STK_CHK [
+ mkIntCLit stk_words,
+ CLbl ret CodePtrRep,
+ ret_reg,
+ mkIntCLit ptrs
+ ]
+ tag_assts
+ do_checks stk_words hp_words tag_assts ret_reg ptrs =
+ CCheck HP_STK_CHK [
+ mkIntCLit stk_words,
+ mkIntCLit hp_words,
+ CLbl ret CodePtrRep,
+ ret_reg,
+ mkIntCLit ptrs
+ ]
+ tag_assts
+
+ free_reg = case length regs + 1 of
+ IBOX(x) -> CReg (VanillaReg PtrRep x)
+
+ all_pointers = all pointer regs
+ pointer (VanillaReg rep _) = isFollowableRep rep
+ pointer _ = False
+
+ addrmode_regs = map CReg regs
+
+-- Checking code for thunks is just a special case of fast entry points:
+
+thunkChecks :: CLabel -> Bool -> Code -> Code
+thunkChecks ret node_points code = fastEntryChecks [] [] ret node_points code
+\end{code}
-heapCheckOnly = heapCheck' False
+Heap checks in a case alternative are nice and easy, provided this is
+a bog-standard algebraic case. We have in our hand:
--- May be emit context switch and emit heap check macro
+ * one return address, on the stack,
+ * one return value, in Node.
-heapCheck' :: Bool -- context switch here?
- -> [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). Only a PtrRep will do.
-heapCheck' do_context_switch regs node_reqd code
- = initHeapUsage (\ hHw -> do_heap_chk hHw `thenC` code)
+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.
+
+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, with gaps left for tagging the unboxed
+objects. If a heap check is required, we need to fill in these tags.
+
+The code below will cover all cases for the x86 architecture (where R1
+is the only VanillaReg ever used). For other architectures, we'll
+have to do something about saving and restoring the other registers.
+
+\begin{code}
+altHeapCheck
+ :: Bool -- is an algebraic alternative
+ -> [MagicId] -- live registers
+ -> [(VirtualSpOffset,Int)] -- stack slots to tag
+ -> AbstractC
+ -> Maybe Unique -- uniq of ret address (possibly)
+ -> Code
+ -> Code
+
+-- 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
+ = 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`
+ setRealHp words_required
+ where
+ non_void_regs = filter (/= VoidReg) regs
+
+ checking_code tag_assts =
+ case non_void_regs of
+
+{- no: there might be stuff on top of the retn. addr. on the stack.
+ [{-no regs-}] ->
+ CCheck HP_CHK_NOREGS
+ [mkIntCLit words_required]
+ tag_assts
+-}
+ -- this will cover all cases for x86
+ [VanillaReg rep ILIT(1)]
+
+ | isFollowableRep rep ->
+ CCheck HP_CHK_UT_ALT
+ [mkIntCLit words_required, mkIntCLit 1, mkIntCLit 0,
+ CReg (VanillaReg RetRep ILIT(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)),
+ CLbl (mkReturnInfoLabel ret_addr) RetRep]
+ tag_assts
+
+ several_regs ->
+ let liveness = mkRegLiveness several_regs
+ in
+ CCheck HP_CHK_GEN
+ [mkIntCLit words_required,
+ mkIntCLit (IBOX(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.)
+ CLbl (mkReturnPtLabel ret_addr) RetRep]
+ tag_assts
+
+-- normal algebraic and primitive case alternatives:
+
+altHeapCheck is_fun regs [] AbsCNop Nothing 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)
+ = absC (if words_required == 0
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
-
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
+
+ -- 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.
+ [VanillaReg rep ILIT(1)]
+ | rep == PtrRep
+ && is_fun ->
+ CCheck HP_CHK_SEQ_NP
+ [mkIntCLit words_required, mkIntCLit 1{-regs live-}]
+ AbsCNop
+
+ -- R1 is lifted (the common case)
+ [VanillaReg rep ILIT(1)]
+ | rep == PtrRep ->
+ 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)] ->
+ CCheck HP_CHK_F1 [mkIntCLit words_required] AbsCNop
+
+ -- DblReg1
+ [DoubleReg ILIT(1)] ->
+ CCheck HP_CHK_D1 [mkIntCLit words_required] AbsCNop
+
+ -- LngReg1
+ [LongReg _ ILIT(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
+
+-- build up a bitmap of the live pointer registers
+
+mkRegLiveness :: [MagicId] -> Word#
+mkRegLiveness [] = int2Word# 0#
+mkRegLiveness (VanillaReg rep i : regs) | isFollowableRep rep
+ = ((int2Word# 1#) `shiftL#` (i -# 1#)) `or#` mkRegLiveness regs
+mkRegLiveness (_ : regs) = mkRegLiveness regs
-- 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 = 0 {-XXX: mkLiveRegsMask all_regs-}
reschedule_code = absC (CMacroStmt GRAN_RESCHEDULE [
mkIntCLit liveness_mask,
--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}
-#endif {- GRAN -}
+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}
+
+\begin{code}
+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])
\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 (hpRel realHp info_offset) use_cc ]
++ (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]
+ costCentresC SLIT("CCS_ALLOC") [blame_cc, mkIntCLit closure_size]
`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:
+
+ - 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}
-allocHeap :: HeapOffset -- Size of the space required
- -> FCode CAddrMode -- Addr mode for first word of object
+inPlaceAllocDynClosure
+ :: ClosureInfo
+ -> CAddrMode -- Pointer to beginning of closure
+ -> CAddrMode -- Cost Centre to stick in the object
-allocHeap space
- = getVirtAndRealHp `thenFC` \ (virtHp, realHp) ->
- let block_start = addOff virtHp (intOff 1)
+ -> [(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
- -- We charge the allocation to "PRIM" (which is probably right)
- profCtrC SLIT("ALLOC_PRIM2") [COffset space] `thenC`
+ -- GENERATE THE CODE
+ absC ( mkAbstractCs (
+ [ CInitHdr closure_info head use_cc ]
+ ++ (map do_move amodes_with_offsets)))
- -- BUMP THE VIRTUAL HEAP POINTER
- setVirtHp (virtHp `addOff` space) `thenC`
+-- Avoid hanging on to anything in the CC field when we're not profiling.
- -- RETURN PTR TO START OF OBJECT
- returnFC (CAddr (HpRel realHp block_start))
+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