X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;ds=sidebyside;f=ghc%2Fcompiler%2FnativeGen%2FAbsCStixGen.lhs;h=5ee35ab29d7f0df525a6ba87b883717b327bc86f;hb=c36b02d9d26fe4050397bdfba60a6f92c7314e8d;hp=ebc7aeeb06e4e74d002abf422310c74a1d3e6f04;hpb=24a7fdbd94bcf4dd99daf1cf45bfbc81a09e36dd;p=ghc-hetmet.git diff --git a/ghc/compiler/nativeGen/AbsCStixGen.lhs b/ghc/compiler/nativeGen/AbsCStixGen.lhs index ebc7aee..5ee35ab 100644 --- a/ghc/compiler/nativeGen/AbsCStixGen.lhs +++ b/ghc/compiler/nativeGen/AbsCStixGen.lhs @@ -24,29 +24,29 @@ import SMRep ( fixedItblSize, import Constants ( mIN_UPD_SIZE ) import CLabel ( CLabel, mkReturnInfoLabel, mkReturnPtLabel, mkClosureTblLabel, mkClosureLabel, - moduleRegdLabel, labelDynamic, - mkSplitMarkerLabel ) + labelDynamic, mkSplitMarkerLabel ) import ClosureInfo ( infoTableLabelFromCI, entryLabelFromCI, fastLabelFromCI, closureUpdReqd, staticClosureNeedsLink ) 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 TyCon ( tyConDataCons ) import DataCon ( dataConWrapId ) -import BitSet ( intBS ) import Name ( NamedThing(..) ) -import Char ( ord ) import CmdLineOpts ( opt_Static, opt_EnsureSplittableC ) +import Outputable ( assertPanic ) \end{code} For each independent chunk of AbstractC code, we generate a list of @@ -96,7 +96,17 @@ Here we handle top-level things, like @CCodeBlock@s and gentopcode stmt@(CRetVector lbl _ _ _) = genCodeVecTbl stmt `thenUs` \ code -> - returnUs (StSegment TextSegment : code [StLabel lbl]) + 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 -> @@ -106,9 +116,7 @@ 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 _) @@ -151,11 +159,13 @@ Here we handle top-level things, like @CCodeBlock@s and = 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 @@ -181,7 +191,7 @@ Here we handle top-level things, like @CCodeBlock@s and [ StLabel tmp_lbl , StAssign PtrRep stgSp (StIndex PtrRep stgSp (StInt (-1))) - , StJump (StInd WordRep stgSp) + , StJump NoDestInfo (StInd WordRep stgSp) ]) gentopcode absC @@ -200,9 +210,7 @@ Here we handle top-level things, like @CCodeBlock@s and 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} @@ -223,19 +231,18 @@ Here we handle top-level things, like @CCodeBlock@s and = StData (promote_to_word (getAmodeRep amode)) [a2stix amode] -- We need to promote any item smaller than a word to a word - promote_to_word Int8Rep = IntRep - promote_to_word CharRep = IntRep - promote_to_word other = other + promote_to_word pk + | sizeOf pk >= sizeOf IntRep = pk + | otherwise = IntRep + + upd_reqd = closureUpdReqd cl_info - -- always at least one padding word: this is the static link field - -- for the garbage collector. - padding_wds = if closureUpdReqd cl_info then - take (max 0 (mIN_UPD_SIZE - length amodes)) zeros - else - [] + padding_wds + | upd_reqd = take (max 0 (mIN_UPD_SIZE - length amodes)) zeros + | otherwise = [] - static_link | staticClosureNeedsLink cl_info = [StInt 0] - | otherwise = [] + static_link | upd_reqd || staticClosureNeedsLink cl_info = [StInt 0] + | otherwise = [] zeros = StInt 0 : zeros @@ -297,7 +304,7 @@ addresses, etc.) \begin{code} - gencode (CInitHdr cl_info reg_rel _) + gencode (CInitHdr cl_info reg_rel _ _) = let lhs = a2stix reg_rel lbl = infoTableLabelFromCI cl_info @@ -348,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], @@ -374,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) @@ -387,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. @@ -462,8 +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) @@ -506,14 +517,14 @@ be tuned.) highest = if floating then targetMaxDouble else targetMaxInt in ( - if False && -- jump tables disabled for now until the register allocator is - -- fixed to cope with them --SDM 18/8/2000 - 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))) @@ -557,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