X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FcodeGen%2FCgHeapery.lhs;h=df3720cd2dcf85ee48a2310d079bffbf83edb45b;hb=b36d55f419b8864665e1637dd895d6ae8f56cfcc;hp=184af904dfb5b9de7ff1b9e4bd0859dfb91206ad;hpb=0065d5ab628975892cea1ec7303f968c3338cbe1;p=ghc-hetmet.git diff --git a/compiler/codeGen/CgHeapery.lhs b/compiler/codeGen/CgHeapery.lhs index 184af90..df3720c 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,30 @@ 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 Packages ( HomeModules ) +import CgProf +import CgTicky +import CgParallel +import CgStackery +import CgCallConv +import ClosureInfo +import SMRep + +import Cmm +import CmmUtils +import Id +import DataCon +import TyCon +import CostCentre +import Util +import Constants import Outputable +import FastString +import Data.List \end{code} @@ -123,8 +113,7 @@ getHpRelOffset virtual_offset \begin{code} layOutDynConstr, layOutStaticConstr - :: HomeModules - -> DataCon + :: DataCon -> [(CgRep,a)] -> (ClosureInfo, [(a,VirtualHpOffset)]) @@ -132,8 +121,10 @@ layOutDynConstr, layOutStaticConstr layOutDynConstr = layOutConstr False layOutStaticConstr = layOutConstr True -layOutConstr is_static hmods data_con args - = (mkConInfo hmods 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 +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: @@ -228,13 +219,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 +234,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 +298,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 +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 (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) @@ -350,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 (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") + PtrArg -> mkRtsCodeLabel (sLit "stg_gc_unpt_r1") -- R1 is unboxed: - NonPtrArg -> mkRtsCodeLabel SLIT( "stg_gc_unbx_r1") + NonPtrArg -> mkRtsCodeLabel (sLit "stg_gc_unbx_r1") rts_label (UbxTupAlt _) = panic "altHeapCheck" \end{code} @@ -398,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 (sLit "stg_gc_ut"))) \end{code} @@ -434,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 @@ -465,7 +470,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 +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). @@ -499,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 (sLit "stg_gc_gen"))) +stg_gc_enter1 :: CmmExpr stg_gc_enter1 = CmmReg (CmmGlobal GCEnter1) \end{code} @@ -532,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 @@ -542,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