X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FcodeGen%2FCgHeapery.lhs;h=3ff646ca07d534c14186ced02cfcfff2a3dbd97e;hp=ae6c892b5d360668cd38c6ad9927ea6161417382;hb=d0faaa6fa0cecd23c5670fd199e9206275313666;hpb=61d2625ae2e6a4cdae2ffc92df828905e81c24cc diff --git a/compiler/codeGen/CgHeapery.lhs b/compiler/codeGen/CgHeapery.lhs index ae6c892..3ff646c 100644 --- a/compiler/codeGen/CgHeapery.lhs +++ b/compiler/codeGen/CgHeapery.lhs @@ -1,8 +1,7 @@ % +% (c) The University of Glasgow 2006 % (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} @@ -23,39 +22,31 @@ module CgHeapery ( #include "HsVersions.h" -import StgSyn ( AltType(..) ) -import CLabel ( CLabel, mkRtsCodeLabel ) -import CgUtils ( mkWordCLit, cmmRegOffW, cmmOffsetW, - cmmOffsetExprB ) +import StgSyn +import CLabel +import CgUtils 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 PackageConfig ( PackageId ) +import CgProf +import CgTicky +import CgParallel +import CgStackery +import CgCallConv +import ClosureInfo +import SMRep + +import OldCmm +import OldCmmUtils +import Id +import DataCon +import TyCon +import CostCentre +import Util +import Module +import Constants import Outputable +import FastString +import Data.List \end{code} @@ -88,7 +79,7 @@ initHeapUsage :: (VirtualHpOffset -> Code) -> Code initHeapUsage fcode = do { orig_hp_usage <- getHpUsage ; setHpUsage initHpUsage - ; fixC (\heap_usage2 -> do + ; fixC_(\heap_usage2 -> do { fcode (heapHWM heap_usage2) ; getHpUsage }) ; setHpUsage orig_hp_usage } @@ -123,8 +114,7 @@ getHpRelOffset virtual_offset \begin{code} layOutDynConstr, layOutStaticConstr - :: PackageId - -> DataCon + :: DataCon -> [(CgRep,a)] -> (ClosureInfo, [(a,VirtualHpOffset)]) @@ -132,8 +122,10 @@ layOutDynConstr, layOutStaticConstr layOutDynConstr = layOutConstr False layOutStaticConstr = layOutConstr True -layOutConstr is_static this_pkg data_con args - = (mkConInfo this_pkg is_static data_con tot_wds ptr_wds, +layOutConstr :: Bool -> DataCon -> [(CgRep, a)] + -> (ClosureInfo, [(a, VirtualHpOffset)]) +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 @@ -193,7 +185,7 @@ 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 + info_lbl = infoTableLabelFromCI cl_info $ clHasCafRefs cl_info -- CAFs must have consistent layout, regardless of whether they -- are actually updatable or not. The layout of a CAF is: @@ -228,13 +220,12 @@ mkStaticClosureFields cl_info ccs caf_refs payload | 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 + ++ concatMap padLitToWord payload ++ padding_wds ++ static_link_field ++ saved_info_field @@ -244,6 +235,17 @@ mkStaticClosure info_lbl ccs payload padding_wds static_link_field saved_info_fi ++ staticParHdr ++ staticProfHdr ccs ++ staticTickyHdr + +padLitToWord :: CmmLit -> [CmmLit] +padLitToWord lit = lit : padding pad_length + where width = typeWidth (cmmLitType lit) + pad_length = wORD_SIZE - widthInBytes width :: Int + + padding n | n <= 0 = [] + | n `rem` 2 /= 0 = CmmInt 0 W8 : padding (n-1) + | n `rem` 4 /= 0 = CmmInt 0 W16 : padding (n-2) + | n `rem` 8 /= 0 = CmmInt 0 W32 : padding (n-4) + | otherwise = CmmInt 0 W64 : padding (n-8) \end{code} %************************************************************************ @@ -297,7 +299,10 @@ hpStkCheck cl_info is_fun reg_save_code code = noStmts | otherwise = oneStmt (CmmAssign nodeReg (CmmLit (CmmLabel closure_lbl))) - closure_lbl = closureLabelFromCI cl_info + -- Strictly speaking, we should tag node here. But if + -- node doesn't point to the closure, the code for the closure + -- cannot depend on the value of R1 anyway, so we're safe. + closure_lbl = closureLabelFromCI cl_info (clHasCafRefs cl_info) full_save_code = node_asst `plusStmts` reg_save_code @@ -342,7 +347,7 @@ altHeapCheck alt_type code ; setRealHp hpHw ; code } where - rts_label PolyAlt = CmmLit (CmmLabel (mkRtsCodeLabel SLIT( "stg_gc_unpt_r1"))) + rts_label PolyAlt = CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageId (fsLit "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) @@ -350,20 +355,20 @@ altHeapCheck alt_type code -- -- However R1 is guaranteed to be a pointer - rts_label (AlgAlt tc) = stg_gc_enter1 + rts_label (AlgAlt _) = 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") + VoidArg -> mkCmmCodeLabel rtsPackageId (fsLit "stg_gc_noregs") + FloatArg -> mkCmmCodeLabel rtsPackageId (fsLit "stg_gc_f1") + DoubleArg -> mkCmmCodeLabel rtsPackageId (fsLit "stg_gc_d1") + LongArg -> mkCmmCodeLabel rtsPackageId (fsLit "stg_gc_l1") -- R1 is boxed but unlifted: - PtrArg -> mkRtsCodeLabel SLIT( "stg_gc_unpt_r1") + PtrArg -> mkCmmCodeLabel rtsPackageId (fsLit "stg_gc_unpt_r1") -- R1 is unboxed: - NonPtrArg -> mkRtsCodeLabel SLIT( "stg_gc_unbx_r1") + NonPtrArg -> mkCmmCodeLabel rtsPackageId (fsLit "stg_gc_unbx_r1") rts_label (UbxTupAlt _) = panic "altHeapCheck" \end{code} @@ -398,10 +403,10 @@ unbxTupleHeapCheck regs ptrs nptrs fail_code code ; code } where full_fail_code = fail_code `plusStmts` oneStmt assign_liveness - assign_liveness = CmmAssign (CmmGlobal (VanillaReg 9)) -- Ho ho ho! + assign_liveness = CmmAssign (CmmGlobal (VanillaReg 9 VNonGcPtr)) -- Ho ho ho! (CmmLit (mkWordCLit liveness)) liveness = mkRegLiveness regs ptrs nptrs - rts_label = CmmLit (CmmLabel (mkRtsCodeLabel SLIT("stg_gc_ut"))) + rts_label = CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageId (fsLit "stg_gc_ut"))) \end{code} @@ -428,31 +433,52 @@ do_checks :: WordOff -- Stack headroom -> CmmExpr -- Rts address to jump to on failure -> Code do_checks 0 0 _ _ = nopC + +do_checks _ hp _ _ + | hp > bLOCKS_PER_MBLOCK * bLOCK_SIZE_W + = sorry (unlines [ + "Trying to allocate more than " ++ show (bLOCKS_PER_MBLOCK * bLOCK_SIZE) ++ " bytes.", + "", + "See: http://hackage.haskell.org/trac/ghc/ticket/4505", + "Suggestion: read data from a file instead of having large static data", + "structures in the code."]) + 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' :: CmmExpr -> CmmExpr -> Bool -> Bool -> CmmStmts -> CmmExpr -> Code 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) + -- The failure block: this saves the registers and jumps to + -- the appropriate RTS stub. + ; exit_blk_id <- forkLabelledCode $ do { ; emitStmts reg_save_code ; stmtC (CmmJump rts_lbl []) } + -- In the case of a heap-check failure, we must also set + -- HpAlloc. NB. HpAlloc is *only* set if Hp has been + -- incremented by the heap check, it must not be set in the + -- event that a stack check failed, because the RTS stub will + -- retreat Hp by HpAlloc. + ; hp_blk_id <- if hp_nonzero + then forkLabelledCode $ do + stmtC (CmmAssign (CmmGlobal HpAlloc) hp_expr) + stmtC (CmmBranch exit_blk_id) + else return exit_blk_id + -- Check for stack overflow *FIRST*; otherwise -- we might bumping Hp and then failing stack oflo ; whenC stk_nonzero - (stmtC (CmmCondBranch stk_oflo blk_id)) + (stmtC (CmmCondBranch stk_oflo exit_blk_id)) ; whenC hp_nonzero (stmtsC [CmmAssign hpReg (cmmOffsetExprB (CmmReg hpReg) hp_expr), - CmmCondBranch hp_oflo blk_id]) + CmmCondBranch hp_oflo hp_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 @@ -465,7 +491,7 @@ do_checks' stk_expr hp_expr stk_nonzero hp_nonzero reg_save_code rts_lbl [CmmMachOp mo_wordSub [CmmReg spReg, stk_expr], CmmReg (CmmGlobal SpLim)] - -- Hp overflow if (Hpp > HpLim) + -- Hp overflow if (Hp > HpLim) -- (Hp has been incremented by now) -- HpLim points to the LAST WORD of valid allocation space. hp_oflo = CmmMachOp mo_wordUGt @@ -483,10 +509,8 @@ 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 - ] + assigns = mkStmts [ mk_vanilla_assignment 9 liveness, + mk_vanilla_assignment 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). @@ -499,16 +523,20 @@ 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 - ] + assigns = mkStmts [ mk_vanilla_assignment 9 liveness, + mk_vanilla_assignment 10 reentry ] + +mk_vanilla_assignment :: Int -> CmmExpr -> CmmStmt +mk_vanilla_assignment n e + = CmmAssign (CmmGlobal (VanillaReg n (vgcFlag (cmmExprType e)))) e 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_gen :: CmmExpr +stg_gc_gen = CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageId (fsLit "stg_gc_gen"))) +stg_gc_enter1 :: CmmExpr stg_gc_enter1 = CmmReg (CmmGlobal GCEnter1) \end{code} @@ -532,7 +560,7 @@ allocDynClosure -- ie Info ptr has offset zero. -> FCode VirtualHpOffset -- Returns virt offset of object -allocDynClosure cl_info use_cc blame_cc amodes_with_offsets +allocDynClosure cl_info use_cc _blame_cc amodes_with_offsets = do { virt_hp <- getVirtHp -- FIND THE OFFSET OF THE INFO-PTR WORD @@ -542,7 +570,8 @@ allocDynClosure cl_info use_cc blame_cc amodes_with_offsets -- Remember, virtHp points to last allocated word, -- ie 1 *before* the info-ptr word of new object. - info_ptr = CmmLit (CmmLabel (infoTableLabelFromCI cl_info)) + info_ptr = CmmLit (CmmLabel (infoTableLabelFromCI cl_info + (clHasCafRefs cl_info))) hdr_w_offsets = initDynHdr info_ptr use_cc `zip` [0..] -- SAY WHAT WE ARE ABOUT TO DO