X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FnativeGen%2FAbsCStixGen.lhs;h=426ae3cb5f62a5a1cede154c6bf43fc2f530a5e5;hb=7abd5f3d3f23d8520edb60b6d4d3df9e99fba12b;hp=90d2868ed5a93e65271c7d88d18086281fc10529;hpb=0d1a15fd5f3396ae711483b446c4b982083e5c87;p=ghc-hetmet.git diff --git a/ghc/compiler/nativeGen/AbsCStixGen.lhs b/ghc/compiler/nativeGen/AbsCStixGen.lhs index 90d2868..426ae3c 100644 --- a/ghc/compiler/nativeGen/AbsCStixGen.lhs +++ b/ghc/compiler/nativeGen/AbsCStixGen.lhs @@ -26,15 +26,14 @@ import CLabel ( CLabel, mkReturnInfoLabel, mkReturnPtLabel, mkClosureTblLabel, mkClosureLabel, labelDynamic, mkSplitMarkerLabel ) import ClosureInfo ( infoTableLabelFromCI, entryLabelFromCI, - fastLabelFromCI, closureUpdReqd, - staticClosureNeedsLink + closureLabelFromCI, fastLabelFromCI ) import Literal ( Literal(..), word2IntLit ) -import Maybes ( Maybe012(..), maybeToBool ) +import Maybes ( maybeToBool ) import StgSyn ( StgOp(..) ) -import MachOp ( MachOp(..), resultRepsOfMachOp ) +import MachOp ( MachOp(..), resultRepOfMachOp ) import PrimRep ( isFloatingRep, is64BitRep, - PrimRep(..), getPrimRepArrayElemSize ) + PrimRep(..), getPrimRepSizeInBytes ) import StixInfo ( genCodeInfoTable, genBitmapInfoTable, livenessIsSmall, bitmapToIntegers ) import StixMacro ( macroCode, checkCode ) @@ -50,7 +49,7 @@ import CmdLineOpts ( opt_Static, opt_EnsureSplittableC ) import Outputable ( assertPanic ) -- DEBUGGING ONLY ---import IOExts ( trace ) +--import TRACE ( trace ) --import Outputable ( showSDoc ) --import MachOp ( pprMachOp ) @@ -89,7 +88,7 @@ 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 closure_info _ _) = genCodeStaticClosure stmt `thenUs` \ code -> returnUs ( if opt_Static @@ -99,6 +98,8 @@ Here we handle top-level things, like @CCodeBlock@s and : StData PtrRep [StInt 0] -- DLLised world, need extra zero word : StLabel lbl : code [] ) + where + lbl = closureLabelFromCI closure_info gentopcode stmt@(CRetVector lbl _ _ _) = genCodeVecTbl stmt `thenUs` \ code -> @@ -110,8 +111,8 @@ Here we handle top-level things, like @CCodeBlock@s and -- 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. + -- 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) @@ -180,7 +181,7 @@ Here we handle top-level things, like @CCodeBlock@s and (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 -> @@ -188,6 +189,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), @@ -226,39 +229,22 @@ Here we handle top-level things, like @CCodeBlock@s and :: AbstractC -> UniqSM StixTreeList -} - genCodeStaticClosure (CStaticClosure _ cl_info cost_centre amodes) + genCodeStaticClosure (CStaticClosure 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 - | getPrimRepArrayElemSize pk >= getPrimRepArrayElemSize 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. @@ -411,58 +397,11 @@ 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 (Just1 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 - ) - - gencode (CMachOpStmt Just0 (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 - ) - - -- Gruesome cases for multiple-result primops - gencode (CMachOpStmt (Just2 r1 r2) mop [arg1, arg2] vols) - | mop `elem` [MO_NatS_AddC, MO_NatS_SubC, MO_NatS_MulC] - = getUniqueUs `thenUs` \ u1 -> - getUniqueUs `thenUs` \ u2 -> - let vr1 = StixVReg u1 IntRep - vr2 = StixVReg u2 IntRep - r1s = a2stix r1 - r2s = a2stix r2 - in - returnUs (\xs -> - StAssignMachOp (Just2 vr1 vr2) mop [a2stix arg1, a2stix arg2] - : mkStAssign IntRep r1s (StReg (StixTemp vr1)) - : mkStAssign IntRep r2s (StReg (StixTemp vr2)) - : xs - ) - - -- Ordinary MachOps are passed through unchanged. - - gencode (CMachOpStmt (Just1 r1) mop args vols) - = let (Just1 rep) = resultRepsOfMachOp mop - in - 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} Now the dreaded conditional jump.