X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FcodeGen%2FCgHeapery.lhs;h=3ff646ca07d534c14186ced02cfcfff2a3dbd97e;hp=3bba211aa19aa06ee3049b2c240d1a9e44c5c5c2;hb=f537dd87c4a07526e2b1fc1bd1c125d652833641;hpb=262c142b90c94ca1aa577c950a6ceae1f255e2d6 diff --git a/compiler/codeGen/CgHeapery.lhs b/compiler/codeGen/CgHeapery.lhs index 3bba211..3ff646c 100644 --- a/compiler/codeGen/CgHeapery.lhs +++ b/compiler/codeGen/CgHeapery.lhs @@ -34,17 +34,17 @@ import CgCallConv import ClosureInfo import SMRep -import Cmm -import MachOp -import CmmUtils +import OldCmm +import OldCmmUtils import Id import DataCon import TyCon import CostCentre import Util +import Module import Constants -import PackageConfig import Outputable +import FastString import Data.List \end{code} @@ -79,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 } @@ -114,8 +114,7 @@ getHpRelOffset virtual_offset \begin{code} layOutDynConstr, layOutStaticConstr - :: PackageId - -> DataCon + :: DataCon -> [(CgRep,a)] -> (ClosureInfo, [(a,VirtualHpOffset)]) @@ -123,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 @@ -184,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: @@ -219,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 @@ -235,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} %************************************************************************ @@ -288,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 @@ -333,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) @@ -341,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} @@ -389,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} @@ -419,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 @@ -456,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 @@ -474,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). @@ -490,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} @@ -523,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 @@ -533,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