X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FcodeGen%2FCgHeapery.lhs;h=3ff646ca07d534c14186ced02cfcfff2a3dbd97e;hp=252989105c265f43d17257703f5400dd9f76db7c;hb=f8f0e76ad302fda30196ebc9230e5fcbc97be537;hpb=176fa33f17dd78355cc572e006d2ab26898e2c69 diff --git a/compiler/codeGen/CgHeapery.lhs b/compiler/codeGen/CgHeapery.lhs index 2529891..3ff646c 100644 --- a/compiler/codeGen/CgHeapery.lhs +++ b/compiler/codeGen/CgHeapery.lhs @@ -5,13 +5,6 @@ \section[CgHeapery]{Heap management functions} \begin{code} -{-# OPTIONS -w #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and fix --- any warnings in the module. See --- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings --- for details - module CgHeapery ( initHeapUsage, getVirtHp, setVirtHp, setRealHp, getHpRelOffset, hpRel, @@ -41,16 +34,15 @@ import CgCallConv import ClosureInfo import SMRep -import Cmm -import CmmUtils +import OldCmm +import OldCmmUtils import Id -import IdInfo import DataCon import TyCon import CostCentre import Util +import Module import Constants -import PackageConfig import Outputable import FastString @@ -87,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 } @@ -130,6 +122,8 @@ layOutDynConstr, layOutStaticConstr layOutDynConstr = layOutConstr False layOutStaticConstr = layOutConstr True +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) @@ -353,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) @@ -361,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} @@ -412,7 +406,7 @@ unbxTupleHeapCheck regs ptrs nptrs fail_code code 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} @@ -439,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 @@ -519,7 +534,9 @@ 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} @@ -543,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