X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FnativeGen%2FAbsCStixGen.lhs;h=4a53f1437fcfcc88a18889695ea2c9fa0c5e4d87;hb=553e90d9a32ee1b1809430f260c401cc4169c6c7;hp=888d1291180db9a414e2f723fd4581b0af812999;hpb=2c71b5dbed008d1d8752b722755143e797debb9d;p=ghc-hetmet.git diff --git a/ghc/compiler/nativeGen/AbsCStixGen.lhs b/ghc/compiler/nativeGen/AbsCStixGen.lhs index 888d129..4a53f14 100644 --- a/ghc/compiler/nativeGen/AbsCStixGen.lhs +++ b/ghc/compiler/nativeGen/AbsCStixGen.lhs @@ -17,25 +17,16 @@ import AbsCUtils ( getAmodeRep, mixedTypeLocn, nonemptyAbsC, mkAbsCStmts ) import PprAbsC ( dumpRealC ) -import SMRep ( fixedItblSize, - rET_SMALL, rET_BIG, - rET_VEC_SMALL, rET_VEC_BIG - ) -import Constants ( mIN_UPD_SIZE, wORD_SIZE ) +import SMRep ( retItblSize ) import CLabel ( CLabel, mkReturnInfoLabel, mkReturnPtLabel, mkClosureTblLabel, mkClosureLabel, labelDynamic, mkSplitMarkerLabel ) -import ClosureInfo ( infoTableLabelFromCI, entryLabelFromCI, - closureLabelFromCI, fastLabelFromCI - ) +import ClosureInfo import Literal ( Literal(..), word2IntLit ) -import Maybes ( maybeToBool ) import StgSyn ( StgOp(..) ) -import MachOp ( MachOp(..), resultRepsOfMachOp ) +import MachOp ( MachOp(..), resultRepOfMachOp ) import PrimRep ( isFloatingRep, is64BitRep, - PrimRep(..), getPrimRepArrayElemSize ) -import StixInfo ( genCodeInfoTable, genBitmapInfoTable, - livenessIsSmall, bitmapToIntegers ) + PrimRep(..), getPrimRepSizeInBytes ) import StixMacro ( macroCode, checkCode ) import StixPrim ( foreignCallCode, amodeToStix, amodeToStix' ) import Outputable ( pprPanic, ppr ) @@ -43,16 +34,18 @@ import UniqSupply ( returnUs, thenUs, mapUs, getUniqueUs, UniqSM ) import Util ( naturalMergeSortLe ) import Panic ( panic ) import TyCon ( tyConDataCons ) -import DataCon ( dataConWrapId ) import Name ( NamedThing(..) ) -import CmdLineOpts ( opt_Static, opt_EnsureSplittableC ) +import CmdLineOpts ( opt_EnsureSplittableC ) import Outputable ( assertPanic ) +import Char ( ord ) + -- DEBUGGING ONLY ---import IOExts ( trace ) +--import TRACE ( trace ) --import Outputable ( showSDoc ) --import MachOp ( pprMachOp ) +#include "nativeGen/NCG.h" \end{code} For each independent chunk of AbstractC code, we generate a list of @@ -70,7 +63,6 @@ genCodeAbstractC absC a2stix' = amodeToStix' volsaves = volatileSaves volrestores = volatileRestores - macro_code = macroCode -- real code follows... --------- \end{code} @@ -88,69 +80,44 @@ Here we handle top-level things, like @CCodeBlock@s and = gencode absC `thenUs` \ code -> returnUs (StSegment TextSegment : StFunBegin lbl : code [StFunEnd lbl]) - gentopcode stmt@(CStaticClosure closure_info _ _) + gentopcode stmt@(CStaticClosure lbl closure_info _ _) = genCodeStaticClosure stmt `thenUs` \ code -> - returnUs ( - if opt_Static - then StSegment DataSegment - : StLabel lbl : code [] - else StSegment DataSegment - : StData PtrRep [StInt 0] -- DLLised world, need extra zero word - : StLabel lbl : code [] - ) - where - lbl = closureLabelFromCI closure_info + returnUs ( StSegment DataSegment + : StLabel lbl : code [] + ) - gentopcode stmt@(CRetVector lbl _ _ _) - = genCodeVecTbl stmt `thenUs` \ code -> - returnUs (StSegment TextSegment - : code [StLabel lbl, vtbl_post_label_word]) - where - -- We put a dummy word after the vtbl label so as to ensure the label - -- is in the same (Text) section as the vtbl it labels. This is critical - -- for ensuring the GC works correctly, although GC crashes due to - -- misclassification are much more likely to show up in the interactive - -- system than in compile code. For details see comment near line 1164 - -- of ghc/driver/mangler/ghc-asm.lprl, which contains an analogous fix - -- for the mangled via-C route. - vtbl_post_label_word = StData PtrRep [StInt 0] + gentopcode stmt@(CRetVector lbl amodes srt liveness) + = returnUs ( StSegment TextSegment + : StData PtrRep table + : StLabel lbl + : [] + ) + where + table = map amodeToStix (mkVecInfoTable amodes srt liveness) gentopcode stmt@(CRetDirect uniq absC srt liveness) = gencode absC `thenUs` \ code -> - genBitmapInfoTable liveness srt closure_type False `thenUs` \ itbl -> - returnUs (StSegment TextSegment : - itbl (StLabel lbl_info : StLabel lbl_ret : code [])) + returnUs ( StSegment TextSegment + : StData PtrRep table + : StLabel info_lbl + : StLabel ret_lbl + : code []) where - lbl_info = mkReturnInfoLabel uniq - lbl_ret = mkReturnPtLabel uniq - closure_type = if livenessIsSmall liveness then rET_SMALL else rET_BIG - - gentopcode stmt@(CClosureInfoAndCode cl_info slow Nothing _) - - | slow_is_empty - = genCodeInfoTable stmt `thenUs` \ itbl -> - returnUs (StSegment TextSegment : itbl []) - - | otherwise - = genCodeInfoTable stmt `thenUs` \ itbl -> - gencode slow `thenUs` \ slow_code -> - returnUs (StSegment TextSegment : itbl (StFunBegin slow_lbl : - slow_code [StFunEnd slow_lbl])) - where - slow_is_empty = not (maybeToBool (nonemptyAbsC slow)) - slow_lbl = entryLabelFromCI cl_info - - gentopcode stmt@(CClosureInfoAndCode cl_info slow (Just fast) _) = - -- ToDo: what if this is empty? ------------------------^^^^ - genCodeInfoTable stmt `thenUs` \ itbl -> - gencode slow `thenUs` \ slow_code -> - gencode fast `thenUs` \ fast_code -> - returnUs (StSegment TextSegment : itbl (StFunBegin slow_lbl : - slow_code (StFunEnd slow_lbl : StFunBegin fast_lbl : - fast_code [StFunEnd fast_lbl]))) + info_lbl = mkReturnInfoLabel uniq + ret_lbl = mkReturnPtLabel uniq + table = map amodeToStix (mkRetInfoTable ret_lbl srt liveness) + + gentopcode stmt@(CClosureInfoAndCode cl_info entry) + = gencode entry `thenUs` \ slow_code -> + returnUs ( StSegment TextSegment + : StData PtrRep table + : StLabel info_lbl + : StFunBegin entry_lbl + : slow_code [StFunEnd entry_lbl]) where - slow_lbl = entryLabelFromCI cl_info - fast_lbl = fastLabelFromCI cl_info + entry_lbl = entryLabelFromCI cl_info + info_lbl = infoTableLabelFromCI cl_info + table = map amodeToStix (mkInfoTable cl_info) gentopcode stmt@(CSRT lbl closures) = returnUs [ StSegment TextSegment @@ -165,23 +132,31 @@ Here we handle top-level things, like @CCodeBlock@s and | otherwise = StCLbl label - gentopcode stmt@(CBitmap lbl mask) - = returnUs $ case bitmapToIntegers mask of - mask'@(_:_:_) -> - [ StSegment TextSegment - , StLabel lbl - , StData WordRep (map StInt (toInteger (length mask') : mask')) - ] - _ -> [] + gentopcode stmt@(CBitmap l@(Liveness lbl size mask)) + = returnUs + [ StSegment TextSegment + , StLabel lbl + , StData WordRep (map StInt (toInteger size : map toInteger mask)) + ] + + gentopcode stmt@(CSRTDesc lbl srt_lbl off len bitmap) + = returnUs + [ StSegment TextSegment + , StLabel lbl + , StData WordRep ( + StIndex PtrRep (StCLbl srt_lbl) (StInt (toInteger off)) : + map StInt (toInteger len : map toInteger bitmap) + ) + ] gentopcode stmt@(CClosureTbl tycon) = returnUs [ StSegment TextSegment , StLabel (mkClosureTblLabel tycon) - , StData DataPtrRep (map (StCLbl . mkClosureLabel . getName . dataConWrapId) + , StData DataPtrRep (map (StCLbl . mkClosureLabel . getName) (tyConDataCons tycon) ) ] - gentopcode stmt@(CModuleInitBlock lbl absC) + gentopcode stmt@(CModuleInitBlock plain_lbl lbl absC) = gencode absC `thenUs` \ code -> getUniqLabelNCG `thenUs` \ tmp_lbl -> getUniqLabelNCG `thenUs` \ flag_lbl -> @@ -189,6 +164,8 @@ Here we handle top-level things, like @CCodeBlock@s and : StLabel flag_lbl : StData IntRep [StInt 0] : StSegment TextSegment + : StLabel plain_lbl + : StJump NoDestInfo (StCLbl lbl) : StLabel lbl : StCondJump tmp_lbl (StMachOp MO_Nat_Ne [StInd IntRep (StCLbl flag_lbl), @@ -208,38 +185,26 @@ Here we handle top-level things, like @CCodeBlock@s and \begin{code} {- - genCodeVecTbl - :: AbstractC - -> UniqSM StixTreeList - -} - genCodeVecTbl (CRetVector lbl amodes srt liveness) - = genBitmapInfoTable liveness srt closure_type True `thenUs` \itbl -> - returnUs (\xs -> vectbl : itbl xs) - where - vectbl = StData PtrRep (reverse (map a2stix amodes)) - closure_type = if livenessIsSmall liveness then rET_VEC_SMALL else rET_VEC_BIG - -\end{code} - -\begin{code} - {- genCodeStaticClosure :: AbstractC -> UniqSM StixTreeList -} - genCodeStaticClosure (CStaticClosure cl_info cost_centre amodes) + genCodeStaticClosure (CStaticClosure lbl cl_info cost_centre amodes) = returnUs (\xs -> table ++ xs) where table = StData PtrRep [StCLbl (infoTableLabelFromCI cl_info)] : - map do_one_amode amodes + foldr do_one_amode [] amodes - do_one_amode amode - = StData (promote_to_word (getAmodeRep amode)) [a2stix amode] + do_one_amode amode rest + | rep == VoidRep = rest + | otherwise = StData (promote_to_word rep) [a2stix amode] : rest + where + rep = getAmodeRep amode -- We need to promote any item smaller than a word to a word promote_to_word pk - | getPrimRepArrayElemSize pk >= getPrimRepArrayElemSize IntRep = pk - | otherwise = IntRep + | getPrimRepSizeInBytes pk >= getPrimRepSizeInBytes IntRep = pk + | otherwise = IntRep \end{code} Now the individual AbstractC statements. @@ -371,14 +336,14 @@ which varies depending on whether we're profiling etc. = returnUs (\xs -> StJump NoDestInfo dest : xs) where dest = StInd PtrRep (StIndex PtrRep (a2stix table) - (StInt (toInteger (-n-fixedItblSize-1)))) + (StInt (toInteger (-n-retItblSize-1)))) gencode (CReturn table (DynamicVectoredReturn am)) = returnUs (\xs -> StJump NoDestInfo dest : xs) where dest = StInd PtrRep (StIndex PtrRep (a2stix table) dyn_off) dyn_off = StMachOp MO_Nat_Sub [StMachOp MO_NatS_Neg [a2stix am], - StInt (toInteger (fixedItblSize+1))] + StInt (toInteger (retItblSize+1))] \end{code} @@ -392,39 +357,10 @@ Now the PrimOps, some of which may need caller-saves register wrappers. gencode (COpStmt results (StgPrimOp op) args vols) = panic "AbsCStixGen.gencode: un-translated PrimOp" - -- Translate out array indexing primops right here, so that - -- individual targets don't have to deal with them - - gencode (CMachOpStmt (Just r1) (MO_ReadOSBI off_w rep) [base,index] vols) - = returnUs (\xs -> - mkStAssign - rep - (a2stix r1) - (StInd rep (StMachOp MO_Nat_Add - [StIndex rep (a2stix base) (a2stix index), - StInt (toInteger (off_w * wORD_SIZE))])) - : xs - ) - - -- Ordinary MachOps are passed through unchanged. - gencode (CMachOpStmt Nothing (MO_WriteOSBI off_w rep) [base,index,val] vols) - = returnUs (\xs -> - StAssignMem - rep - (StMachOp MO_Nat_Add - [StIndex rep (a2stix base) (a2stix index), - StInt (toInteger (off_w * wORD_SIZE))]) - (a2stix val) - : xs - ) - - gencode (CMachOpStmt (Just r1) mop args vols) - = case resultRepsOfMachOp mop of - Just rep - -> returnUs (\xs -> - mkStAssign rep (a2stix r1) - (StMachOp mop (map a2stix args)) - : xs + gencode (CMachOpStmt res mop args vols) + = returnUs (\xs -> mkStAssign (resultRepOfMachOp mop) (a2stix res) + (StMachOp mop (map a2stix args)) + : xs ) \end{code} @@ -490,7 +426,7 @@ Finally, all of the disgusting AbstractC macros. \begin{code} - gencode (CMacroStmt macro args) = macro_code macro args + gencode (CMacroStmt macro args) = macroCode macro (map amodeToStix args) gencode (CCallProfCtrMacro macro _) = returnUs (\xs -> StComment macro : xs) @@ -514,7 +450,7 @@ be tuned.) \begin{code} intTag :: Literal -> Integer - intTag (MachChar c) = toInteger c + intTag (MachChar c) = toInteger (ord c) intTag (MachInt i) = i intTag (MachWord w) = intTag (word2IntLit (MachWord w)) intTag _ = panic "intTag"