X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FnativeGen%2FPprMach.hs;h=2d59cf417f472c9590749a2883e319a5dc085b35;hp=38267d077b4d63fc41c1c84e216bf8eab9519233;hb=e6243a818496aad82b6f47511d3bd9bc800f747d;hpb=e6748917380ae7826114c0801f1a61a4c7861bbc diff --git a/compiler/nativeGen/PprMach.hs b/compiler/nativeGen/PprMach.hs index 38267d0..2d59cf4 100644 --- a/compiler/nativeGen/PprMach.hs +++ b/compiler/nativeGen/PprMach.hs @@ -26,8 +26,8 @@ module PprMach ( #include "HsVersions.h" +import BlockId import Cmm -import MachOp ( MachRep(..), wordRep, isFloatingRep ) import MachRegs -- may differ per-platform import MachInstrs @@ -82,7 +82,7 @@ pprNatCmmTop (CmmProc info lbl params (ListGraph blocks)) = pprLabel (entryLblToInfoLbl lbl) ) $$ vcat (map pprBasicBlock blocks) - -- ^ Even the first block gets a label, because with branch-chain + -- above: Even the first block gets a label, because with branch-chain -- elimination, it might be the target of a goto. #if HAVE_SUBSECTIONS_VIA_SYMBOLS -- If we are using the .subsections_via_symbols directive @@ -112,9 +112,9 @@ pprBasicBlock (BasicBlock (BlockId id) instrs) = -- on which bit of it we care about. Yurgh. pprUserReg :: Reg -> Doc -pprUserReg = pprReg IF_ARCH_i386(I32,) IF_ARCH_x86_64(I64,) +pprUserReg = pprReg IF_ARCH_i386(II32,) IF_ARCH_x86_64(II64,) -pprReg :: IF_ARCH_i386(MachRep ->,) IF_ARCH_x86_64(MachRep ->,) Reg -> Doc +pprReg :: IF_ARCH_i386(Size ->,) IF_ARCH_x86_64(Size ->,) Reg -> Doc pprReg IF_ARCH_i386(s,) IF_ARCH_x86_64(s,) r = case r of @@ -164,9 +164,9 @@ pprReg IF_ARCH_i386(s,) IF_ARCH_x86_64(s,) r }) #endif #if i386_TARGET_ARCH - ppr_reg_no :: MachRep -> Int -> Doc - ppr_reg_no I8 = ppr_reg_byte - ppr_reg_no I16 = ppr_reg_word + ppr_reg_no :: Size -> Int -> Doc + ppr_reg_no II8 = ppr_reg_byte + ppr_reg_no II16 = ppr_reg_word ppr_reg_no _ = ppr_reg_long ppr_reg_byte i = ptext @@ -199,10 +199,10 @@ pprReg IF_ARCH_i386(s,) IF_ARCH_x86_64(s,) r #endif #if x86_64_TARGET_ARCH - ppr_reg_no :: MachRep -> Int -> Doc - ppr_reg_no I8 = ppr_reg_byte - ppr_reg_no I16 = ppr_reg_word - ppr_reg_no I32 = ppr_reg_long + ppr_reg_no :: Size -> Int -> Doc + ppr_reg_no II8 = ppr_reg_byte + ppr_reg_no II16 = ppr_reg_word + ppr_reg_no II32 = ppr_reg_long ppr_reg_no _ = ppr_reg_quad ppr_reg_byte i = ptext @@ -348,7 +348,7 @@ pprReg IF_ARCH_i386(s,) IF_ARCH_x86_64(s,) r ppr_reg_no :: Int -> Doc ppr_reg_no i | i <= 31 = int i -- GPRs | i <= 63 = int (i-32) -- FPRs - | otherwise = ptext sLit "very naughty powerpc register" + | otherwise = ptext (sLit "very naughty powerpc register") #endif #endif @@ -357,7 +357,7 @@ pprReg IF_ARCH_i386(s,) IF_ARCH_x86_64(s,) r -- pprSize: print a 'Size' #if powerpc_TARGET_ARCH || i386_TARGET_ARCH || x86_64_TARGET_ARCH || sparc_TARGET_ARCH -pprSize :: MachRep -> Doc +pprSize :: Size -> Doc #else pprSize :: Size -> Doc #endif @@ -377,41 +377,41 @@ pprSize x = ptext (case x of TF -> sLit "t" #endif #if i386_TARGET_ARCH || x86_64_TARGET_ARCH - I8 -> sLit "b" - I16 -> sLit "w" - I32 -> sLit "l" - I64 -> sLit "q" + II8 -> sLit "b" + II16 -> sLit "w" + II32 -> sLit "l" + II64 -> sLit "q" #endif #if i386_TARGET_ARCH - F32 -> sLit "s" - F64 -> sLit "l" - F80 -> sLit "t" + FF32 -> sLit "s" + FF64 -> sLit "l" + FF80 -> sLit "t" #endif #if x86_64_TARGET_ARCH - F32 -> sLit "ss" -- "scalar single-precision float" (SSE2) - F64 -> sLit "sd" -- "scalar double-precision float" (SSE2) + FF32 -> sLit "ss" -- "scalar single-precision float" (SSE2) + FF64 -> sLit "sd" -- "scalar double-precision float" (SSE2) #endif #if sparc_TARGET_ARCH - I8 -> sLit "sb" - I16 -> sLit "sh" - I32 -> sLit "" - F32 -> sLit "" - F64 -> sLit "d" + II8 -> sLit "sb" + II16 -> sLit "sh" + II32 -> sLit "" + FF32 -> sLit "" + FF64 -> sLit "d" ) -pprStSize :: MachRep -> Doc +pprStSize :: Size -> Doc pprStSize x = ptext (case x of - I8 -> sLit "b" - I16 -> sLit "h" - I32 -> sLit "" - F32 -> sLit "" - F64 -> sLit "d" + II8 -> sLit "b" + II16 -> sLit "h" + II32 -> sLit "" + FF32 -> sLit "" + FF64 -> sLit "d" #endif #if powerpc_TARGET_ARCH - I8 -> sLit "b" - I16 -> sLit "h" - I32 -> sLit "w" - F32 -> sLit "fs" - F64 -> sLit "fd" + II8 -> sLit "b" + II16 -> sLit "h" + II32 -> sLit "w" + FF32 -> sLit "fs" + FF64 -> sLit "fd" #endif ) @@ -474,7 +474,7 @@ pprImm (ImmCLbl l) = pprCLabel_asm l pprImm (ImmIndex l i) = pprCLabel_asm l <> char '+' <> int i pprImm (ImmLit s) = s -pprImm (ImmFloat _) = ptext (sLit "naughty float immediate") +pprImm (ImmFloat _) = ptext (sLit "naughty float immediate") pprImm (ImmDouble _) = ptext (sLit "naughty double immediate") pprImm (ImmConstantSum a b) = pprImm a <> char '+' <> pprImm b @@ -557,7 +557,7 @@ pprAddr (AddrBaseIndex base index displacement) = let pp_disp = ppr_disp displacement pp_off p = pp_disp <> char '(' <> p <> char ')' - pp_reg r = pprReg wordRep r + pp_reg r = pprReg wordSize r in case (base,index) of (EABaseNone, EAIndexNone) -> pp_disp @@ -734,30 +734,30 @@ pprAlign bytes = pprDataItem :: CmmLit -> Doc pprDataItem lit - = vcat (ppr_item (cmmLitRep lit) lit) + = vcat (ppr_item (cmmTypeSize $ cmmLitType lit) lit) where imm = litToImm lit -- These seem to be common: - ppr_item I8 x = [ptext (sLit "\t.byte\t") <> pprImm imm] - ppr_item I32 x = [ptext (sLit "\t.long\t") <> pprImm imm] - ppr_item F32 (CmmFloat r _) + ppr_item II8 x = [ptext (sLit "\t.byte\t") <> pprImm imm] + ppr_item II32 x = [ptext (sLit "\t.long\t") <> pprImm imm] + ppr_item FF32 (CmmFloat r _) = let bs = floatToBytes (fromRational r) in map (\b -> ptext (sLit "\t.byte\t") <> pprImm (ImmInt b)) bs - ppr_item F64 (CmmFloat r _) + ppr_item FF64 (CmmFloat r _) = let bs = doubleToBytes (fromRational r) in map (\b -> ptext (sLit "\t.byte\t") <> pprImm (ImmInt b)) bs #if sparc_TARGET_ARCH -- copy n paste of x86 version - ppr_item I16 x = [ptext (sLit "\t.short\t") <> pprImm imm] - ppr_item I64 x = [ptext (sLit "\t.quad\t") <> pprImm imm] + ppr_item II16 x = [ptext (sLit "\t.short\t") <> pprImm imm] + ppr_item II64 x = [ptext (sLit "\t.quad\t") <> pprImm imm] #endif #if i386_TARGET_ARCH || x86_64_TARGET_ARCH - ppr_item I16 x = [ptext (sLit "\t.word\t") <> pprImm imm] + ppr_item II16 x = [ptext (sLit "\t.word\t") <> pprImm imm] #endif #if i386_TARGET_ARCH && darwin_TARGET_OS - ppr_item I64 (CmmInt x _) = + ppr_item II64 (CmmInt x _) = [ptext (sLit "\t.long\t") <> int (fromIntegral (fromIntegral x :: Word32)), ptext (sLit "\t.long\t") @@ -765,7 +765,7 @@ pprDataItem lit (fromIntegral (x `shiftR` 32) :: Word32))] #endif #if i386_TARGET_ARCH || (darwin_TARGET_OS && x86_64_TARGET_ARCH) - ppr_item I64 x = [ptext (sLit "\t.quad\t") <> pprImm imm] + ppr_item II64 x = [ptext (sLit "\t.quad\t") <> pprImm imm] #endif #if x86_64_TARGET_ARCH && !darwin_TARGET_OS -- x86_64: binutils can't handle the R_X86_64_PC64 relocation @@ -776,7 +776,7 @@ pprDataItem lit -- -- See Note [x86-64-relative] in includes/InfoTables.h -- - ppr_item I64 x + ppr_item II64 x | isRelativeReloc x = [ptext (sLit "\t.long\t") <> pprImm imm, ptext (sLit "\t.long\t0")] @@ -787,8 +787,8 @@ pprDataItem lit isRelativeReloc _ = False #endif #if powerpc_TARGET_ARCH - ppr_item I16 x = [ptext (sLit "\t.short\t") <> pprImm imm] - ppr_item I64 (CmmInt x _) = + ppr_item II16 x = [ptext (sLit "\t.short\t") <> pprImm imm] + ppr_item II64 (CmmInt x _) = [ptext (sLit "\t.long\t") <> int (fromIntegral (fromIntegral (x `shiftR` 32) :: Word32)), @@ -1248,18 +1248,18 @@ pprInstr (RELOAD slot reg) pprInstr (MOV size src dst) = pprSizeOpOp (sLit "mov") size src dst -pprInstr (MOVZxL I32 src dst) = pprSizeOpOp (sLit "mov") I32 src dst +pprInstr (MOVZxL II32 src dst) = pprSizeOpOp (sLit "mov") II32 src dst -- 32-to-64 bit zero extension on x86_64 is accomplished by a simple -- movl. But we represent it as a MOVZxL instruction, because -- the reg alloc would tend to throw away a plain reg-to-reg -- move, and we still want it to do that. -pprInstr (MOVZxL sizes src dst) = pprSizeOpOpCoerce (sLit "movz") sizes I32 src dst +pprInstr (MOVZxL sizes src dst) = pprSizeOpOpCoerce (sLit "movz") sizes II32 src dst -- zero-extension only needs to extend to 32 bits: on x86_64, -- the remaining zero-extension to 64 bits is automatic, and the 32-bit -- instruction is shorter. -pprInstr (MOVSxL sizes src dst) = pprSizeOpOpCoerce (sLit "movs") sizes wordRep src dst +pprInstr (MOVSxL sizes src dst) = pprSizeOpOpCoerce (sLit "movs") sizes wordSize src dst -- here we do some patching, since the physical registers are only set late -- in the code generation. @@ -1295,8 +1295,8 @@ pprInstr (IMUL size op1 op2) = pprSizeOpOp (sLit "imul") size op1 op2 pprInstr (AND size src dst) = pprSizeOpOp (sLit "and") size src dst pprInstr (OR size src dst) = pprSizeOpOp (sLit "or") size src dst -pprInstr (XOR F32 src dst) = pprOpOp (sLit "xorps") F32 src dst -pprInstr (XOR F64 src dst) = pprOpOp (sLit "xorpd") F64 src dst +pprInstr (XOR FF32 src dst) = pprOpOp (sLit "xorps") FF32 src dst +pprInstr (XOR FF64 src dst) = pprOpOp (sLit "xorpd") FF64 src dst pprInstr (XOR size src dst) = pprSizeOpOp (sLit "xor") size src dst pprInstr (NOT size op) = pprSizeOp (sLit "not") size op @@ -1309,8 +1309,14 @@ pprInstr (SHR size src dst) = pprShift (sLit "shr") size src dst pprInstr (BT size imm src) = pprSizeImmOp (sLit "bt") size imm src pprInstr (CMP size src dst) - | isFloatingRep size = pprSizeOpOp (sLit "ucomi") size src dst -- SSE2 - | otherwise = pprSizeOpOp (sLit "cmp") size src dst + | is_float size = pprSizeOpOp (sLit "ucomi") size src dst -- SSE2 + | otherwise = pprSizeOpOp (sLit "cmp") size src dst + where + -- This predicate is needed here and nowhere else + is_float FF32 = True + is_float FF64 = True + is_float FF80 = True + is_float other = False pprInstr (TEST size src dst) = pprSizeOpOp (sLit "test") size src dst pprInstr (PUSH size op) = pprSizeOp (sLit "push") size op @@ -1321,10 +1327,10 @@ pprInstr (POP size op) = pprSizeOp (sLit "pop") size op -- pprInstr POPA = ptext (sLit "\tpopal") pprInstr NOP = ptext (sLit "\tnop") -pprInstr (CLTD I32) = ptext (sLit "\tcltd") -pprInstr (CLTD I64) = ptext (sLit "\tcqto") +pprInstr (CLTD II32) = ptext (sLit "\tcltd") +pprInstr (CLTD II64) = ptext (sLit "\tcqto") -pprInstr (SETCC cond op) = pprCondInstr (sLit "set") cond (pprOperand I8 op) +pprInstr (SETCC cond op) = pprCondInstr (sLit "set") cond (pprOperand II8 op) pprInstr (JXX cond (BlockId id)) = pprCondInstr (sLit "j") cond (pprCLabel_asm lab) @@ -1333,10 +1339,10 @@ pprInstr (JXX cond (BlockId id)) pprInstr (JXX_GBL cond imm) = pprCondInstr (sLit "j") cond (pprImm imm) pprInstr (JMP (OpImm imm)) = (<>) (ptext (sLit "\tjmp ")) (pprImm imm) -pprInstr (JMP op) = (<>) (ptext (sLit "\tjmp *")) (pprOperand wordRep op) +pprInstr (JMP op) = (<>) (ptext (sLit "\tjmp *")) (pprOperand wordSize op) pprInstr (JMP_TBL op ids) = pprInstr (JMP op) pprInstr (CALL (Left imm) _) = (<>) (ptext (sLit "\tcall ")) (pprImm imm) -pprInstr (CALL (Right reg) _) = (<>) (ptext (sLit "\tcall *")) (pprReg wordRep reg) +pprInstr (CALL (Right reg) _) = (<>) (ptext (sLit "\tcall *")) (pprReg wordSize reg) pprInstr (IDIV sz op) = pprSizeOp (sLit "idiv") sz op pprInstr (DIV sz op) = pprSizeOp (sLit "div") sz op @@ -1358,9 +1364,9 @@ pprInstr (CVTSI2SD from to) = pprOpReg (sLit "cvtsi2sdq") from to -- FETCHGOT for PIC on ELF platforms pprInstr (FETCHGOT reg) = vcat [ ptext (sLit "\tcall 1f"), - hcat [ ptext (sLit "1:\tpopl\t"), pprReg I32 reg ], + hcat [ ptext (sLit "1:\tpopl\t"), pprReg II32 reg ], hcat [ ptext (sLit "\taddl\t$_GLOBAL_OFFSET_TABLE_+(.-1b), "), - pprReg I32 reg ] + pprReg II32 reg ] ] -- FETCHPC for PIC on Darwin/x86 @@ -1369,7 +1375,7 @@ pprInstr (FETCHGOT reg) -- and it's a good thing to use the same name on both platforms) pprInstr (FETCHPC reg) = vcat [ ptext (sLit "\tcall 1f"), - hcat [ ptext (sLit "1:\tpopl\t"), pprReg I32 reg ] + hcat [ ptext (sLit "1:\tpopl\t"), pprReg II32 reg ] ] @@ -1418,12 +1424,12 @@ pprInstr g@(GDTOI src dst) hcat [gtab, text "addl $8, %esp"] ]) where - reg = pprReg I32 dst + reg = pprReg II32 dst pprInstr g@(GITOF src dst) = pprInstr (GITOD src dst) pprInstr g@(GITOD src dst) - = pprG g (hcat [gtab, text "pushl ", pprReg I32 src, + = pprG g (hcat [gtab, text "pushl ", pprReg II32 src, text " ; ffree %st(7); fildl (%esp) ; ", gpop dst 1, text " ; addl $4,%esp"]) @@ -1504,17 +1510,12 @@ pprInstr g@(GNEG sz src dst) pprInstr g@(GSQRT sz src dst) = pprG g (hcat [gtab, gpush src 0, text " ; fsqrt"] $$ hcat [gtab, gcoerceto sz, gpop dst 1]) -pprInstr g@(GSIN sz src dst) - = pprG g (hcat [gtab, gpush src 0, text " ; fsin"] $$ - hcat [gtab, gcoerceto sz, gpop dst 1]) -pprInstr g@(GCOS sz src dst) - = pprG g (hcat [gtab, gpush src 0, text " ; fcos"] $$ - hcat [gtab, gcoerceto sz, gpop dst 1]) -pprInstr g@(GTAN sz src dst) - = pprG g (hcat [gtab, text "ffree %st(6) ; ", - gpush src 0, text " ; fptan ; ", - text " fstp %st(0)"] $$ - hcat [gtab, gcoerceto sz, gpop dst 1]) +pprInstr g@(GSIN sz l1 l2 src dst) + = pprG g (pprTrigOp "fsin" False l1 l2 src dst sz) +pprInstr g@(GCOS sz l1 l2 src dst) + = pprG g (pprTrigOp "fcos" False l1 l2 src dst sz) +pprInstr g@(GTAN sz l1 l2 src dst) + = pprG g (pprTrigOp "fptan" True l1 l2 src dst sz) -- In the translations for GADD, GMUL, GSUB and GDIV, -- the first two cases are mere optimisations. The otherwise clause @@ -1585,11 +1586,53 @@ pprInstr GFREE ptext (sLit "\tffree %st(4) ;ffree %st(5) ;ffree %st(6) ;ffree %st(7)") ] +pprTrigOp :: String -> Bool -> CLabel -> CLabel -> Reg -> Reg -> Size -> Doc +pprTrigOp op -- fsin, fcos or fptan + isTan -- we need a couple of extra steps if we're doing tan + l1 l2 -- internal labels for us to use + src dst sz + = -- We'll be needing %eax later on + hcat [gtab, text "pushl %eax;"] $$ + -- tan is going to use an extra space on the FP stack + (if isTan then hcat [gtab, text "ffree %st(6)"] else empty) $$ + -- First put the value in %st(0) and try to apply the op to it + hcat [gpush src 0, text ("; " ++ op)] $$ + -- Now look to see if C2 was set (overflow, |value| >= 2^63) + hcat [gtab, text "fnstsw %ax"] $$ + hcat [gtab, text "test $0x400,%eax"] $$ + -- If we were in bounds then jump to the end + hcat [gtab, text "je " <> pprCLabel_asm l1] $$ + -- Otherwise we need to shrink the value. Start by + -- loading pi, doubleing it (by adding it to itself), + -- and then swapping pi with the value, so the value we + -- want to apply op to is in %st(0) again + hcat [gtab, text "ffree %st(7); fldpi"] $$ + hcat [gtab, text "fadd %st(0),%st"] $$ + hcat [gtab, text "fxch %st(1)"] $$ + -- Now we have a loop in which we make the value smaller, + -- see if it's small enough, and loop if not + (pprCLabel_asm l2 <> char ':') $$ + hcat [gtab, text "fprem1"] $$ + -- My Debian libc uses fstsw here for the tan code, but I can't + -- see any reason why it should need to be different for tan. + hcat [gtab, text "fnstsw %ax"] $$ + hcat [gtab, text "test $0x400,%eax"] $$ + hcat [gtab, text "jne " <> pprCLabel_asm l2] $$ + hcat [gtab, text "fstp %st(1)"] $$ + hcat [gtab, text op] $$ + (pprCLabel_asm l1 <> char ':') $$ + -- Pop the 1.0 tan gave us + (if isTan then hcat [gtab, text "fstp %st(0)"] else empty) $$ + -- Restore %eax + hcat [gtab, text "popl %eax;"] $$ + -- And finally make the result the right size + hcat [gtab, gcoerceto sz, gpop dst 1] + -------------------------- -- coerce %st(0) to the specified size -gcoerceto F64 = empty -gcoerceto F32 = empty --text "subl $4,%esp ; fstps (%esp) ; flds (%esp) ; addl $4,%esp ; " +gcoerceto FF64 = empty +gcoerceto FF32 = empty --text "subl $4,%esp ; fstps (%esp) ; flds (%esp) ; addl $4,%esp ; " gpush reg offset = hcat [text "ffree %st(7) ; fld ", greg reg offset] @@ -1609,26 +1652,26 @@ pprG :: Instr -> Doc -> Doc pprG fake actual = (char '#' <> pprGInstr fake) $$ actual -pprGInstr (GMOV src dst) = pprSizeRegReg (sLit "gmov") F64 src dst +pprGInstr (GMOV src dst) = pprSizeRegReg (sLit "gmov") FF64 src dst pprGInstr (GLD sz src dst) = pprSizeAddrReg (sLit "gld") sz src dst pprGInstr (GST sz src dst) = pprSizeRegAddr (sLit "gst") sz src dst -pprGInstr (GLDZ dst) = pprSizeReg (sLit "gldz") F64 dst -pprGInstr (GLD1 dst) = pprSizeReg (sLit "gld1") F64 dst +pprGInstr (GLDZ dst) = pprSizeReg (sLit "gldz") FF64 dst +pprGInstr (GLD1 dst) = pprSizeReg (sLit "gld1") FF64 dst -pprGInstr (GFTOI src dst) = pprSizeSizeRegReg (sLit "gftoi") F32 I32 src dst -pprGInstr (GDTOI src dst) = pprSizeSizeRegReg (sLit "gdtoi") F64 I32 src dst +pprGInstr (GFTOI src dst) = pprSizeSizeRegReg (sLit "gftoi") FF32 II32 src dst +pprGInstr (GDTOI src dst) = pprSizeSizeRegReg (sLit "gdtoi") FF64 II32 src dst -pprGInstr (GITOF src dst) = pprSizeSizeRegReg (sLit "gitof") I32 F32 src dst -pprGInstr (GITOD src dst) = pprSizeSizeRegReg (sLit "gitod") I32 F64 src dst +pprGInstr (GITOF src dst) = pprSizeSizeRegReg (sLit "gitof") II32 FF32 src dst +pprGInstr (GITOD src dst) = pprSizeSizeRegReg (sLit "gitod") II32 FF64 src dst -pprGInstr (GCMP co src dst) = pprCondRegReg (sLit "gcmp_") F64 co src dst +pprGInstr (GCMP co src dst) = pprCondRegReg (sLit "gcmp_") FF64 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 -pprGInstr (GSIN sz src dst) = pprSizeRegReg (sLit "gsin") sz src dst -pprGInstr (GCOS sz src dst) = pprSizeRegReg (sLit "gcos") sz src dst -pprGInstr (GTAN sz src dst) = pprSizeRegReg (sLit "gtan") sz src dst +pprGInstr (GSIN sz _ _ src dst) = pprSizeRegReg (sLit "gsin") sz src dst +pprGInstr (GCOS sz _ _ src dst) = pprSizeRegReg (sLit "gcos") sz src dst +pprGInstr (GTAN sz _ _ src dst) = pprSizeRegReg (sLit "gtan") sz src dst pprGInstr (GADD sz src1 src2 dst) = pprSizeRegRegReg (sLit "gadd") sz src1 src2 dst pprGInstr (GSUB sz src1 src2 dst) = pprSizeRegRegReg (sLit "gsub") sz src1 src2 dst @@ -1644,7 +1687,7 @@ pprDollImm :: Imm -> Doc pprDollImm i = ptext (sLit "$") <> pprImm i -pprOperand :: MachRep -> Operand -> Doc +pprOperand :: Size -> Operand -> Doc pprOperand s (OpReg r) = pprReg s r pprOperand s (OpImm i) = pprDollImm i pprOperand s (OpAddr ea) = pprAddr ea @@ -1653,11 +1696,11 @@ pprMnemonic_ :: LitString -> Doc pprMnemonic_ name = char '\t' <> ptext name <> space -pprMnemonic :: LitString -> MachRep -> Doc +pprMnemonic :: LitString -> Size -> Doc pprMnemonic name size = char '\t' <> ptext name <> pprSize size <> space -pprSizeImmOp :: LitString -> MachRep -> Imm -> Operand -> Doc +pprSizeImmOp :: LitString -> Size -> Imm -> Operand -> Doc pprSizeImmOp name size imm op1 = hcat [ pprMnemonic name size, @@ -1667,14 +1710,14 @@ pprSizeImmOp name size imm op1 pprOperand size op1 ] -pprSizeOp :: LitString -> MachRep -> Operand -> Doc +pprSizeOp :: LitString -> Size -> Operand -> Doc pprSizeOp name size op1 = hcat [ pprMnemonic name size, pprOperand size op1 ] -pprSizeOpOp :: LitString -> MachRep -> Operand -> Operand -> Doc +pprSizeOpOp :: LitString -> Size -> Operand -> Operand -> Doc pprSizeOpOp name size op1 op2 = hcat [ pprMnemonic name size, @@ -1683,7 +1726,7 @@ pprSizeOpOp name size op1 op2 pprOperand size op2 ] -pprOpOp :: LitString -> MachRep -> Operand -> Operand -> Doc +pprOpOp :: LitString -> Size -> Operand -> Operand -> Doc pprOpOp name size op1 op2 = hcat [ pprMnemonic_ name, @@ -1692,14 +1735,14 @@ pprOpOp name size op1 op2 pprOperand size op2 ] -pprSizeReg :: LitString -> MachRep -> Reg -> Doc +pprSizeReg :: LitString -> Size -> Reg -> Doc pprSizeReg name size reg1 = hcat [ pprMnemonic name size, pprReg size reg1 ] -pprSizeRegReg :: LitString -> MachRep -> Reg -> Reg -> Doc +pprSizeRegReg :: LitString -> Size -> Reg -> Reg -> Doc pprSizeRegReg name size reg1 reg2 = hcat [ pprMnemonic name size, @@ -1712,21 +1755,21 @@ pprRegReg :: LitString -> Reg -> Reg -> Doc pprRegReg name reg1 reg2 = hcat [ pprMnemonic_ name, - pprReg wordRep reg1, + pprReg wordSize reg1, comma, - pprReg wordRep reg2 + pprReg wordSize reg2 ] pprOpReg :: LitString -> Operand -> Reg -> Doc pprOpReg name op1 reg2 = hcat [ pprMnemonic_ name, - pprOperand wordRep op1, + pprOperand wordSize op1, comma, - pprReg wordRep reg2 + pprReg wordSize reg2 ] -pprCondRegReg :: LitString -> MachRep -> Cond -> Reg -> Reg -> Doc +pprCondRegReg :: LitString -> Size -> Cond -> Reg -> Reg -> Doc pprCondRegReg name size cond reg1 reg2 = hcat [ char '\t', @@ -1738,7 +1781,7 @@ pprCondRegReg name size cond reg1 reg2 pprReg size reg2 ] -pprSizeSizeRegReg :: LitString -> MachRep -> MachRep -> Reg -> Reg -> Doc +pprSizeSizeRegReg :: LitString -> Size -> Size -> Reg -> Reg -> Doc pprSizeSizeRegReg name size1 size2 reg1 reg2 = hcat [ char '\t', @@ -1752,7 +1795,7 @@ pprSizeSizeRegReg name size1 size2 reg1 reg2 pprReg size2 reg2 ] -pprSizeRegRegReg :: LitString -> MachRep -> Reg -> Reg -> Reg -> Doc +pprSizeRegRegReg :: LitString -> Size -> Reg -> Reg -> Reg -> Doc pprSizeRegRegReg name size reg1 reg2 reg3 = hcat [ pprMnemonic name size, @@ -1763,7 +1806,7 @@ pprSizeRegRegReg name size reg1 reg2 reg3 pprReg size reg3 ] -pprSizeAddrReg :: LitString -> MachRep -> AddrMode -> Reg -> Doc +pprSizeAddrReg :: LitString -> Size -> AddrMode -> Reg -> Doc pprSizeAddrReg name size op dst = hcat [ pprMnemonic name size, @@ -1772,7 +1815,7 @@ pprSizeAddrReg name size op dst pprReg size dst ] -pprSizeRegAddr :: LitString -> MachRep -> Reg -> AddrMode -> Doc +pprSizeRegAddr :: LitString -> Size -> Reg -> AddrMode -> Doc pprSizeRegAddr name size src op = hcat [ pprMnemonic name size, @@ -1781,16 +1824,16 @@ pprSizeRegAddr name size src op pprAddr op ] -pprShift :: LitString -> MachRep -> Operand -> Operand -> Doc +pprShift :: LitString -> Size -> Operand -> Operand -> Doc pprShift name size src dest = hcat [ pprMnemonic name size, - pprOperand I8 src, -- src is 8-bit sized + pprOperand II8 src, -- src is 8-bit sized comma, pprOperand size dest ] -pprSizeOpOpCoerce :: LitString -> MachRep -> MachRep -> 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, @@ -1837,7 +1880,7 @@ pprInstr (RELOAD slot reg) -- ld [g1+4],%f(n+1) -- sub g1,g2,g1 -- to restore g1 -pprInstr (LD F64 (AddrRegReg g1 g2) reg) +pprInstr (LD FF64 (AddrRegReg g1 g2) reg) = vcat [ hcat [ptext (sLit "\tadd\t"), pprReg g1,comma,pprReg g2,comma,pprReg g1], hcat [pp_ld_lbracket, pprReg g1, pp_rbracket_comma, pprReg reg], @@ -1848,7 +1891,7 @@ pprInstr (LD F64 (AddrRegReg g1 g2) reg) -- Translate to -- ld [addr],%fn -- ld [addr+4],%f(n+1) -pprInstr (LD F64 addr reg) | isJust off_addr +pprInstr (LD FF64 addr reg) | isJust off_addr = vcat [ hcat [pp_ld_lbracket, pprAddr addr, pp_rbracket_comma, pprReg reg], hcat [pp_ld_lbracket, pprAddr addr2, pp_rbracket_comma,pprReg (fPair reg)] @@ -1876,7 +1919,7 @@ pprInstr (LD size addr reg) -- st %fn,[g1] -- st %f(n+1),[g1+4] -- sub g1,g2,g1 -- to restore g1 -pprInstr (ST F64 reg (AddrRegReg g1 g2)) +pprInstr (ST FF64 reg (AddrRegReg g1 g2)) = vcat [ hcat [ptext (sLit "\tadd\t"), pprReg g1,comma,pprReg g2,comma,pprReg g1], hcat [ptext (sLit "\tst\t"), pprReg reg, pp_comma_lbracket, @@ -1889,7 +1932,7 @@ pprInstr (ST F64 reg (AddrRegReg g1 g2)) -- Translate to -- st %fn,[addr] -- st %f(n+1),[addr+4] -pprInstr (ST F64 reg addr) | isJust off_addr +pprInstr (ST FF64 reg addr) | isJust off_addr = vcat [ hcat [ptext (sLit "\tst\t"), pprReg reg, pp_comma_lbracket, pprAddr addr, rbrack], @@ -1964,12 +2007,12 @@ pprInstr (SETHI imm reg) pprInstr NOP = ptext (sLit "\tnop") -pprInstr (FABS F32 reg1 reg2) = pprSizeRegReg (sLit "fabs") F32 reg1 reg2 -pprInstr (FABS F64 reg1 reg2) - = (<>) (pprSizeRegReg (sLit "fabs") F32 reg1 reg2) +pprInstr (FABS FF32 reg1 reg2) = pprSizeRegReg (sLit "fabs") FF32 reg1 reg2 +pprInstr (FABS FF64 reg1 reg2) + = (<>) (pprSizeRegReg (sLit "fabs") FF32 reg1 reg2) (if (reg1 == reg2) then empty else (<>) (char '\n') - (pprSizeRegReg (sLit "fmov") F32 (fPair reg1) (fPair reg2))) + (pprSizeRegReg (sLit "fmov") FF32 (fPair reg1) (fPair reg2))) pprInstr (FADD size reg1 reg2 reg3) = pprSizeRegRegReg (sLit "fadd") size reg1 reg2 reg3 @@ -1978,22 +2021,22 @@ pprInstr (FCMP e size reg1 reg2) pprInstr (FDIV size reg1 reg2 reg3) = pprSizeRegRegReg (sLit "fdiv") size reg1 reg2 reg3 -pprInstr (FMOV F32 reg1 reg2) = pprSizeRegReg (sLit "fmov") F32 reg1 reg2 -pprInstr (FMOV F64 reg1 reg2) - = (<>) (pprSizeRegReg (sLit "fmov") F32 reg1 reg2) +pprInstr (FMOV FF32 reg1 reg2) = pprSizeRegReg (sLit "fmov") FF32 reg1 reg2 +pprInstr (FMOV FF64 reg1 reg2) + = (<>) (pprSizeRegReg (sLit "fmov") FF32 reg1 reg2) (if (reg1 == reg2) then empty else (<>) (char '\n') - (pprSizeRegReg (sLit "fmov") F32 (fPair reg1) (fPair reg2))) + (pprSizeRegReg (sLit "fmov") FF32 (fPair reg1) (fPair reg2))) pprInstr (FMUL size reg1 reg2 reg3) = pprSizeRegRegReg (sLit "fmul") size reg1 reg2 reg3 -pprInstr (FNEG F32 reg1 reg2) = pprSizeRegReg (sLit "fneg") F32 reg1 reg2 -pprInstr (FNEG F64 reg1 reg2) - = (<>) (pprSizeRegReg (sLit "fneg") F32 reg1 reg2) +pprInstr (FNEG FF32 reg1 reg2) = pprSizeRegReg (sLit "fneg") FF32 reg1 reg2 +pprInstr (FNEG FF64 reg1 reg2) + = (<>) (pprSizeRegReg (sLit "fneg") FF32 reg1 reg2) (if (reg1 == reg2) then empty else (<>) (char '\n') - (pprSizeRegReg (sLit "fmov") F32 (fPair reg1) (fPair reg2))) + (pprSizeRegReg (sLit "fmov") FF32 (fPair reg1) (fPair reg2))) pprInstr (FSQRT size reg1 reg2) = pprSizeRegReg (sLit "fsqrt") size reg1 reg2 pprInstr (FSUB size reg1 reg2 reg3) = pprSizeRegRegReg (sLit "fsub") size reg1 reg2 reg3 @@ -2002,14 +2045,14 @@ pprInstr (FxTOy size1 size2 reg1 reg2) ptext (sLit "\tf"), ptext (case size1 of - I32 -> sLit "ito" - F32 -> sLit "sto" - F64 -> sLit "dto"), + II32 -> sLit "ito" + FF32 -> sLit "sto" + FF64 -> sLit "dto"), ptext (case size2 of - I32 -> sLit "i\t" - F32 -> sLit "s\t" - F64 -> sLit "d\t"), + II32 -> sLit "i\t" + FF32 -> sLit "s\t" + FF64 -> sLit "d\t"), pprReg reg1, comma, pprReg reg2 ] @@ -2041,27 +2084,27 @@ pprRI :: RI -> Doc pprRI (RIReg r) = pprReg r pprRI (RIImm r) = pprImm r -pprSizeRegReg :: LitString -> MachRep -> Reg -> Reg -> Doc +pprSizeRegReg :: LitString -> Size -> Reg -> Reg -> Doc pprSizeRegReg name size reg1 reg2 = hcat [ char '\t', ptext name, (case size of - F32 -> ptext (sLit "s\t") - F64 -> ptext (sLit "d\t")), + FF32 -> ptext (sLit "s\t") + FF64 -> ptext (sLit "d\t")), pprReg reg1, comma, pprReg reg2 ] -pprSizeRegRegReg :: LitString -> MachRep -> Reg -> Reg -> Reg -> Doc +pprSizeRegRegReg :: LitString -> Size -> Reg -> Reg -> Reg -> Doc pprSizeRegRegReg name size reg1 reg2 reg3 = hcat [ char '\t', ptext name, (case size of - F32 -> ptext (sLit "s\t") - F64 -> ptext (sLit "d\t")), + FF32 -> ptext (sLit "s\t") + FF64 -> ptext (sLit "d\t")), pprReg reg1, comma, pprReg reg2, @@ -2126,11 +2169,11 @@ pprInstr (LD sz reg addr) = hcat [ char '\t', ptext (sLit "l"), ptext (case sz of - I8 -> sLit "bz" - I16 -> sLit "hz" - I32 -> sLit "wz" - F32 -> sLit "fs" - F64 -> sLit "fd"), + II8 -> sLit "bz" + II16 -> sLit "hz" + II32 -> sLit "wz" + FF32 -> sLit "fs" + FF64 -> sLit "fd"), case addr of AddrRegImm _ _ -> empty AddrRegReg _ _ -> char 'x', char '\t', @@ -2142,11 +2185,11 @@ pprInstr (LA sz reg addr) = hcat [ char '\t', ptext (sLit "l"), ptext (case sz of - I8 -> sLit "ba" - I16 -> sLit "ha" - I32 -> sLit "wa" - F32 -> sLit "fs" - F64 -> sLit "fd"), + II8 -> sLit "ba" + II16 -> sLit "ha" + II32 -> sLit "wa" + FF32 -> sLit "fs" + FF64 -> sLit "fd"), case addr of AddrRegImm _ _ -> empty AddrRegReg _ _ -> char 'x', char '\t', @@ -2461,8 +2504,8 @@ pprRI :: RI -> Doc pprRI (RIReg r) = pprReg r pprRI (RIImm r) = pprImm r -pprFSize F64 = empty -pprFSize F32 = char 's' +pprFSize FF64 = empty +pprFSize FF32 = char 's' -- limit immediate argument for shift instruction to range 0..32 -- (yes, the maximum is really 32, not 31)