X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FcodeGen%2FCgHeapery.lhs;h=6abffe72dccc00127cc459d897af7b27cf3038be;hb=423d477bfecd490de1449c59325c8776f91d7aac;hp=226ff6b72a07babcc4c586a6c6eb53e7cbc7b074;hpb=e7d21ee4f8ac907665a7e170c71d59e13a01da09;p=ghc-hetmet.git diff --git a/ghc/compiler/codeGen/CgHeapery.lhs b/ghc/compiler/codeGen/CgHeapery.lhs index 226ff6b..6abffe7 100644 --- a/ghc/compiler/codeGen/CgHeapery.lhs +++ b/ghc/compiler/codeGen/CgHeapery.lhs @@ -1,193 +1,500 @@ % -% (c) The GRASP/AQUA Project, Glasgow University, 1992-1994 +% (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, - -- and to make the interface self-sufficient... - AbstractC, CAddrMode, HeapOffset, - CgState, ClosureInfo, Id + layOutDynConstr, layOutStaticConstr, + mkVirtHeapOffsets, mkStaticClosureFields, mkStaticClosure, + + allocDynClosure, emitSetDynHdr ) where -import AbsCSyn +#include "HsVersions.h" + +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 CgRetConv ( mkLiveRegsBitMask ) -import CgUsages ( getVirtAndRealHp, setVirtHp, setRealHp, - initHeapUsage - ) -import ClosureInfo ( closureSize, closureHdrSize, closureGoodStuffSize, slopSize, - layOutDynClosure, - allocProfilingMsg, closureKind - ) -import Util \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. + +rje: Note the slightly suble fixed point behaviour needed here -heapCheck regs node_reqd code - = initHeapUsage (\ hHw -> do_heap_chk hHw `thenC` code) +\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} + +@mkVirtHeapOffsets@ always returns boxed things with smaller offsets +than the unboxed things, and furthermore, the offsets in the result +list - 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 = mkLiveRegsBitMask all_regs - - checking_code = CMacroStmt HEAP_CHK [ - mkIntCLit liveness_mask, - COffset words_required, - mkIntCLit (if node_reqd then 1 else 0)] -#endif {- GRAN -} +\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} +%* * +%************************************************************************ -heapCheck = heapCheck' False +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. -heapCheckOnly :: [MagicId] -- Live registers - -> Bool -- Node reqd after GC? - -> Code - -> Code +-------------------------------------------------------------- +A heap/stack check at a function or thunk entry point. -heapCheckOnly = heapCheck' False +\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: --- 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). -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. + +\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. + +\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. +%* * +%************************************************************************ + +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} +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 - 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 = 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)] - --- 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 = mkLiveRegsBitMask 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} %************************************************************************ @@ -202,77 +509,65 @@ to account for this. \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)) - (getAmodeKind 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)) IntKind] - `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. - -- BUMP THE VIRTUAL HEAP POINTER - setVirtHp (virtHp `addOff` closure_size) `thenC` + info_ptr = CmmLit (CmmLabel (infoTableLabelFromCI cl_info)) + hdr_w_offsets = initDynHdr info_ptr use_cc `zip` [0..] - -- RETURN PTR TO START OF OBJECT - returnFC info_offset - where - closure_size = closureSize closure_info - slop_size = slopSize closure_info -\end{code} - -%************************************************************************ -%* * -\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}