X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FcodeGen%2FCgHeapery.lhs;h=8d4f7f232afaaa37fd8ced59252153e06e1f5e6c;hb=984a288119983912d40a80845c674ee4b83a19ce;hp=9cb1bb4370f85e381b0594dffc32f92d11c1c2b8;hpb=e5d9aaa2b7b717c862651f8eea5e2dc66f0a8028;p=ghc-hetmet.git diff --git a/compiler/codeGen/CgHeapery.lhs b/compiler/codeGen/CgHeapery.lhs index 9cb1bb4..8d4f7f2 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, @@ -42,7 +35,6 @@ import ClosureInfo import SMRep import Cmm -import MachOp import CmmUtils import Id import DataCon @@ -50,8 +42,8 @@ import TyCon import CostCentre import Util import Constants -import PackageConfig import Outputable +import FastString import Data.List \end{code} @@ -86,7 +78,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 } @@ -129,6 +121,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) @@ -190,7 +184,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: @@ -225,7 +219,6 @@ 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 @@ -244,14 +237,14 @@ mkStaticClosure info_lbl ccs payload padding_wds static_link_field saved_info_fi padLitToWord :: CmmLit -> [CmmLit] padLitToWord lit = lit : padding pad_length - where rep = cmmLitRep lit - pad_length = wORD_SIZE - machRepByteWidth rep :: Int + where width = typeWidth (cmmLitType lit) + pad_length = wORD_SIZE - widthInBytes width :: Int padding n | n <= 0 = [] - | n `rem` 2 /= 0 = CmmInt 0 I8 : padding (n-1) - | n `rem` 4 /= 0 = CmmInt 0 I16 : padding (n-2) - | n `rem` 8 /= 0 = CmmInt 0 I32 : padding (n-4) - | otherwise = CmmInt 0 I64 : padding (n-8) + | 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} %************************************************************************ @@ -308,7 +301,7 @@ hpStkCheck cl_info is_fun reg_save_code code -- 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 + closure_lbl = closureLabelFromCI cl_info (clHasCafRefs cl_info) full_save_code = node_asst `plusStmts` reg_save_code @@ -353,7 +346,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 (mkRtsCodeLabel (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 +354,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 -> mkRtsCodeLabel (fsLit "stg_gc_noregs") + FloatArg -> mkRtsCodeLabel (fsLit "stg_gc_f1") + DoubleArg -> mkRtsCodeLabel (fsLit "stg_gc_d1") + LongArg -> mkRtsCodeLabel (fsLit "stg_gc_l1") -- R1 is boxed but unlifted: - PtrArg -> mkRtsCodeLabel SLIT( "stg_gc_unpt_r1") + PtrArg -> mkRtsCodeLabel (fsLit "stg_gc_unpt_r1") -- R1 is unboxed: - NonPtrArg -> mkRtsCodeLabel SLIT( "stg_gc_unbx_r1") + NonPtrArg -> mkRtsCodeLabel (fsLit "stg_gc_unbx_r1") rts_label (UbxTupAlt _) = panic "altHeapCheck" \end{code} @@ -409,10 +402,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 (mkRtsCodeLabel (fsLit "stg_gc_ut"))) \end{code} @@ -445,6 +438,7 @@ do_checks stk hp reg_save_code rts_lbl (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 @@ -494,10 +488,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). @@ -510,16 +502,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 (mkRtsCodeLabel (fsLit "stg_gc_gen"))) +stg_gc_enter1 :: CmmExpr stg_gc_enter1 = CmmReg (CmmGlobal GCEnter1) \end{code} @@ -543,7 +539,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 @@ -553,7 +549,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