%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
+%
+% $Id: CgHeapery.lhs,v 1.47 2005/06/21 10:44:41 simonmar Exp $
%
\section[CgHeapery]{Heap management functions}
\begin{code}
-#include "HsVersions.h"
-
module CgHeapery (
- heapCheck,
- allocHeap, allocDynClosure
+ initHeapUsage, getVirtHp, setVirtHp, setRealHp,
+ getHpRelOffset, hpRel,
+
+ funEntryChecks, thunkEntryChecks,
+ altHeapCheck, unbxTupleHeapCheck,
+ hpChkGen, hpChkNodePointsAssignSp0,
+ stkChkGen, stkChkNodePoints,
- -- new functions, basically inserting macro calls into Code -- HWL
- , heapCheckOnly, fetchAndReschedule, yield
+ layOutDynConstr, layOutStaticConstr,
+ mkVirtHeapOffsets, mkStaticClosureFields, mkStaticClosure,
+
+ allocDynClosure, emitSetDynHdr
) where
-IMP_Ubiq(){-uitous-}
+#include "HsVersions.h"
-import AbsCSyn
+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, staticClosureNeedsLink,
+ mkConInfo, closureNeedsUpdSpace,
+ infoTableLabelFromCI, closureLabelFromCI,
+ nodeMustPointToIt, closureLFInfo,
+ ClosureInfo )
+import SMRep ( CgRep(..), cgRepSizeW, separateByPtrFollowness,
+ WordOff, fixedHdrSize, thunkHdrSize,
+ 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 Packages ( HomeModules )
+import Outputable
+
+\end{code}
+
+
+%************************************************************************
+%* *
+\subsection[CgUsages-heapery]{Monad things for fiddling with heap usage}
+%* *
+%************************************************************************
+
+The heap always grows upwards, so hpRel is easy
+
+\begin{code}
+hpRel :: VirtualHpOffset -- virtual offset of Hp
+ -> VirtualHpOffset -- virtual offset of The Thing
+ -> WordOff -- integer word offset
+hpRel hp off = off - hp
+\end{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.
+
+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}
+
-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,
- SYN_IE(VirtualHeapOffset)
- )
-import PrimRep ( PrimRep(..) )
+%************************************************************************
+%* *
+ Layout of heap objects
+%* *
+%************************************************************************
+
+\begin{code}
+layOutDynConstr, layOutStaticConstr
+ :: HomeModules
+ -> DataCon
+ -> [(CgRep,a)]
+ -> (ClosureInfo,
+ [(a,VirtualHpOffset)])
+
+layOutDynConstr = layOutConstr False
+layOutStaticConstr = layOutConstr True
+
+layOutConstr is_static hmods data_con args
+ = (mkConInfo hmods 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 False{-not a thunk-} args
+\end{code}
+
+@mkVirtHeapOffsets@ always returns boxed things with smaller offsets
+than the unboxed things, and furthermore, the offsets in the result
+list
+
+\begin{code}
+mkVirtHeapOffsets
+ :: Bool -- True <=> is a thunk
+ -> [(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 is_thunk 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
+ hdr_size | is_thunk = thunkHdrSize
+ | otherwise = fixedHdrSize
+
+ computeOffset wds_so_far (rep, thing)
+ = (wds_so_far + cgRepSizeW rep, (thing, hdr_size + wds_so_far))
+\end{code}
+
+
+%************************************************************************
+%* *
+ 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}
+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 saved_info_field
+ where
+ info_lbl = infoTableLabelFromCI cl_info
+
+ -- CAFs must have consistent layout, regardless of whether they
+ -- are actually updatable or not. The layout of a CAF is:
+ --
+ -- 3 saved_info
+ -- 2 static_link
+ -- 1 indirectee
+ -- 0 info ptr
+ --
+ -- the static_link and saved_info fields must always be in the same
+ -- place. So we use closureNeedsUpdSpace rather than
+ -- closureUpdReqd here:
+
+ is_caf = closureNeedsUpdSpace cl_info
+
+ padding_wds
+ | not is_caf = []
+ | otherwise = ASSERT(null payload) [mkIntCLit 0]
+
+ static_link_field
+ | is_caf || staticClosureNeedsLink cl_info = [static_link_value]
+ | otherwise = []
+
+ saved_info_field
+ | is_caf = [mkIntCLit 0]
+ | 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] -> [CmmLit]
+mkStaticClosure info_lbl ccs payload padding_wds static_link_field saved_info_field
+ = [CmmLabel info_lbl]
+ ++ variable_header_words
+ ++ payload
+ ++ padding_wds
+ ++ static_link_field
+ ++ saved_info_field
+ where
+ variable_header_words
+ = staticGranHdr
+ ++ staticParHdr
+ ++ staticProfHdr ccs
+ ++ staticTickyHdr
\end{code}
%************************************************************************
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}
-heapCheck :: [MagicId] -- Live registers
- -> Bool -- Node reqd after GC?
- -> Code
- -> 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}
-heapCheck = 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:
-heapCheckOnly :: [MagicId] -- Live registers
- -> Bool -- Node reqd after GC?
- -> Code
- -> Code
+ * one return address, on the stack,
+ * one return value, in Node.
-heapCheckOnly = heapCheck' False
+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).
--- May be emit context switch and emit heap check macro
+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.
-heapCheck' :: Bool -- context switch here?
- -> [MagicId] -- Live registers
- -> Bool -- Node reqd after GC?
- -> Code
- -> Code
+\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}
-heapCheck' do_context_switch regs node_reqd code
- = initHeapUsage (\ hHw -> do_heap_chk hHw `thenC` 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.
+
+\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")))
- 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 [])
\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}
+
+%************************************************************************
+%* *
+ Heap/Stack Checks.
+%* *
+%************************************************************************
+
+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.
+
+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.
\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 = mkLiveRegsMask all_regs
-
- yield_code = absC (CMacroStmt GRAN_YIELD [mkIntCLit liveness_mask])
+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}
+
+%************************************************************************
+%* *
+ Generic Heap/Stack Checks - used in the RTS
+%* *
+%************************************************************************
+
+\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
+
+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