%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
+%
+% $Id: CgHeapery.lhs,v 1.40 2004/08/13 13:06:00 simonmar Exp $
%
\section[CgHeapery]{Heap management functions}
\begin{code}
-#include "HsVersions.h"
-
module CgHeapery (
- heapCheck,
- allocHeap, allocDynClosure
+ initHeapUsage, getVirtHp, setVirtHp, setRealHp,
+ getHpRelOffset, hpRel,
-#ifdef GRAN
- -- new for GrAnSim HWL
- , heapCheckOnly, fetchAndReschedule
-#endif {- GRAN -}
+ funEntryChecks, thunkEntryChecks,
+ altHeapCheck, unbxTupleHeapCheck,
+ hpChkGen, hpChkNodePointsAssignSp0,
+ stkChkGen, stkChkNodePoints,
+
+ layOutDynConstr, layOutStaticConstr,
+ mkVirtHeapOffsets, mkStaticClosureFields, mkStaticClosure,
+
+ allocDynClosure, emitSetDynHdr
) where
-import Ubiq{-uitous-}
+#include "HsVersions.h"
-import AbsCSyn
+import Constants ( mIN_UPD_SIZE )
+import StgSyn ( AltType(..) )
+import CLabel ( CLabel, mkRtsCodeLabel )
+import CgUtils ( mkWordCLit, cmmRegOffW, cmmOffsetW,
+ cmmOffsetExprB )
import CgMonad
+import CgProf ( staticProfHdr, profDynAlloc, dynProfHdr )
+import CgTicky ( staticTickyHdr, tickyDynAlloc, tickyAllocHeap )
+import CgParallel ( staticGranHdr, staticParHdr, doGranAllocate )
+import CgStackery ( getFinalStackHW, getRealSp )
+import CgCallConv ( mkRegLiveness )
+import ClosureInfo ( closureSize, closureUpdReqd,
+ staticClosureNeedsLink,
+ mkConInfo,
+ infoTableLabelFromCI, closureLabelFromCI,
+ nodeMustPointToIt, closureLFInfo,
+ ClosureInfo )
+import SMRep ( CgRep(..), cgRepSizeW, separateByPtrFollowness,
+ WordOff, fixedHdrSize, isVoidArg, primRepToCgRep )
+
+import Cmm ( CmmLit(..), CmmStmt(..), CmmExpr(..), GlobalReg(..),
+ CmmReg(..), hpReg, nodeReg, spReg )
+import MachOp ( mo_wordULt, mo_wordUGt, mo_wordSub )
+import CmmUtils ( mkIntCLit, CmmStmts, noStmts, oneStmt, plusStmts,
+ mkStmts )
+import Id ( Id )
+import DataCon ( DataCon )
+import TyCon ( tyConPrimRep )
+import CostCentre ( CostCentreStack )
+import Util ( mapAccumL, filterOut )
+import Constants ( wORD_SIZE )
+import Outputable
+
+import GLAEXTS
-import AbsCUtils ( mkAbstractCs, getAmodeRep )
-import CgRetConv ( mkLiveRegsMask )
-import CgUsages ( getVirtAndRealHp, setVirtHp, setRealHp,
- initHeapUsage
- )
-import ClosureInfo ( closureSize, closureHdrSize, closureGoodStuffSize,
- slopSize, allocProfilingMsg, closureKind
- )
-import HeapOffs ( isZeroOff, addOff, intOff,
- VirtualHeapOffset(..)
- )
-import PrimRep ( PrimRep(..) )
\end{code}
+
%************************************************************************
%* *
-\subsection[CgHeapery-heap-overflow]{Heap overflow checking}
+\subsection[CgUsages-heapery]{Monad things for fiddling with heap usage}
%* *
%************************************************************************
-This is std code we replaced by the bits below for GrAnSim. -- HWL
+The heap always grows upwards, so hpRel is easy
\begin{code}
-#ifndef GRAN
+hpRel :: VirtualHpOffset -- virtual offset of Hp
+ -> VirtualHpOffset -- virtual offset of The Thing
+ -> WordOff -- integer word offset
+hpRel hp off = off - hp
+\end{code}
-heapCheck :: [MagicId] -- Live registers
- -> Bool -- Node reqd after GC?
- -> Code
- -> Code
+@initHeapUsage@ applies a function to the amount of heap that it uses.
+It initialises the heap usage to zeros, and passes on an unchanged
+heap usage.
+
+It is usually a prelude to performing a GC check, so everything must
+be in a tidy and consistent state.
-heapCheck regs node_reqd code
- = initHeapUsage (\ hHw -> do_heap_chk hHw `thenC` code)
+rje: Note the slightly suble fixed point behaviour needed here
+
+\begin{code}
+initHeapUsage :: (VirtualHpOffset -> Code) -> Code
+initHeapUsage fcode
+ = do { orig_hp_usage <- getHpUsage
+ ; setHpUsage initHpUsage
+ ; fixC (\heap_usage2 -> do
+ { fcode (heapHWM heap_usage2)
+ ; getHpUsage })
+ ; setHpUsage orig_hp_usage }
+
+setVirtHp :: VirtualHpOffset -> Code
+setVirtHp new_virtHp
+ = do { hp_usage <- getHpUsage
+ ; setHpUsage (hp_usage {virtHp = new_virtHp}) }
+
+getVirtHp :: FCode VirtualHpOffset
+getVirtHp
+ = do { hp_usage <- getHpUsage
+ ; return (virtHp hp_usage) }
+
+setRealHp :: VirtualHpOffset -> Code
+setRealHp new_realHp
+ = do { hp_usage <- getHpUsage
+ ; setHpUsage (hp_usage {realHp = new_realHp}) }
+
+getHpRelOffset :: VirtualHpOffset -> FCode CmmExpr
+getHpRelOffset virtual_offset
+ = do { hp_usg <- getHpUsage
+ ; return (cmmRegOffW hpReg (hpRel (realHp hp_usg) virtual_offset)) }
+\end{code}
+
+
+%************************************************************************
+%* *
+ Layout of heap objects
+%* *
+%************************************************************************
+
+\begin{code}
+layOutDynConstr, layOutStaticConstr
+ :: DataCon
+ -> [(CgRep,a)]
+ -> (ClosureInfo,
+ [(a,VirtualHpOffset)])
+
+layOutDynConstr = layOutConstr False
+layOutStaticConstr = layOutConstr True
+
+layOutConstr is_static data_con args
+ = (mkConInfo is_static data_con tot_wds ptr_wds,
+ things_w_offsets)
where
+ (tot_wds, -- #ptr_wds + #nonptr_wds
+ ptr_wds, -- #ptr_wds
+ things_w_offsets) = mkVirtHeapOffsets args
+\end{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!
-
- -- 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 = mkLiveRegsMask all_regs
-
- checking_code = CMacroStmt HEAP_CHK [
- mkIntCLit liveness_mask,
- COffset words_required,
- mkIntCLit (if node_reqd then 1 else 0)]
-#endif {- GRAN -}
+@mkVirtHeapOffsets@ always returns boxed things with smaller offsets
+than the unboxed things, and furthermore, the offsets in the result
+list
+
+\begin{code}
+mkVirtHeapOffsets
+ :: [(CgRep,a)] -- Things to make offsets for
+ -> (WordOff, -- *Total* number of words allocated
+ WordOff, -- Number of words allocated for *pointers*
+ [(a, VirtualHpOffset)])
+ -- Things with their offsets from start of
+ -- object in order of increasing offset
+
+-- First in list gets lowest offset, which is initial offset + 1.
+
+mkVirtHeapOffsets things
+ = let non_void_things = filterOut (isVoidArg . fst) things
+ (ptrs, non_ptrs) = separateByPtrFollowness non_void_things
+ (wds_of_ptrs, ptrs_w_offsets) = mapAccumL computeOffset 0 ptrs
+ (tot_wds, non_ptrs_w_offsets) = mapAccumL computeOffset wds_of_ptrs non_ptrs
+ in
+ (tot_wds, wds_of_ptrs, ptrs_w_offsets ++ non_ptrs_w_offsets)
+ where
+ computeOffset wds_so_far (rep, thing)
+ = (wds_so_far + cgRepSizeW rep, (thing, fixedHdrSize + wds_so_far))
\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.
+
+%************************************************************************
+%* *
+ Lay out a static closure
+%* *
+%************************************************************************
+
+Make a static closure, adding on any extra padding needed for CAFs,
+and adding a static link field if necessary.
\begin{code}
-#ifdef GRAN
+mkStaticClosureFields
+ :: ClosureInfo
+ -> CostCentreStack
+ -> Bool -- Has CAF refs
+ -> [CmmLit] -- Payload
+ -> [CmmLit] -- The full closure
+mkStaticClosureFields cl_info ccs caf_refs payload
+ = mkStaticClosure info_lbl ccs payload padding_wds static_link_field
+ where
+ info_lbl = infoTableLabelFromCI cl_info
+
+ upd_reqd = closureUpdReqd cl_info
+
+ -- for the purposes of laying out the static closure, we consider all
+ -- thunks to be "updatable", so that the static link field is always
+ -- in the same place.
+ padding_wds
+ | not upd_reqd = []
+ | otherwise = replicate n (mkIntCLit 0) -- a bunch of 0s
+ where n = max 0 (mIN_UPD_SIZE - length payload)
+
+ -- We always have a static link field for a thunk, it's used to
+ -- save the closure's info pointer when we're reverting CAFs
+ -- (see comment in Storage.c)
+ static_link_field
+ | upd_reqd || staticClosureNeedsLink cl_info = [static_link_value]
+ | otherwise = []
+
+ -- for a static constructor which has NoCafRefs, we set the
+ -- static link field to a non-zero value so the garbage
+ -- collector will ignore it.
+ static_link_value
+ | caf_refs = mkIntCLit 0
+ | otherwise = mkIntCLit 1
+
+mkStaticClosure :: CLabel -> CostCentreStack -> [CmmLit]
+ -> [CmmLit] -> [CmmLit] -> [CmmLit]
+mkStaticClosure info_lbl ccs payload padding_wds static_link_field
+ = [CmmLabel info_lbl]
+ ++ variable_header_words
+ ++ payload
+ ++ padding_wds
+ ++ static_link_field
+ where
+ variable_header_words
+ = staticGranHdr
+ ++ staticParHdr
+ ++ staticProfHdr ccs
+ ++ staticTickyHdr
+\end{code}
-heapCheck :: [MagicId] -- Live registers
- -> Bool -- Node reqd after GC?
- -> Code
- -> Code
+%************************************************************************
+%* *
+\subsection[CgHeapery-heap-overflow]{Heap overflow checking}
+%* *
+%************************************************************************
+
+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}
+funEntryChecks :: ClosureInfo -> CmmStmts -> Code -> Code
+funEntryChecks cl_info reg_save_code code
+ = hpStkCheck cl_info True reg_save_code code
+
+thunkEntryChecks :: ClosureInfo -> Code -> Code
+thunkEntryChecks cl_info code
+ = hpStkCheck cl_info False noStmts code
+
+hpStkCheck :: ClosureInfo -- Function closure
+ -> Bool -- Is a function? (not a thunk)
+ -> CmmStmts -- Register saves
+ -> Code
+ -> Code
+
+hpStkCheck cl_info is_fun reg_save_code code
+ = getFinalStackHW $ \ spHw -> do
+ { sp <- getRealSp
+ ; let stk_words = spHw - sp
+ ; initHeapUsage $ \ hpHw -> do
+ { -- Emit heap checks, but be sure to do it lazily so
+ -- that the conditionals on hpHw don't cause a black hole
+ codeOnly $ do
+ { do_checks stk_words hpHw full_save_code rts_label
+ ; tickyAllocHeap hpHw }
+ ; setRealHp hpHw
+ ; code }
+ }
+ where
+ node_asst
+ | nodeMustPointToIt (closureLFInfo cl_info)
+ = noStmts
+ | otherwise
+ = oneStmt (CmmAssign nodeReg (CmmLit (CmmLabel closure_lbl)))
+ closure_lbl = closureLabelFromCI cl_info
+
+ full_save_code = node_asst `plusStmts` reg_save_code
+
+ rts_label | is_fun = CmmReg (CmmGlobal GCFun)
+ -- Function entry point
+ | otherwise = CmmReg (CmmGlobal GCEnter1)
+ -- Thunk or case return
+ -- In the thunk/case-return case, R1 points to a closure
+ -- which should be (re)-entered after GC
+\end{code}
+
+Heap checks in a case alternative are nice and easy, provided this is
+a bog-standard algebraic case. We have in our hand:
+
+ * one return address, on the stack,
+ * one return value, in Node.
+
+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).
+
+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.
+
+\begin{code}
+altHeapCheck
+ :: AltType -- PolyAlt, PrimAlt, AlgAlt, but *not* UbxTupAlt
+ -- (Unboxed tuples are dealt with by ubxTupleHeapCheck)
+ -> Code -- Continuation
+ -> Code
+altHeapCheck alt_type code
+ = initHeapUsage $ \ hpHw -> do
+ { codeOnly $ do
+ { do_checks 0 {- no stack chk -} hpHw
+ noStmts {- nothign to save -}
+ (rts_label alt_type)
+ ; tickyAllocHeap hpHw }
+ ; setRealHp hpHw
+ ; code }
+ where
+ rts_label PolyAlt = CmmLit (CmmLabel (mkRtsCodeLabel SLIT( "stg_gc_unpt_r1")))
+ -- Do *not* enter R1 after a heap check in
+ -- a polymorphic case. It might be a function
+ -- and the entry code for a function (currently)
+ -- applies it
+ --
+ -- However R1 is guaranteed to be a pointer
+
+ rts_label (AlgAlt tc) = stg_gc_enter1
+ -- Enter R1 after the heap check; it's a pointer
+
+ rts_label (PrimAlt tc)
+ = CmmLit $ CmmLabel $
+ case primRepToCgRep (tyConPrimRep tc) of
+ VoidArg -> mkRtsCodeLabel SLIT( "stg_gc_noregs")
+ FloatArg -> mkRtsCodeLabel SLIT( "stg_gc_f1")
+ DoubleArg -> mkRtsCodeLabel SLIT( "stg_gc_d1")
+ LongArg -> mkRtsCodeLabel SLIT( "stg_gc_l1")
+ -- R1 is boxed but unlifted:
+ PtrArg -> mkRtsCodeLabel SLIT( "stg_gc_unpt_r1")
+ -- R1 is unboxed:
+ NonPtrArg -> mkRtsCodeLabel SLIT( "stg_gc_unbx_r1")
+
+ rts_label (UbxTupAlt _) = panic "altHeapCheck"
+\end{code}
+
+
+Unboxed tuple alternatives and let-no-escapes (the two most annoying
+constructs to generate code for!) 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.
-heapCheck = heapCheck' False
+\begin{code}
+unbxTupleHeapCheck
+ :: [(Id, GlobalReg)] -- Live registers
+ -> WordOff -- no. of stack slots containing ptrs
+ -> WordOff -- no. of stack slots containing nonptrs
+ -> CmmStmts -- 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 $ \ hpHw -> do
+ { codeOnly $ do { do_checks 0 {- no stack check -} hpHw
+ full_fail_code rts_label
+ ; tickyAllocHeap hpHw }
+ ; setRealHp hpHw
+ ; code }
+ where
+ full_fail_code = fail_code `plusStmts` oneStmt assign_liveness
+ assign_liveness = CmmAssign (CmmGlobal (VanillaReg 9)) -- Ho ho ho!
+ (CmmLit (mkWordCLit liveness))
+ liveness = mkRegLiveness regs ptrs nptrs
+ rts_label = CmmLit (CmmLabel (mkRtsCodeLabel SLIT("stg_gc_ut")))
+
+\end{code}
+
+
+%************************************************************************
+%* *
+ Heap/Stack Checks.
+%* *
+%************************************************************************
-heapCheckOnly :: [MagicId] -- Live registers
- -> Bool -- Node reqd after GC?
- -> Code
- -> Code
+When failing a check, we save a return address on the stack and
+jump to a pre-compiled code fragment that saves the live registers
+and returns to the scheduler.
-heapCheckOnly = heapCheck' False
+The return address in most cases will be the beginning of the basic
+block in which the check resides, since we need to perform the check
+again on re-entry because someone else might have stolen the resource
+in the meantime.
--- May be emit context switch and emit heap check macro
+\begin{code}
+do_checks :: WordOff -- Stack headroom
+ -> WordOff -- Heap headroom
+ -> CmmStmts -- Assignments to perform on failure
+ -> CmmExpr -- Rts address to jump to on failure
+ -> Code
+do_checks 0 0 _ _ = nopC
+do_checks stk hp reg_save_code rts_lbl
+ = do_checks' (CmmLit (mkIntCLit (stk*wORD_SIZE)))
+ (CmmLit (mkIntCLit (hp*wORD_SIZE)))
+ (stk /= 0) (hp /= 0) reg_save_code rts_lbl
+
+-- The offsets are now in *bytes*
+do_checks' stk_expr hp_expr stk_nonzero hp_nonzero reg_save_code rts_lbl
+ = do { doGranAllocate hp_expr
+
+ -- Emit a block for the heap-check-failure code
+ ; blk_id <- forkLabelledCode $ do
+ { whenC hp_nonzero $
+ stmtC (CmmAssign (CmmGlobal HpAlloc) hp_expr)
+ ; emitStmts reg_save_code
+ ; stmtC (CmmJump rts_lbl []) }
+
+ -- Check for stack overflow *FIRST*; otherwise
+ -- we might bumping Hp and then failing stack oflo
+ ; whenC stk_nonzero
+ (stmtC (CmmCondBranch stk_oflo blk_id))
+
+ ; whenC hp_nonzero
+ (stmtsC [CmmAssign hpReg
+ (cmmOffsetExprB (CmmReg hpReg) hp_expr),
+ CmmCondBranch hp_oflo blk_id])
+ -- Bump heap pointer, and test for heap exhaustion
+ -- Note that we don't move the heap pointer unless the
+ -- stack check succeeds. Otherwise we might end up
+ -- with slop at the end of the current block, which can
+ -- confuse the LDV profiler.
+ }
+ where
+ -- Stk overflow if (Sp - stk_bytes < SpLim)
+ stk_oflo = CmmMachOp mo_wordULt
+ [CmmMachOp mo_wordSub [CmmReg spReg, stk_expr],
+ CmmReg (CmmGlobal SpLim)]
+
+ -- Hp overflow if (Hpp > HpLim)
+ -- (Hp has been incremented by now)
+ -- HpLim points to the LAST WORD of valid allocation space.
+ hp_oflo = CmmMachOp mo_wordUGt
+ [CmmReg hpReg, CmmReg (CmmGlobal HpLim)]
+\end{code}
-heapCheck' :: Bool -- context switch here?
- -> [MagicId] -- Live registers
- -> Bool -- Node reqd after GC?
- -> Code
- -> Code
+%************************************************************************
+%* *
+ Generic Heap/Stack Checks - used in the RTS
+%* *
+%************************************************************************
-heapCheck' do_context_switch regs node_reqd code
- = initHeapUsage (\ hHw -> do_heap_chk hHw `thenC` code)
+\begin{code}
+hpChkGen :: CmmExpr -> CmmExpr -> CmmExpr -> Code
+hpChkGen bytes liveness reentry
+ = do_checks' (CmmLit (mkIntCLit 0)) bytes False True assigns stg_gc_gen
+ where
+ assigns = mkStmts [
+ CmmAssign (CmmGlobal (VanillaReg 9)) liveness,
+ CmmAssign (CmmGlobal (VanillaReg 10)) reentry
+ ]
+
+-- a heap check where R1 points to the closure to enter on return, and
+-- we want to assign to Sp[0] on failure (used in AutoApply.cmm:BUILD_PAP).
+hpChkNodePointsAssignSp0 :: CmmExpr -> CmmExpr -> Code
+hpChkNodePointsAssignSp0 bytes sp0
+ = do_checks' (CmmLit (mkIntCLit 0)) bytes False True assign stg_gc_enter1
+ where assign = oneStmt (CmmStore (CmmReg spReg) sp0)
+
+stkChkGen :: CmmExpr -> CmmExpr -> CmmExpr -> Code
+stkChkGen bytes liveness reentry
+ = do_checks' bytes (CmmLit (mkIntCLit 0)) True False assigns stg_gc_gen
where
+ assigns = mkStmts [
+ CmmAssign (CmmGlobal (VanillaReg 9)) liveness,
+ CmmAssign (CmmGlobal (VanillaReg 10)) reentry
+ ]
+
+stkChkNodePoints :: CmmExpr -> Code
+stkChkNodePoints bytes
+ = do_checks' bytes (CmmLit (mkIntCLit 0)) True False noStmts stg_gc_enter1
- 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
-
- 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 = mkLiveRegsMask 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)]
-
--- Emit macro for simulating a fetch and then reschedule
-
-fetchAndReschedule :: [MagicId] -- Live registers
- -> Bool -- Node reqd
- -> Code
-
-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 = mkLiveRegsMask all_regs
-
- reschedule_code = absC (CMacroStmt GRAN_RESCHEDULE [
- mkIntCLit 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 [])
-
-#endif {- GRAN -}
+stg_gc_gen = CmmLit (CmmLabel (mkRtsCodeLabel SLIT("stg_gc_gen")))
+stg_gc_enter1 = CmmReg (CmmGlobal GCEnter1)
\end{code}
%************************************************************************
\begin{code}
allocDynClosure
:: ClosureInfo
- -> CAddrMode -- Cost Centre to stick in the object
- -> CAddrMode -- Cost Centre to blame for this alloc
+ -> CmmExpr -- Cost Centre to stick in the object
+ -> CmmExpr -- Cost Centre to blame for this alloc
-- (usually the same; sometimes "OVERHEAD")
- -> [(CAddrMode, VirtualHeapOffset)] -- Offsets from start of the object
- -- ie Info ptr has offset zero.
- -> FCode VirtualHeapOffset -- Returns virt offset of object
+ -> [(CmmExpr, VirtualHpOffset)] -- Offsets from start of the object
+ -- ie Info ptr has offset zero.
+ -> FCode VirtualHpOffset -- Returns virt offset of object
-allocDynClosure closure_info use_cc blame_cc amodes_with_offsets
- = getVirtAndRealHp `thenFC` \ (virtHp, realHp) ->
+allocDynClosure cl_info use_cc blame_cc amodes_with_offsets
+ = do { virt_hp <- getVirtHp
-- 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)
-
- -- do_move IS THE ASSIGNMENT FUNCTION
- do_move (amode, offset_from_start)
- = CAssign (CVal (HpRel realHp
- (info_offset `addOff` 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`
-
- -- GENERATE THE CODE
- absC ( mkAbstractCs (
- [ CInitHdr closure_info (HpRel realHp info_offset) use_cc False ]
- ++ (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`
+ ; let info_offset = virt_hp + 1
+ -- info_offset is the VirtualHpOffset of the first
+ -- word of the new object
+ -- Remember, virtHp points to last allocated word,
+ -- ie 1 *before* the info-ptr word of new object.
- -- RETURN PTR TO START OF OBJECT
- returnFC info_offset
- where
- closure_size = closureSize closure_info
- slop_size = slopSize closure_info
-\end{code}
+ info_ptr = CmmLit (CmmLabel (infoTableLabelFromCI cl_info))
+ hdr_w_offsets = initDynHdr info_ptr use_cc `zip` [0..]
-%************************************************************************
-%* *
-\subsection{Allocate uninitialized heap space}
-%* *
-%************************************************************************
+ -- SAY WHAT WE ARE ABOUT TO DO
+ ; profDynAlloc cl_info use_cc
+ -- ToDo: This is almost certainly wrong
+ -- We're ignoring blame_cc. But until we've
+ -- fixed the boxing hack in chooseDynCostCentres etc,
+ -- we're worried about making things worse by "fixing"
+ -- this part to use blame_cc!
-\begin{code}
-allocHeap :: HeapOffset -- Size of the space required
- -> FCode CAddrMode -- Addr mode for first word of object
+ ; tickyDynAlloc cl_info
-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`
+ -- ALLOCATE THE OBJECT
+ ; base <- getHpRelOffset info_offset
+ ; hpStore base (hdr_w_offsets ++ amodes_with_offsets)
-- BUMP THE VIRTUAL HEAP POINTER
- setVirtHp (virtHp `addOff` space) `thenC`
-
+ ; setVirtHp (virt_hp + closureSize cl_info)
+
-- RETURN PTR TO START OF OBJECT
- returnFC (CAddr (HpRel realHp block_start))
+ ; returnFC info_offset }
+
+
+initDynHdr :: CmmExpr
+ -> CmmExpr -- Cost centre to put in object
+ -> [CmmExpr]
+initDynHdr info_ptr cc
+ = [info_ptr]
+ -- ToDo: Gransim stuff
+ -- ToDo: Parallel stuff
+ ++ dynProfHdr cc
+ -- No ticky header
+
+hpStore :: CmmExpr -> [(CmmExpr, VirtualHpOffset)] -> Code
+-- Store the item (expr,off) in base[off]
+hpStore base es
+ = stmtsC [ CmmStore (cmmOffsetW base off) val
+ | (val, off) <- es ]
+
+emitSetDynHdr :: CmmExpr -> CmmExpr -> CmmExpr -> Code
+emitSetDynHdr base info_ptr ccs
+ = hpStore base (zip (initDynHdr info_ptr ccs) [0..])
\end{code}
projects / ghc-hetmet.git / blobdiff