X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FcodeGen%2FCgHeapery.lhs;h=66d41d3d96742693c785f7110ce74cc095b4b143;hb=e71130586a619169d5c406fa394ae5f69bd04bfa;hp=ae6c892b5d360668cd38c6ad9927ea6161417382;hpb=61d2625ae2e6a4cdae2ffc92df828905e81c24cc;p=ghc-hetmet.git diff --git a/compiler/codeGen/CgHeapery.lhs b/compiler/codeGen/CgHeapery.lhs index ae6c892..66d41d3 100644 --- a/compiler/codeGen/CgHeapery.lhs +++ b/compiler/codeGen/CgHeapery.lhs @@ -1,11 +1,17 @@ % +% (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} +{-# 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, @@ -23,39 +29,32 @@ 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 Cmm +import MachOp +import CmmUtils +import Id +import DataCon +import TyCon +import CostCentre +import Util +import Constants +import PackageConfig import Outputable +import FastString +import Data.List \end{code} @@ -123,8 +122,7 @@ getHpRelOffset virtual_offset \begin{code} layOutDynConstr, layOutStaticConstr - :: PackageId - -> DataCon + :: DataCon -> [(CgRep,a)] -> (ClosureInfo, [(a,VirtualHpOffset)]) @@ -132,8 +130,8 @@ 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 is_static data_con args + = (mkConInfo is_static data_con tot_wds ptr_wds, things_w_offsets) where (tot_wds, -- #ptr_wds + #nonptr_wds @@ -234,7 +232,7 @@ mkStaticClosure :: CLabel -> CostCentreStack -> [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 +242,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 rep = cmmLitRep lit + pad_length = wORD_SIZE - machRepByteWidth rep :: 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) \end{code} %************************************************************************ @@ -297,6 +306,9 @@ hpStkCheck cl_info is_fun reg_save_code code = noStmts | otherwise = oneStmt (CmmAssign nodeReg (CmmLit (CmmLabel closure_lbl))) + -- 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 full_save_code = node_asst `plusStmts` reg_save_code @@ -342,7 +354,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) @@ -356,14 +368,14 @@ altHeapCheck alt_type code 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} @@ -401,7 +413,7 @@ unbxTupleHeapCheck regs ptrs nptrs fail_code code assign_liveness = CmmAssign (CmmGlobal (VanillaReg 9)) -- 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} @@ -465,7 +477,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 @@ -508,7 +520,7 @@ 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 = CmmLit (CmmLabel (mkRtsCodeLabel (sLit "stg_gc_gen"))) stg_gc_enter1 = CmmReg (CmmGlobal GCEnter1) \end{code}