module PprMach (
pprNatCmmTop, pprBasicBlock, pprSectionHeader, pprData,
- pprInstr, pprSize, pprUserReg
+ pprInstr, pprSize, pprUserReg, pprImm
) where
+#include "HsVersions.h"
+
+import BlockId
import Cmm
-import MachOp ( MachRep(..), wordRep, isFloatingRep )
-import MachRegs -- may differ per-platform
-import MachInstrs
+import Regs -- may differ per-platform
+import Instrs
+import Regs
import CLabel ( CLabel, pprCLabel, externallyVisibleCLabel,
labelDynamic, mkAsmTempLabel, entryLblToInfoLbl )
import Pretty
import FastString
import qualified Outputable
-import Outputable ( Outputable )
+import Outputable ( Outputable, pprPanic, ppr, docToSDoc)
import Data.Array.ST
import Data.Word ( Word8 )
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
-- 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
})
#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
#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
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
-- -----------------------------------------------------------------------------
--- pprSize: print a 'Size'
+-- | print a 'Size'
+-- Used for instruction suffixes.
+-- eg LD is 32bit on sparc, but LDD is 64 bit.
+--
#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
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 "ub"
+ II16 -> sLit "uh"
+ II32 -> sLit ""
+ II64 -> sLit "d"
+ FF32 -> sLit ""
+ FF64 -> sLit "d"
)
-pprStSize :: MachRep -> Doc
+
+-- suffix to store/ ST instruction
+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 ""
+ II64 -> sLit "x"
+ 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
)
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
-#if sparc_TARGET_ARCH
+-- #if sparc_TARGET_ARCH
-- ToDo: This should really be fixed in the PIC support, but only
-- print a for now.
-pprImm (ImmConstantDiff a b) = pprImm a
-#else
+-- pprImm (ImmConstantDiff a b) = pprImm a
+-- #else
pprImm (ImmConstantDiff a b) = pprImm a <> char '-'
<> lparen <> pprImm b <> rparen
-#endif
+-- #endif
#if sparc_TARGET_ARCH
pprImm (LO i)
= 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
#if powerpc_TARGET_ARCH
pprAddr (AddrRegReg r1 r2)
- = pprReg r1 <+> ptext sLit ", " <+> pprReg r2
+ = pprReg r1 <+> ptext (sLit ", ") <+> pprReg r2
pprAddr (AddrRegImm r1 (ImmInt i)) = hcat [ int i, char '(', pprReg r1, char ')' ]
pprAddr (AddrRegImm r1 (ImmInteger i)) = hcat [ integer i, char '(', pprReg r1, char ')' ]
pprSectionHeader ReadOnlyData
= 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_sparc(sLit ".text\n\t.align 8" {-<8 will break double constants -}
,IF_ARCH_i386(IF_OS_darwin(sLit ".const\n.align 2",
sLit ".section .rodata\n\t.align 4")
,IF_ARCH_x86_64(IF_OS_darwin(sLit ".const\n.align 3",
pprSectionHeader RelocatableReadOnlyData
= 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_sparc(sLit ".text\n\t.align 8" {-<8 will break double constants -}
,IF_ARCH_i386(IF_OS_darwin(sLit ".const_data\n.align 2",
sLit ".section .data\n\t.align 4")
,IF_ARCH_x86_64(IF_OS_darwin(sLit ".const_data\n.align 3",
pprData (CmmAlign bytes) = pprAlign bytes
pprData (CmmDataLabel lbl) = pprLabel lbl
pprData (CmmString str) = pprASCII str
-pprData (CmmUninitialised bytes) = ptext (sLit ".space ") <> int bytes
+pprData (CmmUninitialised bytes) = ptext (sLit ".skip ") <> int bytes
pprData (CmmStaticLit lit) = pprDataItem lit
pprGloblDecl :: CLabel -> Doc
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")
(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
--
-- 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")]
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)),
pprInstr :: Instr -> Doc
---pprInstr (COMMENT s) = empty -- nuke 'em
+pprInstr (COMMENT s) = empty -- nuke 'em
+{-
pprInstr (COMMENT s)
= IF_ARCH_alpha( ((<>) (ptext (sLit "\t# ")) (ftext s))
- ,IF_ARCH_sparc( ((<>) (ptext (sLit "! ")) (ftext s))
+ ,IF_ARCH_sparc( ((<>) (ptext (sLit "# ")) (ftext s))
,IF_ARCH_i386( ((<>) (ptext (sLit "# ")) (ftext s))
,IF_ARCH_x86_64( ((<>) (ptext (sLit "# ")) (ftext s))
,IF_ARCH_powerpc( IF_OS_linux(
((<>) (ptext (sLit "# ")) (ftext s)),
((<>) (ptext (sLit "; ")) (ftext s)))
,)))))
-
+-}
pprInstr (DELTA d)
= pprInstr (COMMENT (mkFastString ("\tdelta = " ++ show d)))
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.
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
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
-- 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)
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
-- 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
-- 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 ]
]
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"])
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
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]
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
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
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,
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,
pprOperand size op2
]
-pprOpOp :: LitString -> MachRep -> Operand -> Operand -> Doc
+pprOpOp :: LitString -> Size -> Operand -> Operand -> Doc
pprOpOp name size op1 op2
= hcat [
pprMnemonic_ name,
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,
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',
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',
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,
pprReg size reg3
]
-pprSizeAddrReg :: LitString -> MachRep -> AddrMode -> Reg -> Doc
+pprSizeAddrReg :: LitString -> Size -> AddrMode -> Reg -> Doc
pprSizeAddrReg name size op dst
= hcat [
pprMnemonic name size,
pprReg size dst
]
-pprSizeRegAddr :: LitString -> MachRep -> Reg -> AddrMode -> Doc
+pprSizeRegAddr :: LitString -> Size -> Reg -> AddrMode -> Doc
pprSizeRegAddr name size src op
= hcat [
pprMnemonic name size,
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,
-- ld [g1+4],%f(n+1)
-- sub g1,g2,g1 -- to restore g1
-pprInstr (LD F64 (AddrRegReg g1 g2) reg)
- = vcat [
+pprInstr (LD FF64 (AddrRegReg g1 g2) reg)
+ = let Just regH = fPair reg
+ in 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],
- hcat [pp_ld_lbracket, pprReg g1, ptext (sLit "+4]"), comma, pprReg (fPair reg)],
+ hcat [pp_ld_lbracket, pprReg g1, ptext (sLit "+4]"), comma, pprReg regH],
hcat [ptext (sLit "\tsub\t"), pprReg g1,comma,pprReg g2,comma,pprReg g1]
]
-- Translate to
-- ld [addr],%fn
-- ld [addr+4],%f(n+1)
-pprInstr (LD F64 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)]
- ]
- where
- off_addr = addrOffset addr 4
- addr2 = case off_addr of Just x -> x
-
+pprInstr (LD FF64 addr reg)
+ = let Just addr2 = addrOffset addr 4
+ Just regH = fPair reg
+ in vcat [
+ hcat [pp_ld_lbracket, pprAddr addr, pp_rbracket_comma, pprReg reg],
+ hcat [pp_ld_lbracket, pprAddr addr2, pp_rbracket_comma,pprReg regH]
+ ]
+
pprInstr (LD size addr reg)
= hcat [
-- st %fn,[g1]
-- st %f(n+1),[g1+4]
-- sub g1,g2,g1 -- to restore g1
-pprInstr (ST F64 reg (AddrRegReg g1 g2))
- = vcat [
+pprInstr (ST FF64 reg (AddrRegReg g1 g2))
+ = let Just regH = fPair reg
+ in vcat [
hcat [ptext (sLit "\tadd\t"), pprReg g1,comma,pprReg g2,comma,pprReg g1],
hcat [ptext (sLit "\tst\t"), pprReg reg, pp_comma_lbracket,
pprReg g1, rbrack],
- hcat [ptext (sLit "\tst\t"), pprReg (fPair reg), pp_comma_lbracket,
+ hcat [ptext (sLit "\tst\t"), pprReg regH, pp_comma_lbracket,
pprReg g1, ptext (sLit "+4]")],
hcat [ptext (sLit "\tsub\t"), pprReg g1,comma,pprReg g2,comma,pprReg g1]
]
-- Translate to
-- st %fn,[addr]
-- st %f(n+1),[addr+4]
-pprInstr (ST F64 reg addr) | isJust off_addr
- = vcat [
- hcat [ptext (sLit "\tst\t"), pprReg reg, pp_comma_lbracket,
- pprAddr addr, rbrack],
- hcat [ptext (sLit "\tst\t"), pprReg (fPair reg), pp_comma_lbracket,
- pprAddr addr2, rbrack]
- ]
- where
- off_addr = addrOffset addr 4
- addr2 = case off_addr of Just x -> x
+pprInstr instr@(ST FF64 reg addr)
+ = let Just addr2 = addrOffset addr 4
+ Just regH = fPair reg
+ in vcat [
+ hcat [ptext (sLit "\tst\t"), pprReg reg, pp_comma_lbracket,
+ pprAddr addr, rbrack],
+ hcat [ptext (sLit "\tst\t"), pprReg regH, pp_comma_lbracket,
+ pprAddr addr2, rbrack]
+ ]
+
+
-- no distinction is made between signed and unsigned bytes on stores for the
-- Sparc opcodes (at least I cannot see any, and gas is nagging me --SOF),
pprInstr (ADD x cc reg1 ri reg2)
| not x && not cc && riZero ri
= hcat [ ptext (sLit "\tmov\t"), pprReg reg1, comma, pprReg reg2 ]
+
| otherwise
= pprRegRIReg (if x then sLit "addx" else sLit "add") cc reg1 ri reg2
in case ri of
RIReg rrr | rrr == reg2 -> empty
other -> doit
+
| otherwise
= pprRegRIReg (sLit "or") b 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 (RDY rd) = ptext (sLit "\trd\t%y,") <> pprReg rd
+pprInstr (WRY reg1 reg2)
+ = ptext (sLit "\twr\t")
+ <> pprReg reg1
+ <> char ','
+ <> pprReg reg2
+ <> char ','
+ <> ptext (sLit "%y")
+
+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 (SDIV b reg1 ri reg2) = pprRegRIReg (sLit "sdiv") b reg1 ri reg2
+pprInstr (UDIV b reg1 ri reg2) = pprRegRIReg (sLit "udiv") b reg1 ri reg2
pprInstr (SETHI imm reg)
= hcat [
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)
+ = let Just reg1H = fPair reg1
+ Just reg2H = fPair reg2
+ in
+ (<>) (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 reg1H reg2H))
pprInstr (FADD size reg1 reg2 reg3)
= pprSizeRegRegReg (sLit "fadd") size reg1 reg2 reg3
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") FF64 reg1 reg2
+
+{-
+pprInstr (FMOV FF64 reg1 reg2)
+ = let Just reg1H = fPair reg1
+ Just reg2H = fPair reg2
+ in
+ (<>) (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 reg1H reg2H))
+-}
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)
+ = let Just reg1H = fPair reg1
+ Just reg2H = fPair reg2
+ in
+ (<>) (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 reg1H reg2H))
pprInstr (FSQRT size reg1 reg2) = pprSizeRegReg (sLit "fsqrt") size reg1 reg2
pprInstr (FSUB size reg1 reg2 reg3) = pprSizeRegRegReg (sLit "fsub") size reg1 reg2 reg3
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"
+ II64 -> sLit "x\t"
+ FF32 -> sLit "s\t"
+ FF64 -> sLit "d\t"),
pprReg reg1, comma, pprReg reg2
]
-pprInstr (BI cond b lab)
+pprInstr (BI cond b (BlockId id))
= hcat [
ptext (sLit "\tb"), pprCond cond,
if b then pp_comma_a else empty,
char '\t',
- pprImm lab
+ pprCLabel_asm (mkAsmTempLabel id)
]
-pprInstr (BF cond b lab)
+pprInstr (BF cond b (BlockId id))
= hcat [
ptext (sLit "\tfb"), pprCond cond,
if b then pp_comma_a else empty,
char '\t',
- pprImm lab
+ pprCLabel_asm (mkAsmTempLabel id)
]
pprInstr (JMP addr) = (<>) (ptext (sLit "\tjmp\t")) (pprAddr addr)
+pprInstr (JMP_TBL op ids) = pprInstr (JMP op)
pprInstr (CALL (Left imm) n _)
= hcat [ ptext (sLit "\tcall\t"), pprImm imm, comma, int n ]
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,
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',
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',
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)
projects / ghc-hetmet.git / blobdiff