X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FnativeGen%2FAbsCStixGen.lhs;h=c85e6d3c163c2d52b3cb328f80e849f48bdab217;hb=0377a8dbdd87285c650736cd072ee5c650624b79;hp=08dce9fe378234b10336eedd2e5200ff3e754d09;hpb=7790cbadc7e21fb726128005a411a2afb24e815f;p=ghc-hetmet.git diff --git a/ghc/compiler/nativeGen/AbsCStixGen.lhs b/ghc/compiler/nativeGen/AbsCStixGen.lhs index 08dce9f..c85e6d3 100644 --- a/ghc/compiler/nativeGen/AbsCStixGen.lhs +++ b/ghc/compiler/nativeGen/AbsCStixGen.lhs @@ -14,32 +14,39 @@ import Stix import MachMisc import AbsCUtils ( getAmodeRep, mixedTypeLocn, - nonemptyAbsC, mkAbsCStmts, mkAbsCStmtList + nonemptyAbsC, mkAbsCStmts ) +import PprAbsC ( dumpRealC ) import SMRep ( fixedItblSize, rET_SMALL, rET_BIG, rET_VEC_SMALL, rET_VEC_BIG ) import Constants ( mIN_UPD_SIZE ) -import CLabel ( CLabel, mkReturnInfoLabel, mkReturnPtLabel ) +import CLabel ( CLabel, mkReturnInfoLabel, mkReturnPtLabel, + mkClosureTblLabel, mkClosureLabel, + labelDynamic, mkSplitMarkerLabel ) import ClosureInfo ( infoTableLabelFromCI, entryLabelFromCI, - fastLabelFromCI, closureUpdReqd + fastLabelFromCI, closureUpdReqd, + staticClosureNeedsLink ) -import Const ( Literal(..) ) +import Literal ( Literal(..), word2IntLit ) import Maybes ( maybeToBool ) +import StgSyn ( StgOp(..) ) import PrimOp ( primOpNeedsWrapper, PrimOp(..) ) import PrimRep ( isFloatingRep, PrimRep(..) ) -import StixInfo ( genCodeInfoTable, genBitmapInfoTable ) +import StixInfo ( genCodeInfoTable, genBitmapInfoTable, + livenessIsSmall, bitmapToIntegers ) import StixMacro ( macroCode, checkCode ) -import StixPrim ( primCode, amodeToStix, amodeToStix' ) +import StixPrim ( primCode, foreignCallCode, amodeToStix, amodeToStix' ) +import Outputable ( pprPanic, ppr ) import UniqSupply ( returnUs, thenUs, mapUs, getUniqueUs, UniqSM ) import Util ( naturalMergeSortLe ) import Panic ( panic ) -import BitSet ( intBS ) - -#ifdef REALLY_HASKELL_1_3 -ord = fromEnum :: Char -> Int -#endif +import TyCon ( tyConDataCons ) +import DataCon ( dataConWrapId ) +import Name ( NamedThing(..) ) +import CmdLineOpts ( opt_Static, opt_EnsureSplittableC ) +import Outputable ( assertPanic ) \end{code} For each independent chunk of AbstractC code, we generate a list of @@ -48,11 +55,10 @@ We leave the chunks separated so that register allocation can be performed locally within the chunk. \begin{code} -genCodeAbstractC :: AbstractC -> UniqSM [[StixTree]] +genCodeAbstractC :: AbstractC -> UniqSM [StixTree] genCodeAbstractC absC - = mapUs gentopcode (mkAbsCStmtList absC) `thenUs` \ trees -> - returnUs ([StComment SLIT("Native Code")] : trees) + = gentopcode absC where a2stix = amodeToStix a2stix' = amodeToStix' @@ -73,17 +79,34 @@ Here we handle top-level things, like @CCodeBlock@s and -> UniqSM [StixTree] -} - gentopcode (CCodeBlock label absC) + gentopcode (CCodeBlock lbl absC) = gencode absC `thenUs` \ code -> - returnUs (StSegment TextSegment : StFunBegin label : code [StFunEnd label]) + returnUs (StSegment TextSegment : StFunBegin lbl : code [StFunEnd lbl]) - gentopcode stmt@(CStaticClosure label _ _ _) + gentopcode stmt@(CStaticClosure lbl _ _ _) = genCodeStaticClosure stmt `thenUs` \ code -> - returnUs (StSegment DataSegment : StLabel label : code []) - - gentopcode stmt@(CRetVector label _ _ _) + 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 [] + ) + + gentopcode stmt@(CRetVector lbl _ _ _) = genCodeVecTbl stmt `thenUs` \ code -> - returnUs (StSegment TextSegment : code [StLabel label]) + 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@(CRetDirect uniq absC srt liveness) = gencode absC `thenUs` \ code -> @@ -93,11 +116,9 @@ Here we handle top-level things, like @CCodeBlock@s and where lbl_info = mkReturnInfoLabel uniq lbl_ret = mkReturnPtLabel uniq - closure_type = case liveness of - LvSmall _ -> rET_SMALL - LvLarge _ -> rET_BIG + closure_type = if livenessIsSmall liveness then rET_SMALL else rET_BIG - gentopcode stmt@(CClosureInfoAndCode cl_info slow Nothing _ _) + gentopcode stmt@(CClosureInfoAndCode cl_info slow Nothing _) | slow_is_empty = genCodeInfoTable stmt `thenUs` \ itbl -> @@ -112,7 +133,7 @@ Here we handle top-level things, like @CCodeBlock@s and slow_is_empty = not (maybeToBool (nonemptyAbsC slow)) slow_lbl = entryLabelFromCI cl_info - gentopcode stmt@(CClosureInfoAndCode cl_info slow (Just fast) _ _) = + gentopcode stmt@(CClosureInfoAndCode cl_info slow (Just fast) _) = -- ToDo: what if this is empty? ------------------------^^^^ genCodeInfoTable stmt `thenUs` \ itbl -> gencode slow `thenUs` \ slow_code -> @@ -127,20 +148,55 @@ Here we handle top-level things, like @CCodeBlock@s and gentopcode stmt@(CSRT lbl closures) = returnUs [ StSegment TextSegment , StLabel lbl - , StData DataPtrRep (map StCLbl closures) + , StData DataPtrRep (map mk_StCLbl_for_SRT closures) ] + where + mk_StCLbl_for_SRT :: CLabel -> StixTree + mk_StCLbl_for_SRT label + | labelDynamic label + = StIndex Int8Rep (StCLbl label) (StInt 1) + | otherwise + = StCLbl label gentopcode stmt@(CBitmap lbl mask) - = returnUs [ StSegment TextSegment - , StLabel lbl - , StData WordRep (StInt (toInteger (length mask)) : - map (StInt . toInteger . intBS) mask) - ] + = returnUs $ case bitmapToIntegers mask of + mask'@(_:_:_) -> + [ StSegment TextSegment + , StLabel lbl + , StData WordRep (map StInt (toInteger (length mask') : mask')) + ] + _ -> [] + + gentopcode stmt@(CClosureTbl tycon) + = returnUs [ StSegment TextSegment + , StLabel (mkClosureTblLabel tycon) + , StData DataPtrRep (map (StCLbl . mkClosureLabel . getName . dataConWrapId) + (tyConDataCons tycon) ) + ] + + gentopcode stmt@(CModuleInitBlock lbl absC) + = gencode absC `thenUs` \ code -> + getUniqLabelNCG `thenUs` \ tmp_lbl -> + getUniqLabelNCG `thenUs` \ flag_lbl -> + returnUs ( StSegment DataSegment + : StLabel flag_lbl + : StData IntRep [StInt 0] + : StSegment TextSegment + : StLabel lbl + : StCondJump tmp_lbl (StPrim IntNeOp + [StInd IntRep (StCLbl flag_lbl), + StInt 0]) + : StAssign IntRep (StInd IntRep (StCLbl flag_lbl)) (StInt 1) + : code + [ StLabel tmp_lbl + , StAssign PtrRep stgSp + (StIndex PtrRep stgSp (StInt (-1))) + , StJump NoDestInfo (StInd WordRep stgSp) + ]) gentopcode absC = gencode absC `thenUs` \ code -> returnUs (StSegment TextSegment : code []) - \end{code} \begin{code} @@ -149,14 +205,12 @@ Here we handle top-level things, like @CCodeBlock@s and :: AbstractC -> UniqSM StixTreeList -} - genCodeVecTbl (CRetVector label amodes srt liveness) + 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 = case liveness of - LvSmall _ -> rET_VEC_SMALL - LvLarge _ -> rET_VEC_BIG + closure_type = if livenessIsSmall liveness then rET_VEC_SMALL else rET_VEC_BIG \end{code} @@ -170,15 +224,25 @@ Here we handle top-level things, like @CCodeBlock@s and = returnUs (\xs -> table ++ xs) where table = StData PtrRep [StCLbl (infoTableLabelFromCI cl_info)] : - map (\amode -> StData (getAmodeRep amode) [a2stix amode]) amodes ++ - [StData PtrRep padding_wds] + map do_one_amode amodes ++ + [StData PtrRep (padding_wds ++ static_link)] - -- always at least one padding word: this is the static link field - -- for the garbage collector. - padding_wds = if closureUpdReqd cl_info then - take (1 + max 0 (mIN_UPD_SIZE - length amodes)) zeros - else - [StInt 0] + do_one_amode amode + = StData (promote_to_word (getAmodeRep amode)) [a2stix amode] + + -- We need to promote any item smaller than a word to a word + promote_to_word pk + | sizeOf pk >= sizeOf IntRep = pk + | otherwise = IntRep + + upd_reqd = closureUpdReqd cl_info + + padding_wds + | upd_reqd = take (max 0 (mIN_UPD_SIZE - length amodes)) zeros + | otherwise = [] + + static_link | upd_reqd || staticClosureNeedsLink cl_info = [StInt 0] + | otherwise = [] zeros = StInt 0 : zeros @@ -209,11 +273,14 @@ Now the individual AbstractC statements. \end{code} -Split markers are a NOP in this land. +Split markers just insert a __stg_split_marker, which is caught by the +split-mangler later on and used to split the assembly into chunks. \begin{code} - gencode CSplitMarker = returnUs id + gencode CSplitMarker + | opt_EnsureSplittableC = returnUs (\xs -> StLabel mkSplitMarkerLabel : xs) + | otherwise = returnUs id \end{code} @@ -239,10 +306,10 @@ addresses, etc.) gencode (CInitHdr cl_info reg_rel _) = let - lhs = a2stix (CVal reg_rel PtrRep) + lhs = a2stix reg_rel lbl = infoTableLabelFromCI cl_info in - returnUs (\xs -> StAssign PtrRep lhs (StCLbl lbl) : xs) + returnUs (\xs -> StAssign PtrRep (StInd PtrRep lhs) (StCLbl lbl) : xs) \end{code} @@ -288,22 +355,22 @@ which varies depending on whether we're profiling etc. \begin{code} gencode (CJump dest) - = returnUs (\xs -> StJump (a2stix dest) : xs) + = returnUs (\xs -> StJump NoDestInfo (a2stix dest) : xs) gencode (CFallThrough (CLbl lbl _)) = returnUs (\xs -> StFallThrough lbl : xs) gencode (CReturn dest DirectReturn) - = returnUs (\xs -> StJump (a2stix dest) : xs) + = returnUs (\xs -> StJump NoDestInfo (a2stix dest) : xs) gencode (CReturn table (StaticVectoredReturn n)) - = returnUs (\xs -> StJump dest : xs) + = returnUs (\xs -> StJump NoDestInfo dest : xs) where dest = StInd PtrRep (StIndex PtrRep (a2stix table) (StInt (toInteger (-n-fixedItblSize-1)))) gencode (CReturn table (DynamicVectoredReturn am)) - = returnUs (\xs -> StJump dest : xs) + = returnUs (\xs -> StJump NoDestInfo dest : xs) where dest = StInd PtrRep (StIndex PtrRep (a2stix table) dyn_off) dyn_off = StPrim IntSubOp [StPrim IntNegOp [a2stix am], @@ -314,12 +381,15 @@ which varies depending on whether we're profiling etc. Now the PrimOps, some of which may need caller-saves register wrappers. \begin{code} + gencode (COpStmt results (StgFCallOp fcall _) args vols) + = ASSERT( null vols ) + foreignCallCode (nonVoid results) fcall (nonVoid args) - gencode (COpStmt results op args vols) + gencode (COpStmt results (StgPrimOp op) args vols) -- ToDo (ADR?): use that liveness mask | primOpNeedsWrapper op = let - saves = volsaves vols + saves = volsaves vols restores = volrestores vols in p2stix (nonVoid results) op (nonVoid args) @@ -327,9 +397,6 @@ Now the PrimOps, some of which may need caller-saves register wrappers. returnUs (\xs -> saves ++ code (restores ++ xs)) | otherwise = p2stix (nonVoid results) op (nonVoid args) - where - nonVoid = filter ((/= VoidRep) . getAmodeRep) - \end{code} Now the dreaded conditional jump. @@ -358,8 +425,8 @@ Now the if statement. Almost *all* flow of control are of this form. Nothing -> gencode alt_code Just dc -> mkIfThenElse discrim tag alt_code dc - [(tag1@(MachInt i1 _), alt_code1), - (tag2@(MachInt i2 _), alt_code2)] + [(tag1@(MachInt i1), alt_code1), + (tag2@(MachInt i2), alt_code2)] | deflt_is_empty && i1 == 0 && i2 == 1 -> mkIfThenElse discrim tag1 alt_code1 alt_code2 | deflt_is_empty && i1 == 1 && i2 == 0 @@ -402,6 +469,12 @@ Finally, all of the disgusting AbstractC macros. gencode (CCallProfCCMacro macro _) = returnUs (\xs -> StComment macro : xs) + gencode CCallTypedef{} = returnUs id + + gencode other + = pprPanic "AbsCStixGen.gencode" (dumpRealC other) + + nonVoid = filter ((/= VoidRep) . getAmodeRep) \end{code} Here, we generate a jump table if there are more than four (integer) @@ -412,15 +485,16 @@ be tuned.) \begin{code} intTag :: Literal -> Integer - intTag (MachChar c) = fromInt (ord c) - intTag (MachInt i _) = i - intTag _ = panic "intTag" + intTag (MachChar c) = toInteger c + intTag (MachInt i) = i + intTag (MachWord w) = intTag (word2IntLit (MachWord w)) + intTag _ = panic "intTag" fltTag :: Literal -> Rational - fltTag (MachFloat f) = f + fltTag (MachFloat f) = f fltTag (MachDouble d) = d - fltTag _ = panic "fltTag" + fltTag x = pprPanic "fltTag" (ppr x) {- mkSimpleSwitches @@ -443,12 +517,14 @@ be tuned.) highest = if floating then targetMaxDouble else targetMaxInt in ( - if not floating && choices > 4 && highTag - lowTag < toInteger (2 * choices) then + if not floating && choices > 4 + && highTag - lowTag < toInteger (2 * choices) + then mkJumpTable am' sortedAlts lowTag highTag udlbl else mkBinaryTree am' floating sortedAlts choices lowest highest udlbl ) - `thenUs` \ alt_code -> + `thenUs` \ alt_code -> gencode absC `thenUs` \ dflt_code -> returnUs (\xs -> alt_code (StLabel udlbl : dflt_code (StLabel ujlbl : xs))) @@ -458,7 +534,8 @@ be tuned.) choices = length alts (x@(MachChar _),_) `leAlt` (y,_) = intTag x <= intTag y - (x@(MachInt _ _),_) `leAlt` (y,_) = intTag x <= intTag y + (x@(MachInt _), _) `leAlt` (y,_) = intTag x <= intTag y + (x@(MachWord _), _) `leAlt` (y,_) = intTag x <= intTag y (x,_) `leAlt` (y,_) = fltTag x <= fltTag y \end{code} @@ -491,8 +568,9 @@ already finish with a jump to the join point. cjmpHi = StCondJump dflt (StPrim IntGtOp [am, StInt (toInteger highTag)]) offset = StPrim IntSubOp [am, StInt lowTag] + dsts = DestInfo (dflt : map fst branches) - jump = StJump (StInd PtrRep (StIndex PtrRep (StCLbl utlbl) offset)) + jump = StJump dsts (StInd PtrRep (StIndex PtrRep (StCLbl utlbl) offset)) tlbl = StLabel utlbl table = StData PtrRep (mkTable branches [lowTag..highTag] []) in