X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FnativeGen%2FPprMach.lhs;h=1265384ea7ae9146f7163d5cd6af585d38747d3a;hb=6e5df3a4551b8d8b83e936b3f7b52edfc778ca8a;hp=c48b86fa01588e1355037dd6eacc48fa3e826b75;hpb=0d1a15fd5f3396ae711483b446c4b982083e5c87;p=ghc-hetmet.git diff --git a/ghc/compiler/nativeGen/PprMach.lhs b/ghc/compiler/nativeGen/PprMach.lhs index c48b86f..1265384 100644 --- a/ghc/compiler/nativeGen/PprMach.lhs +++ b/ghc/compiler/nativeGen/PprMach.lhs @@ -22,10 +22,18 @@ import Stix ( CodeSegment(..) ) import Unique ( pprUnique ) import Panic ( panic ) import Pretty +import FastString import qualified Outputable -import ST +#if __GLASGOW_HASKELL__ >= 504 +import Data.Array.ST +import Data.Word ( Word8 ) +#else import MutableArray +#endif + +import MONAD_ST + import Char ( chr, ord ) import Maybe ( isJust ) @@ -168,6 +176,45 @@ pprReg IF_ARCH_i386(s,) r _ -> SLIT("very naughty sparc register") }) #endif +#if powerpc_TARGET_ARCH + ppr_reg_no :: Int -> Doc + ppr_reg_no i = ptext + (case i of { + 0 -> SLIT("r0"); 1 -> SLIT("r1"); + 2 -> SLIT("r2"); 3 -> SLIT("r3"); + 4 -> SLIT("r4"); 5 -> SLIT("r5"); + 6 -> SLIT("r6"); 7 -> SLIT("r7"); + 8 -> SLIT("r8"); 9 -> SLIT("r9"); + 10 -> SLIT("r10"); 11 -> SLIT("r11"); + 12 -> SLIT("r12"); 13 -> SLIT("r13"); + 14 -> SLIT("r14"); 15 -> SLIT("r15"); + 16 -> SLIT("r16"); 17 -> SLIT("r17"); + 18 -> SLIT("r18"); 19 -> SLIT("r19"); + 20 -> SLIT("r20"); 21 -> SLIT("r21"); + 22 -> SLIT("r22"); 23 -> SLIT("r23"); + 24 -> SLIT("r24"); 25 -> SLIT("r25"); + 26 -> SLIT("r26"); 27 -> SLIT("r27"); + 28 -> SLIT("r28"); 29 -> SLIT("r29"); + 30 -> SLIT("r30"); 31 -> SLIT("r31"); + 32 -> SLIT("f0"); 33 -> SLIT("f1"); + 34 -> SLIT("f2"); 35 -> SLIT("f3"); + 36 -> SLIT("f4"); 37 -> SLIT("f5"); + 38 -> SLIT("f6"); 39 -> SLIT("f7"); + 40 -> SLIT("f8"); 41 -> SLIT("f9"); + 42 -> SLIT("f10"); 43 -> SLIT("f11"); + 44 -> SLIT("f12"); 45 -> SLIT("f13"); + 46 -> SLIT("f14"); 47 -> SLIT("f15"); + 48 -> SLIT("f16"); 49 -> SLIT("f17"); + 50 -> SLIT("f18"); 51 -> SLIT("f19"); + 52 -> SLIT("f20"); 53 -> SLIT("f21"); + 54 -> SLIT("f22"); 55 -> SLIT("f23"); + 56 -> SLIT("f24"); 57 -> SLIT("f25"); + 58 -> SLIT("f26"); 59 -> SLIT("f27"); + 60 -> SLIT("f28"); 61 -> SLIT("f29"); + 62 -> SLIT("f30"); 63 -> SLIT("f31"); + _ -> SLIT("very naughty powerpc register") + }) +#endif \end{code} %************************************************************************ @@ -207,6 +254,8 @@ pprSize x = ptext (case x of #if sparc_TARGET_ARCH B -> SLIT("sb") Bu -> SLIT("ub") + H -> SLIT("sh") + Hu -> SLIT("uh") W -> SLIT("") F -> SLIT("") DF -> SLIT("d") @@ -215,10 +264,21 @@ pprStSize :: Size -> Doc pprStSize x = ptext (case x of B -> SLIT("b") Bu -> SLIT("b") + H -> SLIT("h") + Hu -> SLIT("h") W -> SLIT("") F -> SLIT("") DF -> SLIT("d") #endif +#if powerpc_TARGET_ARCH + B -> SLIT("b") + Bu -> SLIT("b") + H -> SLIT("h") + Hu -> SLIT("h") + W -> SLIT("w") + F -> SLIT("fs") + DF -> SLIT("fd") +#endif ) \end{code} @@ -262,6 +322,14 @@ pprCond c = ptext (case c of { NEG -> SLIT("neg"); POS -> SLIT("pos"); VC -> SLIT("vc"); VS -> SLIT("vs") #endif +#if powerpc_TARGET_ARCH + ALWAYS -> SLIT(""); + EQQ -> SLIT("eq"); NE -> SLIT("ne"); + LTT -> SLIT("lt"); GE -> SLIT("ge"); + GTT -> SLIT("gt"); LE -> SLIT("le"); + LU -> SLIT("lt"); GEU -> SLIT("ge"); + GU -> SLIT("gt"); LEU -> SLIT("le"); +#endif }) \end{code} @@ -297,6 +365,22 @@ pprImm (HI i) where pp_hi = text "%hi(" #endif +#if powerpc_TARGET_ARCH +pprImm (LO i) + = hcat [ pp_lo, pprImm i, rparen ] + where + pp_lo = text "lo16(" + +pprImm (HI i) + = hcat [ pp_hi, pprImm i, rparen ] + where + pp_hi = text "hi16(" + +pprImm (HA i) + = hcat [ pp_ha, pprImm i, rparen ] + where + pp_ha = text "ha16(" +#endif \end{code} %************************************************************************ @@ -363,6 +447,8 @@ pprAddr (AddrRegImm r1 (ImmInt i)) pprAddr (AddrRegImm r1 (ImmInteger i)) | i == 0 = pprReg r1 | not (fits13Bits i) = largeOffsetError i +------------------- + | otherwise = hcat [ pprReg r1, pp_sign, integer i ] where pp_sign = if i > 0 then char '+' else empty @@ -370,6 +456,14 @@ pprAddr (AddrRegImm r1 (ImmInteger i)) pprAddr (AddrRegImm r1 imm) = hcat [ pprReg r1, char '+', pprImm imm ] #endif +#if powerpc_TARGET_ARCH +pprAddr (AddrRegReg r1 r2) + = error "PprMach.pprAddr (AddrRegReg) unimplemented" + +pprAddr (AddrRegImm r1 (ImmInt i)) = hcat [ int i, char '(', pprReg r1, char ')' ] +pprAddr (AddrRegImm r1 (ImmInteger i)) = hcat [ integer i, char '(', pprReg r1, char ')' ] +pprAddr (AddrRegImm r1 imm) = hcat [ pprImm imm, char '(', pprReg r1, char ')' ] +#endif \end{code} %************************************************************************ @@ -383,33 +477,37 @@ pprInstr :: Instr -> Doc --pprInstr (COMMENT s) = empty -- nuke 'em pprInstr (COMMENT s) - = IF_ARCH_alpha( ((<>) (ptext SLIT("\t# ")) (ptext s)) - ,IF_ARCH_sparc( ((<>) (ptext SLIT("! ")) (ptext s)) - ,IF_ARCH_i386( ((<>) (ptext SLIT("# ")) (ptext s)) - ,))) + = IF_ARCH_alpha( ((<>) (ptext SLIT("\t# ")) (ftext s)) + ,IF_ARCH_sparc( ((<>) (ptext SLIT("! ")) (ftext s)) + ,IF_ARCH_i386( ((<>) (ptext SLIT("# ")) (ftext s)) + ,IF_ARCH_powerpc( ((<>) (ptext SLIT("; ")) (ftext s)) + ,)))) pprInstr (DELTA d) - = pprInstr (COMMENT (_PK_ ("\tdelta = " ++ show d))) + = pprInstr (COMMENT (mkFastString ("\tdelta = " ++ show d))) pprInstr (SEGMENT TextSegment) = IF_ARCH_alpha(ptext SLIT("\t.text\n\t.align 3") {-word boundary-} ,IF_ARCH_sparc(ptext SLIT(".text\n\t.align 4") {-word boundary-} ,IF_ARCH_i386((text ".text\n\t.align 4,0x90") {-needs per-OS variation!-} - ,))) + ,IF_ARCH_powerpc(ptext SLIT(".text\n.align 2") + ,)))) pprInstr (SEGMENT DataSegment) = ptext IF_ARCH_alpha(SLIT("\t.data\n\t.align 3") ,IF_ARCH_sparc(SLIT(".data\n\t.align 8") {-<8 will break double constants -} ,IF_ARCH_i386(SLIT(".data\n\t.align 4") - ,))) + ,IF_ARCH_powerpc(SLIT(".data\n.align 2") + ,)))) pprInstr (SEGMENT RoDataSegment) = ptext IF_ARCH_alpha(SLIT("\t.data\n\t.align 3") ,IF_ARCH_sparc(SLIT(".data\n\t.align 8") {-<8 will break double constants -} ,IF_ARCH_i386(SLIT(".section .rodata\n\t.align 4") - ,))) + ,IF_ARCH_powerpc(SLIT(".const_data\n.align 2") + ,)))) pprInstr (LABEL clab) = let @@ -423,7 +521,8 @@ pprInstr (LABEL clab) IF_ARCH_alpha(SLIT("\t.globl\t") ,IF_ARCH_i386(SLIT(".globl ") ,IF_ARCH_sparc(SLIT(".global\t") - ,))) + ,IF_ARCH_powerpc(SLIT(".globl ") + ,)))) , pp_lab, char '\n'], pp_lab, char ':' @@ -472,38 +571,19 @@ pprInstr (DATA s xs) = let bs = doubleToBytes (fromRational r) in map (\b -> ptext SLIT("\t.byte\t") <> pprImm (ImmInt b)) bs #endif - - -- floatToBytes and doubleToBytes convert to the host's byte - -- order. Providing that we're not cross-compiling for a - -- target with the opposite endianness, this should work ok - -- on all targets. - floatToBytes :: Float -> [Int] - floatToBytes f - = runST (do - arr <- newFloatArray ((0::Int),3) - writeFloatArray arr 0 f - i0 <- readCharArray arr 0 - i1 <- readCharArray arr 1 - i2 <- readCharArray arr 2 - i3 <- readCharArray arr 3 - return (map ord [i0,i1,i2,i3]) - ) - - doubleToBytes :: Double -> [Int] - doubleToBytes d - = runST (do - arr <- newDoubleArray ((0::Int),7) - writeDoubleArray arr 0 d - i0 <- readCharArray arr 0 - i1 <- readCharArray arr 1 - i2 <- readCharArray arr 2 - i3 <- readCharArray arr 3 - i4 <- readCharArray arr 4 - i5 <- readCharArray arr 5 - i6 <- readCharArray arr 6 - i7 <- readCharArray arr 7 - return (map ord [i0,i1,i2,i3,i4,i5,i6,i7]) - ) +#if powerpc_TARGET_ARCH + ppr_item B x = [ptext SLIT("\t.byte\t") <> pprImm x] + ppr_item Bu x = [ptext SLIT("\t.byte\t") <> pprImm x] + ppr_item H x = [ptext SLIT("\t.byte\t") <> pprImm x] + ppr_item Hu x = [ptext SLIT("\t.byte\t") <> pprImm x] + ppr_item W x = [ptext SLIT("\t.long\t") <> pprImm x] + ppr_item F (ImmFloat r) + = let bs = floatToBytes (fromRational r) + in map (\b -> ptext SLIT("\t.byte\t") <> pprImm (ImmInt b)) bs + ppr_item DF (ImmDouble r) + = let bs = doubleToBytes (fromRational r) + in map (\b -> ptext SLIT("\t.byte\t") <> pprImm (ImmInt b)) bs +#endif -- fall through to rest of (machine-specific) pprInstr... \end{code} @@ -864,8 +944,7 @@ pprRI :: RI -> Doc pprRI (RIReg r) = pprReg r pprRI (RIImm r) = pprImm r -pprRegRIReg :: FAST_STRING -> Reg -> RI -> Reg -> Doc - +pprRegRIReg :: LitString -> Reg -> RI -> Reg -> Doc pprRegRIReg name reg1 ri reg2 = hcat [ char '\t', @@ -878,8 +957,7 @@ pprRegRIReg name reg1 ri reg2 pprReg reg2 ] -pprSizeRegRegReg :: FAST_STRING -> Size -> Reg -> Reg -> Reg -> Doc - +pprSizeRegRegReg :: LitString -> Size -> Reg -> Reg -> Reg -> Doc pprSizeRegRegReg name size reg1 reg2 reg3 = hcat [ char '\t', @@ -967,8 +1045,8 @@ pprInstr (POP size op) = pprSizeOp SLIT("pop") size op pprInstr PUSHA = ptext SLIT("\tpushal") pprInstr POPA = ptext SLIT("\tpopal") -pprInstr (NOP) = ptext SLIT("\tnop") -pprInstr (CLTD) = ptext SLIT("\tcltd") +pprInstr NOP = ptext SLIT("\tnop") +pprInstr CLTD = ptext SLIT("\tcltd") pprInstr (SETCC cond op) = pprCondInstr SLIT("set") cond (pprOperand B op) @@ -976,7 +1054,8 @@ pprInstr (JXX cond lab) = pprCondInstr SLIT("j") cond (pprCLabel_asm lab) pprInstr (JMP dsts (OpImm imm)) = (<>) (ptext SLIT("\tjmp ")) (pprImm imm) pprInstr (JMP dsts op) = (<>) (ptext SLIT("\tjmp *")) (pprOperand L op) -pprInstr (CALL imm) = (<>) (ptext SLIT("\tcall ")) (pprImm imm) +pprInstr (CALL (Left imm)) = (<>) (ptext SLIT("\tcall ")) (pprImm imm) +pprInstr (CALL (Right reg)) = (<>) (ptext SLIT("\tcall *")) (pprReg L reg) -- First bool indicates signedness; second whether quot or rem pprInstr (IQUOT sz src dst) = pprInstr_quotRem True True sz src dst @@ -985,6 +1064,9 @@ pprInstr (IREM sz src dst) = pprInstr_quotRem True False sz src dst pprInstr (QUOT sz src dst) = pprInstr_quotRem False True sz src dst pprInstr (REM sz src dst) = pprInstr_quotRem False False sz src dst +pprInstr (IMUL64 sd_hi sd_lo) = pprInstr_imul64 sd_hi sd_lo + + -- Simulating a flat register set on the x86 FP stack is tricky. -- you have to free %st(7) before pushing anything on the FP reg stack -- so as to preclude the possibility of a FP stack overflow exception. @@ -1023,11 +1105,74 @@ pprInstr g@(GITOD src dst) text " ; ffree %st(7); fildl (%esp) ; ", gpop dst 1, text " ; addl $4,%esp"]) -pprInstr g@(GCMP sz src1 src2) - = pprG g (hcat [gtab, text "pushl %eax ; ",gpush src1 0] - $$ - hcat [gtab, text "fcomp ", greg src2 1, - text "; fstsw %ax ; sahf ; popl %eax"]) +{- Gruesome swamp follows. If you're unfortunate enough to have ventured + this far into the jungle AND you give a Rat's Ass (tm) what's going + on, here's the deal. Generate code to do a floating point comparison + of src1 and src2, of kind cond, and set the Zero flag if true. + + The complications are to do with handling NaNs correctly. We want the + property that if either argument is NaN, then the result of the + comparison is False ... except if we're comparing for inequality, + in which case the answer is True. + + Here's how the general (non-inequality) case works. As an + example, consider generating the an equality test: + + pushl %eax -- we need to mess with this + + fcomp and pop pushed src1 + -- Result of comparison is in FPU Status Register bits + -- C3 C2 and C0 + fstsw %ax -- Move FPU Status Reg to %ax + sahf -- move C3 C2 C0 from %ax to integer flag reg + -- now the serious magic begins + setpo %ah -- %ah = if comparable(neither arg was NaN) then 1 else 0 + sete %al -- %al = if arg1 == arg2 then 1 else 0 + andb %ah,%al -- %al &= %ah + -- so %al == 1 iff (comparable && same); else it holds 0 + decb %al -- %al == 0, ZeroFlag=1 iff (comparable && same); + else %al == 0xFF, ZeroFlag=0 + -- the zero flag is now set as we desire. + popl %eax + + The special case of inequality differs thusly: + + setpe %ah -- %ah = if incomparable(either arg was NaN) then 1 else 0 + setne %al -- %al = if arg1 /= arg2 then 1 else 0 + orb %ah,%al -- %al = if (incomparable || different) then 1 else 0 + decb %al -- if (incomparable || different) then (%al == 0, ZF=1) + else (%al == 0xFF, ZF=0) +-} +pprInstr g@(GCMP cond src1 src2) + | case cond of { NE -> True; other -> False } + = pprG g (vcat [ + hcat [gtab, text "pushl %eax ; ",gpush src1 0], + hcat [gtab, text "fcomp ", greg src2 1, + text "; fstsw %ax ; sahf ; setpe %ah"], + hcat [gtab, text "setne %al ; ", + text "orb %ah,%al ; decb %al ; popl %eax"] + ]) + | otherwise + = pprG g (vcat [ + hcat [gtab, text "pushl %eax ; ",gpush src1 0], + hcat [gtab, text "fcomp ", greg src2 1, + text "; fstsw %ax ; sahf ; setpo %ah"], + hcat [gtab, text "set", pprCond (fix_FP_cond cond), text " %al ; ", + text "andb %ah,%al ; decb %al ; popl %eax"] + ]) + where + {- On the 486, the flags set by FP compare are the unsigned ones! + (This looks like a HACK to me. WDP 96/03) + -} + fix_FP_cond :: Cond -> Cond + fix_FP_cond GE = GEU + fix_FP_cond GTT = GU + fix_FP_cond LTT = LU + fix_FP_cond LE = LEU + fix_FP_cond EQQ = EQQ + fix_FP_cond NE = NE + -- there should be no others + pprInstr g@(GABS sz src dst) = pprG g (hcat [gtab, gpush src 0, text " ; fabs ; ", gpop dst 1]) @@ -1126,12 +1271,14 @@ pprInstr_quotRem signed isQuot sz src dst = vcat [ (text "\t# BEGIN " <> fakeInsn), (text "\tpushl $0; pushl %eax; pushl %edx; pushl " <> pprOperand sz src), - (text "\tmovl " <> pprOperand sz dst <> text ",%eax; xorl %edx,%edx; cltd"), + (text "\tmovl " <> pprOperand sz dst <> text ",%eax; " <> widen_to_64), (x86op <> text " 0(%esp); movl " <> text resReg <> text ",12(%esp)"), (text "\tpopl %edx; popl %edx; popl %eax; popl " <> pprOperand sz dst), (text "\t# END " <> fakeInsn) ] where + widen_to_64 | signed = text "cltd" + | not signed = text "xorl %edx,%edx" x86op = if signed then text "\tidivl" else text "\tdivl" resReg = if isQuot then "%eax" else "%edx" opStr | signed = if isQuot then "IQUOT" else "IREM" @@ -1139,6 +1286,24 @@ pprInstr_quotRem signed isQuot sz src dst fakeInsn = text opStr <+> pprOperand sz src <> char ',' <+> pprOperand sz dst +-- Emit code to make hi_reg:lo_reg be the 64-bit product of hi_reg and lo_reg +pprInstr_imul64 hi_reg lo_reg + = let fakeInsn = text "imul64" <+> pp_hi_reg <> comma <+> pp_lo_reg + pp_hi_reg = pprReg L hi_reg + pp_lo_reg = pprReg L lo_reg + in + vcat [ + text "\t# BEGIN " <> fakeInsn, + text "\tpushl" <+> pp_hi_reg <> text" ; pushl" <+> pp_lo_reg, + text "\tpushl %eax ; pushl %edx", + text "\tmovl 12(%esp), %eax ; imull 8(%esp)", + text "\tmovl %edx, 12(%esp) ; movl %eax, 8(%esp)", + text "\tpopl %edx ; popl %eax", + text "\tpopl" <+> pp_lo_reg <> text " ; popl" <+> pp_hi_reg, + text "\t# END " <> fakeInsn + ] + + -------------------------- -- coerce %st(0) to the specified size @@ -1177,7 +1342,7 @@ pprGInstr (GDTOI src dst) = pprSizeSizeRegReg SLIT("gdtoi") DF L src dst pprGInstr (GITOF src dst) = pprSizeSizeRegReg SLIT("gitof") L F src dst pprGInstr (GITOD src dst) = pprSizeSizeRegReg SLIT("gitod") L DF src dst -pprGInstr (GCMP sz src dst) = pprSizeRegReg SLIT("gcmp") sz src dst +pprGInstr (GCMP co src dst) = pprCondRegReg SLIT("gcmp_") DF co src dst pprGInstr (GABS sz src dst) = pprSizeRegReg SLIT("gabs") sz src dst pprGInstr (GNEG sz src dst) = pprSizeRegReg SLIT("gneg") sz src dst pprGInstr (GSQRT sz src dst) = pprSizeRegReg SLIT("gsqrt") sz src dst @@ -1202,7 +1367,7 @@ pprOperand s (OpReg r) = pprReg s r pprOperand s (OpImm i) = pprDollImm i pprOperand s (OpAddr ea) = pprAddr ea -pprSizeImmOp :: FAST_STRING -> Size -> Imm -> Operand -> Doc +pprSizeImmOp :: LitString -> Size -> Imm -> Operand -> Doc pprSizeImmOp name size imm op1 = hcat [ char '\t', @@ -1215,7 +1380,7 @@ pprSizeImmOp name size imm op1 pprOperand size op1 ] -pprSizeOp :: FAST_STRING -> Size -> Operand -> Doc +pprSizeOp :: LitString -> Size -> Operand -> Doc pprSizeOp name size op1 = hcat [ char '\t', @@ -1225,7 +1390,7 @@ pprSizeOp name size op1 pprOperand size op1 ] -pprSizeOpOp :: FAST_STRING -> Size -> Operand -> Operand -> Doc +pprSizeOpOp :: LitString -> Size -> Operand -> Operand -> Doc pprSizeOpOp name size op1 op2 = hcat [ char '\t', @@ -1237,7 +1402,7 @@ pprSizeOpOp name size op1 op2 pprOperand size op2 ] -pprSizeByteOpOp :: FAST_STRING -> Size -> Operand -> Operand -> Doc +pprSizeByteOpOp :: LitString -> Size -> Operand -> Operand -> Doc pprSizeByteOpOp name size op1 op2 = hcat [ char '\t', @@ -1249,7 +1414,7 @@ pprSizeByteOpOp name size op1 op2 pprOperand size op2 ] -pprSizeOpReg :: FAST_STRING -> Size -> Operand -> Reg -> Doc +pprSizeOpReg :: LitString -> Size -> Operand -> Reg -> Doc pprSizeOpReg name size op1 reg = hcat [ char '\t', @@ -1261,7 +1426,7 @@ pprSizeOpReg name size op1 reg pprReg size reg ] -pprSizeReg :: FAST_STRING -> Size -> Reg -> Doc +pprSizeReg :: LitString -> Size -> Reg -> Doc pprSizeReg name size reg1 = hcat [ char '\t', @@ -1271,7 +1436,7 @@ pprSizeReg name size reg1 pprReg size reg1 ] -pprSizeRegReg :: FAST_STRING -> Size -> Reg -> Reg -> Doc +pprSizeRegReg :: LitString -> Size -> Reg -> Reg -> Doc pprSizeRegReg name size reg1 reg2 = hcat [ char '\t', @@ -1283,7 +1448,19 @@ pprSizeRegReg name size reg1 reg2 pprReg size reg2 ] -pprSizeSizeRegReg :: FAST_STRING -> Size -> Size -> Reg -> Reg -> Doc +pprCondRegReg :: LitString -> Size -> Cond -> Reg -> Reg -> Doc +pprCondRegReg name size cond reg1 reg2 + = hcat [ + char '\t', + ptext name, + pprCond cond, + space, + pprReg size reg1, + comma, + pprReg size reg2 + ] + +pprSizeSizeRegReg :: LitString -> Size -> Size -> Reg -> Reg -> Doc pprSizeSizeRegReg name size1 size2 reg1 reg2 = hcat [ char '\t', @@ -1292,11 +1469,12 @@ pprSizeSizeRegReg name size1 size2 reg1 reg2 pprSize size2, space, pprReg size1 reg1, + comma, pprReg size2 reg2 ] -pprSizeRegRegReg :: FAST_STRING -> Size -> Reg -> Reg -> Reg -> Doc +pprSizeRegRegReg :: LitString -> Size -> Reg -> Reg -> Reg -> Doc pprSizeRegRegReg name size reg1 reg2 reg3 = hcat [ char '\t', @@ -1310,7 +1488,7 @@ pprSizeRegRegReg name size reg1 reg2 reg3 pprReg size reg3 ] -pprSizeAddr :: FAST_STRING -> Size -> MachRegsAddr -> Doc +pprSizeAddr :: LitString -> Size -> MachRegsAddr -> Doc pprSizeAddr name size op = hcat [ char '\t', @@ -1320,7 +1498,7 @@ pprSizeAddr name size op pprAddr op ] -pprSizeAddrReg :: FAST_STRING -> Size -> MachRegsAddr -> Reg -> Doc +pprSizeAddrReg :: LitString -> Size -> MachRegsAddr -> Reg -> Doc pprSizeAddrReg name size op dst = hcat [ char '\t', @@ -1332,7 +1510,7 @@ pprSizeAddrReg name size op dst pprReg size dst ] -pprSizeRegAddr :: FAST_STRING -> Size -> Reg -> MachRegsAddr -> Doc +pprSizeRegAddr :: LitString -> Size -> Reg -> MachRegsAddr -> Doc pprSizeRegAddr name size src op = hcat [ char '\t', @@ -1344,7 +1522,7 @@ pprSizeRegAddr name size src op pprAddr op ] -pprOpOp :: FAST_STRING -> Size -> Operand -> Operand -> Doc +pprOpOp :: LitString -> Size -> Operand -> Operand -> Doc pprOpOp name size op1 op2 = hcat [ char '\t', @@ -1354,7 +1532,7 @@ pprOpOp name size op1 op2 pprOperand size op2 ] -pprSizeOpOpCoerce :: FAST_STRING -> Size -> Size -> Operand -> Operand -> Doc +pprSizeOpOpCoerce :: LitString -> Size -> Size -> Operand -> Operand -> Doc pprSizeOpOpCoerce name size1 size2 op1 op2 = hcat [ char '\t', ptext name, pprSize size1, pprSize size2, space, pprOperand size1 op1, @@ -1362,7 +1540,7 @@ pprSizeOpOpCoerce name size1 size2 op1 op2 pprOperand size2 op2 ] -pprCondInstr :: FAST_STRING -> Cond -> Doc -> Doc +pprCondInstr :: LitString -> Cond -> Doc -> Doc pprCondInstr name cond arg = hcat [ char '\t', ptext name, pprCond cond, space, arg] @@ -1486,7 +1664,10 @@ pprInstr (ANDN b reg1 ri reg2) = pprRegRIReg SLIT("andn") b reg1 ri reg2 pprInstr (OR b reg1 ri reg2) | not b && reg1 == g0 - = hcat [ ptext SLIT("\tmov\t"), pprRI ri, comma, pprReg reg2 ] + = let doit = hcat [ ptext SLIT("\tmov\t"), pprRI ri, comma, pprReg reg2 ] + in case ri of + RIReg rrr | rrr == reg2 -> empty + other -> doit | otherwise = pprRegRIReg SLIT("or") b reg1 ri reg2 @@ -1499,6 +1680,10 @@ pprInstr (SLL reg1 ri reg2) = pprRegRIReg SLIT("sll") False reg1 ri reg2 pprInstr (SRL reg1 ri reg2) = pprRegRIReg SLIT("srl") False reg1 ri reg2 pprInstr (SRA reg1 ri reg2) = pprRegRIReg SLIT("sra") False reg1 ri reg2 +pprInstr (RDY rd) = ptext SLIT("\trd\t%y,") <> pprReg rd +pprInstr (SMUL b reg1 ri reg2) = pprRegRIReg SLIT("smul") b reg1 ri reg2 +pprInstr (UMUL b reg1 ri reg2) = pprRegRIReg SLIT("umul") b reg1 ri reg2 + pprInstr (SETHI imm reg) = hcat [ ptext SLIT("\tsethi\t"), @@ -1577,8 +1762,10 @@ pprInstr (BF cond b lab) pprInstr (JMP dsts addr) = (<>) (ptext SLIT("\tjmp\t")) (pprAddr addr) -pprInstr (CALL imm n _) +pprInstr (CALL (Left imm) n _) = hcat [ ptext SLIT("\tcall\t"), pprImm imm, comma, int n ] +pprInstr (CALL (Right reg) n _) + = hcat [ ptext SLIT("\tcall\t"), pprReg reg, comma, int n ] \end{code} Continue with SPARC-only printing bits and bobs: @@ -1587,7 +1774,7 @@ pprRI :: RI -> Doc pprRI (RIReg r) = pprReg r pprRI (RIImm r) = pprImm r -pprSizeRegReg :: FAST_STRING -> Size -> Reg -> Reg -> Doc +pprSizeRegReg :: LitString -> Size -> Reg -> Reg -> Doc pprSizeRegReg name size reg1 reg2 = hcat [ char '\t', @@ -1600,7 +1787,7 @@ pprSizeRegReg name size reg1 reg2 pprReg reg2 ] -pprSizeRegRegReg :: FAST_STRING -> Size -> Reg -> Reg -> Reg -> Doc +pprSizeRegRegReg :: LitString -> Size -> Reg -> Reg -> Reg -> Doc pprSizeRegRegReg name size reg1 reg2 reg3 = hcat [ char '\t', @@ -1615,7 +1802,7 @@ pprSizeRegRegReg name size reg1 reg2 reg3 pprReg reg3 ] -pprRegRIReg :: FAST_STRING -> Bool -> Reg -> RI -> Reg -> Doc +pprRegRIReg :: LitString -> Bool -> Reg -> RI -> Reg -> Doc pprRegRIReg name b reg1 ri reg2 = hcat [ char '\t', @@ -1628,7 +1815,7 @@ pprRegRIReg name b reg1 ri reg2 pprReg reg2 ] -pprRIReg :: FAST_STRING -> Bool -> RI -> Reg -> Doc +pprRIReg :: LitString -> Bool -> RI -> Reg -> Doc pprRIReg name b ri reg1 = hcat [ char '\t', @@ -1646,3 +1833,285 @@ pp_comma_a = text ",a" #endif {-sparc_TARGET_ARCH-} \end{code} + +%************************************************************************ +%* * +\subsubsection{@pprInstr@ for PowerPC} +%* * +%************************************************************************ + +\begin{code} +#if powerpc_TARGET_ARCH +pprInstr (LD sz reg addr) = hcat [ + char '\t', + ptext SLIT("l"), + ptext (case sz of + B -> SLIT("ba") + Bu -> SLIT("bz") + H -> SLIT("ha") + Hu -> SLIT("hz") + W -> SLIT("wz") + F -> SLIT("fs") + DF -> SLIT("fd")), + char '\t', + pprReg reg, + ptext SLIT(", "), + pprAddr addr + ] +pprInstr (ST sz reg addr) = hcat [ + char '\t', + ptext SLIT("st"), + pprSize sz, + char '\t', + pprReg reg, + ptext SLIT(", "), + pprAddr addr + ] +pprInstr (STU sz reg addr) = hcat [ + char '\t', + ptext SLIT("st"), + pprSize sz, + ptext SLIT("u\t"), + pprReg reg, + ptext SLIT(", "), + pprAddr addr + ] +pprInstr (LIS reg imm) = hcat [ + char '\t', + ptext SLIT("lis"), + char '\t', + pprReg reg, + ptext SLIT(", "), + pprImm imm + ] +pprInstr (LI reg imm) = hcat [ + char '\t', + ptext SLIT("li"), + char '\t', + pprReg reg, + ptext SLIT(", "), + pprImm imm + ] +pprInstr (MR reg1 reg2) = hcat [ + char '\t', + case regClass reg1 of + RcInteger -> ptext SLIT("mr") + _ -> ptext SLIT("fmr"), + char '\t', + pprReg reg1, + ptext SLIT(", "), + pprReg reg2 + ] +pprInstr (CMP sz reg ri) = hcat [ + char '\t', + op, + char '\t', + pprReg reg, + ptext SLIT(", "), + pprRI ri + ] + where + op = hcat [ + ptext SLIT("cmp"), + pprSize sz, + case ri of + RIReg _ -> empty + RIImm _ -> char 'i' + ] +pprInstr (CMPL sz reg ri) = hcat [ + char '\t', + op, + char '\t', + pprReg reg, + ptext SLIT(", "), + pprRI ri + ] + where + op = hcat [ + ptext SLIT("cmpl"), + pprSize sz, + case ri of + RIReg _ -> empty + RIImm _ -> char 'i' + ] +pprInstr (BCC cond lbl) = hcat [ + char '\t', + ptext SLIT("b"), + pprCond cond, + char '\t', + pprCLabel_asm lbl + ] + +pprInstr (MTCTR reg) = hcat [ + char '\t', + ptext SLIT("mtctr"), + char '\t', + pprReg reg + ] +pprInstr (BCTR) = hcat [ + char '\t', + ptext SLIT("bctr") + ] +pprInstr (BL imm _) = hcat [ + char '\t', + ptext SLIT("bl"), + char '\t', + pprImm imm + ] +pprInstr (BCTRL _) = hcat [ + char '\t', + ptext SLIT("bctrl") + ] +pprInstr (ADD reg1 reg2 ri) = pprLogic SLIT("add") reg1 reg2 ri +pprInstr (SUBF reg1 reg2 ri) = pprLogic SLIT("subf") reg1 reg2 ri +pprInstr (MULLW reg1 reg2 ri@(RIReg _)) = pprLogic SLIT("mullw") reg1 reg2 ri +pprInstr (MULLW reg1 reg2 ri@(RIImm _)) = pprLogic SLIT("mull") reg1 reg2 ri +pprInstr (DIVW reg1 reg2 reg3) = pprLogic SLIT("divw") reg1 reg2 (RIReg reg3) +pprInstr (DIVWU reg1 reg2 reg3) = pprLogic SLIT("divwu") reg1 reg2 (RIReg reg3) +pprInstr (AND reg1 reg2 ri) = pprLogic SLIT("and") reg1 reg2 ri +pprInstr (OR reg1 reg2 ri) = pprLogic SLIT("or") reg1 reg2 ri +pprInstr (XOR reg1 reg2 ri) = pprLogic SLIT("xor") reg1 reg2 ri +pprInstr (SLW reg1 reg2 ri) = pprLogic SLIT("slw") reg1 reg2 ri +pprInstr (SRW reg1 reg2 ri) = pprLogic SLIT("srw") reg1 reg2 ri +pprInstr (SRAW reg1 reg2 ri) = pprLogic SLIT("sraw") reg1 reg2 ri +pprInstr (NEG reg1 reg2) = pprUnary SLIT("neg") reg1 reg2 +pprInstr (NOT reg1 reg2) = pprUnary SLIT("not") reg1 reg2 + +pprInstr (FADD sz reg1 reg2 reg3) = pprBinaryF SLIT("fadd") sz reg1 reg2 reg3 +pprInstr (FSUB sz reg1 reg2 reg3) = pprBinaryF SLIT("fsub") sz reg1 reg2 reg3 +pprInstr (FMUL sz reg1 reg2 reg3) = pprBinaryF SLIT("fmul") sz reg1 reg2 reg3 +pprInstr (FDIV sz reg1 reg2 reg3) = pprBinaryF SLIT("fdiv") sz reg1 reg2 reg3 + +pprInstr (FCMP reg1 reg2) = hcat [ + char '\t', + ptext SLIT("fcmpu\tcr0, "), + -- Note: we're using fcmpu, not fcmpo + -- The difference is with fcmpo, compare with NaN is an invalid operation. + -- We don't handle invalid fp ops, so we don't care + pprReg reg1, + ptext SLIT(", "), + pprReg reg2 + ] + +pprInstr _ = ptext SLIT("something") + +pprLogic op reg1 reg2 ri = hcat [ + char '\t', + ptext op, + case ri of + RIReg _ -> empty + RIImm _ -> char 'i', + char '\t', + pprReg reg1, + ptext SLIT(", "), + pprReg reg2, + ptext SLIT(", "), + pprRI ri + ] + +pprUnary op reg1 reg2 = hcat [ + char '\t', + ptext op, + char '\t', + pprReg reg1, + ptext SLIT(", "), + pprReg reg2 + ] + +pprBinaryF op sz reg1 reg2 reg3 = hcat [ + char '\t', + ptext op, + pprFSize sz, + char '\t', + pprReg reg1, + ptext SLIT(", "), + pprReg reg2, + ptext SLIT(", "), + pprReg reg3 + ] + +pprRI :: RI -> Doc +pprRI (RIReg r) = pprReg r +pprRI (RIImm r) = pprImm r + +pprFSize DF = empty +pprFSize F = char 's' + +#endif {-powerpc_TARGET_ARCH-} +\end{code} + +\begin{code} +#if __GLASGOW_HASKELL__ >= 504 +newFloatArray :: (Int,Int) -> ST s (STUArray s Int Float) +newFloatArray = newArray_ + +newDoubleArray :: (Int,Int) -> ST s (STUArray s Int Double) +newDoubleArray = newArray_ + +castFloatToCharArray :: STUArray s Int Float -> ST s (STUArray s Int Word8) +castFloatToCharArray = castSTUArray + +castDoubleToCharArray :: STUArray s Int Double -> ST s (STUArray s Int Word8) +castDoubleToCharArray = castSTUArray + +writeFloatArray :: STUArray s Int Float -> Int -> Float -> ST s () +writeFloatArray = writeArray + +writeDoubleArray :: STUArray s Int Double -> Int -> Double -> ST s () +writeDoubleArray = writeArray + +readCharArray :: STUArray s Int Word8 -> Int -> ST s Char +readCharArray arr i = do + w <- readArray arr i + return $! (chr (fromIntegral w)) + +#else + +castFloatToCharArray :: MutableByteArray s t -> ST s (MutableByteArray s t) +castFloatToCharArray = return + +castDoubleToCharArray :: MutableByteArray s t -> ST s (MutableByteArray s t) + + +castDoubleToCharArray = return + +#endif + +-- floatToBytes and doubleToBytes convert to the host's byte +-- order. Providing that we're not cross-compiling for a +-- target with the opposite endianness, this should work ok +-- on all targets. + +-- ToDo: this stuff is very similar to the shenanigans in PprAbs, +-- could they be merged? + +floatToBytes :: Float -> [Int] +floatToBytes f + = runST (do + arr <- newFloatArray ((0::Int),3) + writeFloatArray arr 0 f + arr <- castFloatToCharArray arr + i0 <- readCharArray arr 0 + i1 <- readCharArray arr 1 + i2 <- readCharArray arr 2 + i3 <- readCharArray arr 3 + return (map ord [i0,i1,i2,i3]) + ) + +doubleToBytes :: Double -> [Int] +doubleToBytes d + = runST (do + arr <- newDoubleArray ((0::Int),7) + writeDoubleArray arr 0 d + arr <- castDoubleToCharArray arr + i0 <- readCharArray arr 0 + i1 <- readCharArray arr 1 + i2 <- readCharArray arr 2 + i3 <- readCharArray arr 3 + i4 <- readCharArray arr 4 + i5 <- readCharArray arr 5 + i6 <- readCharArray arr 6 + i7 <- readCharArray arr 7 + return (map ord [i0,i1,i2,i3,i4,i5,i6,i7]) + ) +\end{code}