X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FnativeGen%2FAbsCStixGen.lhs;h=784b2c118163934ec67f2d12a10aa752c15efe77;hb=3087014ae03067cf0f9c9e0d8d49fb885e2cd0a8;hp=dcaba25709d459a6065f2a8a97112c03fe318256;hpb=93c01cb974548f29d95b556703af42455a90b9a6;p=ghc-hetmet.git diff --git a/ghc/compiler/nativeGen/AbsCStixGen.lhs b/ghc/compiler/nativeGen/AbsCStixGen.lhs index dcaba25..784b2c1 100644 --- a/ghc/compiler/nativeGen/AbsCStixGen.lhs +++ b/ghc/compiler/nativeGen/AbsCStixGen.lhs @@ -17,36 +17,33 @@ 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 ) +import SMRep ( retItblSize ) import CLabel ( CLabel, mkReturnInfoLabel, mkReturnPtLabel, mkClosureTblLabel, mkClosureLabel, labelDynamic, mkSplitMarkerLabel ) -import ClosureInfo ( infoTableLabelFromCI, entryLabelFromCI, - fastLabelFromCI, closureUpdReqd, - staticClosureNeedsLink - ) +import ClosureInfo import Literal ( Literal(..), word2IntLit ) -import Maybes ( maybeToBool ) import StgSyn ( StgOp(..) ) -import PrimOp ( primOpNeedsWrapper, PrimOp(..) ) -import PrimRep ( isFloatingRep, PrimRep(..) ) -import StixInfo ( genCodeInfoTable, genBitmapInfoTable ) +import MachOp ( MachOp(..), resultRepOfMachOp ) +import PrimRep ( isFloatingRep, is64BitRep, + PrimRep(..), getPrimRepSizeInBytes ) import StixMacro ( macroCode, checkCode ) -import StixPrim ( primCode, foreignCallCode, amodeToStix, amodeToStix' ) +import StixPrim ( 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 CmdLineOpts ( opt_Static, opt_EnsureSplittableC ) +import CmdLineOpts ( opt_EnsureSplittableC ) import Outputable ( assertPanic ) + +-- DEBUGGING ONLY +--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 @@ -55,7 +52,7 @@ 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 [StixStmt] genCodeAbstractC absC = gentopcode absC @@ -64,8 +61,6 @@ genCodeAbstractC absC a2stix' = amodeToStix' volsaves = volatileSaves volrestores = volatileRestores - p2stix = primCode - macro_code = macroCode -- real code follows... --------- \end{code} @@ -83,59 +78,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 lbl _ _ _) + 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 [] - ) - - gentopcode stmt@(CRetVector lbl _ _ _) - = genCodeVecTbl stmt `thenUs` \ code -> - returnUs (StSegment TextSegment : code [StLabel lbl]) + returnUs ( StSegment DataSegment + : StLabel lbl : code [] + ) + + 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 = case liveness of - LvSmall _ -> rET_SMALL - LvLarge _ -> 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 @@ -143,28 +123,38 @@ Here we handle top-level things, like @CCodeBlock@s and , StData DataPtrRep (map mk_StCLbl_for_SRT closures) ] where - mk_StCLbl_for_SRT :: CLabel -> StixTree + mk_StCLbl_for_SRT :: CLabel -> StixExpr 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) - ] + 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 -> @@ -172,16 +162,18 @@ 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 (StPrim IntNeOp + : StCondJump tmp_lbl (StMachOp MO_Nat_Ne [StInd IntRep (StCLbl flag_lbl), StInt 0]) - : StAssign IntRep (StInd IntRep (StCLbl flag_lbl)) (StInt 1) + : StAssignMem IntRep (StCLbl flag_lbl) (StInt 1) : code [ StLabel tmp_lbl - , StAssign PtrRep stgSp - (StIndex PtrRep stgSp (StInt (-1))) - , StJump NoDestInfo (StInd WordRep stgSp) + , StAssignReg PtrRep stgSp + (StIndex PtrRep (StReg stgSp) (StInt (-1))) + , StJump NoDestInfo (StInd WordRep (StReg stgSp)) ]) gentopcode absC @@ -191,60 +183,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 = case liveness of - LvSmall _ -> rET_VEC_SMALL - LvLarge _ -> 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 ++ - [StData PtrRep (padding_wds ++ static_link)] + 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 - | 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 - - {- needed??? --SDM - -- Watch out for VoidKinds...cf. PprAbsC - amodeZeroVoid item - | getAmodeRep item == VoidRep = StInt 0 - | otherwise = a2stix item - -} - + | getPrimRepSizeInBytes pk >= getPrimRepSizeInBytes IntRep = pk + | otherwise = IntRep \end{code} Now the individual AbstractC statements. @@ -286,6 +244,14 @@ resulting StixTreeLists are joined together. gencode c2 `thenUs` \ b2 -> returnUs (b1 . b2) + gencode (CSequential stuff) + = foo stuff + where + foo [] = returnUs id + foo (s:ss) = gencode s `thenUs` \ stix -> + foo ss `thenUs` \ stixes -> + returnUs (stix . stixes) + \end{code} Initialising closure headers in the heap...a fairly complex ordeal if @@ -296,12 +262,12 @@ 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 in - returnUs (\xs -> StAssign PtrRep (StInd PtrRep lhs) (StCLbl lbl) : xs) + returnUs (\xs -> StAssignMem PtrRep lhs (StCLbl lbl) : xs) \end{code} @@ -325,14 +291,23 @@ of the source? Be careful about floats/doubles. \begin{code} gencode (CAssign lhs rhs) - | getAmodeRep lhs == VoidRep = returnUs id + | lhs_rep == VoidRep + = returnUs id | otherwise - = let pk = getAmodeRep lhs - pk' = if mixedTypeLocn lhs && not (isFloatingRep pk) then IntRep else pk + = let -- This is a Hack. Should be cleaned up. + -- JRS, 10 Dec 01 + pk' | ncg_target_is_32bit && is64BitRep lhs_rep + = lhs_rep + | otherwise + = if mixedTypeLocn lhs && not (isFloatingRep lhs_rep) + then IntRep + else lhs_rep lhs' = a2stix lhs rhs' = a2stix' rhs in - returnUs (\xs -> StAssign pk' lhs' rhs' : xs) + returnUs (\xs -> mkStAssign pk' lhs' rhs' : xs) + where + lhs_rep = getAmodeRep lhs \end{code} @@ -359,14 +334,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 = StPrim IntSubOp [StPrim IntNegOp [a2stix am], - StInt (toInteger (fixedItblSize+1))] + dyn_off = StMachOp MO_Nat_Sub [StMachOp MO_NatS_Neg [a2stix am], + StInt (toInteger (retItblSize+1))] \end{code} @@ -378,17 +353,13 @@ Now the PrimOps, some of which may need caller-saves register wrappers. foreignCallCode (nonVoid results) fcall (nonVoid args) gencode (COpStmt results (StgPrimOp op) args vols) - -- ToDo (ADR?): use that liveness mask - | primOpNeedsWrapper op - = let - saves = volsaves vols - restores = volrestores vols - in - p2stix (nonVoid results) op (nonVoid args) - `thenUs` \ code -> - returnUs (\xs -> saves ++ code (restores ++ xs)) + = panic "AbsCStixGen.gencode: un-translated PrimOp" - | otherwise = p2stix (nonVoid results) op (nonVoid args) + gencode (CMachOpStmt res mop args vols) + = returnUs (\xs -> mkStAssign (resultRepOfMachOp mop) (a2stix res) + (StMachOp mop (map a2stix args)) + : xs + ) \end{code} Now the dreaded conditional jump. @@ -453,7 +424,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) @@ -461,6 +432,8 @@ 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) @@ -554,10 +527,10 @@ already finish with a jump to the join point. mkJumpTable am alts lowTag highTag dflt = getUniqLabelNCG `thenUs` \ utlbl -> mapUs genLabel alts `thenUs` \ branches -> - let cjmpLo = StCondJump dflt (StPrim IntLtOp [am, StInt (toInteger lowTag)]) - cjmpHi = StCondJump dflt (StPrim IntGtOp [am, StInt (toInteger highTag)]) + let cjmpLo = StCondJump dflt (StMachOp MO_NatS_Lt [am, StInt (toInteger lowTag)]) + cjmpHi = StCondJump dflt (StMachOp MO_NatS_Gt [am, StInt (toInteger highTag)]) - offset = StPrim IntSubOp [am, StInt lowTag] + offset = StMachOp MO_Nat_Sub [am, StInt lowTag] dsts = DestInfo (dflt : map fst branches) jump = StJump dsts (StInd PtrRep (StIndex PtrRep (StCLbl utlbl) offset)) @@ -614,8 +587,8 @@ alternatives should already finish with a jump to the join point. | rangeOfOne = gencode alt | otherwise = let tag' = a2stix (CLit tag) - cmpOp = if floating then DoubleNeOp else IntNeOp - test = StPrim cmpOp [am, tag'] + cmpOp = if floating then MO_Dbl_Ne else MO_Nat_Ne + test = StMachOp cmpOp [am, tag'] cjmp = StCondJump udlbl test in gencode alt `thenUs` \ alt_code -> @@ -628,8 +601,8 @@ alternatives should already finish with a jump to the join point. mkBinaryTree am floating alts choices lowTag highTag udlbl = getUniqLabelNCG `thenUs` \ uhlbl -> let tag' = a2stix (CLit splitTag) - cmpOp = if floating then DoubleGeOp else IntGeOp - test = StPrim cmpOp [am, tag'] + cmpOp = if floating then MO_Dbl_Ge else MO_NatS_Ge + test = StMachOp cmpOp [am, tag'] cjmp = StCondJump uhlbl test in mkBinaryTree am floating alts_lo half lowTag splitTag udlbl @@ -661,8 +634,8 @@ alternatives should already finish with a jump to the join point. getUniqLabelNCG `thenUs` \ utlbl -> let discrim' = a2stix discrim tag' = a2stix (CLit tag) - cmpOp = if (isFloatingRep (getAmodeRep discrim)) then DoubleNeOp else IntNeOp - test = StPrim cmpOp [discrim', tag'] + cmpOp = if (isFloatingRep (getAmodeRep discrim)) then MO_Dbl_Ne else MO_Nat_Ne + test = StMachOp cmpOp [discrim', tag'] cjmp = StCondJump utlbl test dest = StLabel utlbl join = StLabel ujlbl @@ -671,8 +644,8 @@ alternatives should already finish with a jump to the join point. gencode deflt `thenUs` \ dflt_code -> returnUs (\xs -> cjmp : alt_code (dest : dflt_code (join : xs))) -mkJoin :: AbstractC -> CLabel -> AbstractC +mkJoin :: AbstractC -> CLabel -> AbstractC mkJoin code lbl | mightFallThrough code = mkAbsCStmts code (CJump (CLbl lbl PtrRep)) | otherwise = code