module X86.Ppr (
pprNatCmmTop,
pprBasicBlock,
pprSectionHeader,
pprData,
pprInstr,
pprUserReg,
pprSize,
pprImm,
pprDataItem,
)
where
#include "HsVersions.h"
#include "nativeGen/NCG.h"
import X86.Regs
import X86.Instr
import X86.Cond
import Instruction
import Size
import Reg
import PprBase
import BlockId
import Cmm
import CLabel
import Unique ( pprUnique )
import Pretty
import FastString
import qualified Outputable
import Outputable (panic, Outputable)
import Data.Word
#if i386_TARGET_ARCH && darwin_TARGET_OS
import Data.Bits
#endif
pprNatCmmTop :: NatCmmTop Instr -> Doc
pprNatCmmTop (CmmData section dats) =
pprSectionHeader section $$ vcat (map pprData dats)
pprNatCmmTop (CmmProc [] lbl _ (ListGraph [])) = pprLabel lbl
pprNatCmmTop (CmmProc info lbl _ (ListGraph blocks)) =
pprSectionHeader Text $$
(if null info then
pprLabel lbl
else
#if HAVE_SUBSECTIONS_VIA_SYMBOLS
pprCLabel_asm (mkDeadStripPreventer $ entryLblToInfoLbl lbl)
<> char ':' $$
#endif
vcat (map pprData info) $$
pprLabel (entryLblToInfoLbl lbl)
) $$
vcat (map pprBasicBlock blocks)
#if HAVE_SUBSECTIONS_VIA_SYMBOLS
$$ if not (null info)
then text "\t.long "
<+> pprCLabel_asm (entryLblToInfoLbl lbl)
<+> char '-'
<+> pprCLabel_asm (mkDeadStripPreventer $ entryLblToInfoLbl lbl)
else empty
#endif
pprBasicBlock :: NatBasicBlock Instr -> Doc
pprBasicBlock (BasicBlock (BlockId id) instrs) =
pprLabel (mkAsmTempLabel id) $$
vcat (map pprInstr instrs)
pprData :: CmmStatic -> Doc
pprData (CmmAlign bytes) = pprAlign bytes
pprData (CmmDataLabel lbl) = pprLabel lbl
pprData (CmmString str) = pprASCII str
#if darwin_TARGET_OS
pprData (CmmUninitialised bytes) = ptext (sLit ".space ") <> int bytes
#else
pprData (CmmUninitialised bytes) = ptext (sLit ".skip ") <> int bytes
#endif
pprData (CmmStaticLit lit) = pprDataItem lit
pprGloblDecl :: CLabel -> Doc
pprGloblDecl lbl
| not (externallyVisibleCLabel lbl) = empty
| otherwise = ptext IF_ARCH_sparc((sLit ".global "),
(sLit ".globl ")) <>
pprCLabel_asm lbl
pprTypeAndSizeDecl :: CLabel -> Doc
#if elf_OBJ_FORMAT
pprTypeAndSizeDecl lbl
| not (externallyVisibleCLabel lbl) = empty
| otherwise = ptext (sLit ".type ") <>
pprCLabel_asm lbl <> ptext (sLit ", @object")
#else
pprTypeAndSizeDecl _
= empty
#endif
pprLabel :: CLabel -> Doc
pprLabel lbl = pprGloblDecl lbl $$ pprTypeAndSizeDecl lbl $$ (pprCLabel_asm lbl <> char ':')
pprASCII :: [Word8] -> Doc
pprASCII str
= vcat (map do1 str) $$ do1 0
where
do1 :: Word8 -> Doc
do1 w = ptext (sLit "\t.byte\t") <> int (fromIntegral w)
pprAlign :: Int -> Doc
pprAlign bytes
= ptext (sLit ".align ") <> int IF_OS_darwin(pow2, bytes)
where
#if darwin_TARGET_OS
pow2 = log2 bytes
log2 :: Int -> Int
log2 1 = 0
log2 2 = 1
log2 4 = 2
log2 8 = 3
log2 n = 1 + log2 (n `quot` 2)
#endif
instance Outputable Instr where
ppr instr = Outputable.docToSDoc $ pprInstr instr
#if i386_TARGET_ARCH || x86_64_TARGET_ARCH
pprUserReg :: Reg -> Doc
pprUserReg = pprReg IF_ARCH_i386(II32,) IF_ARCH_x86_64(II64,)
#else
pprUserReg :: Reg -> Doc
pprUserReg = panic "X86.Ppr.pprUserReg: not defined"
#endif
pprReg :: Size -> Reg -> Doc
pprReg s r
= case r of
RegReal (RealRegSingle i) -> ppr_reg_no s i
RegReal (RealRegPair _ _) -> panic "X86.Ppr: no reg pairs on this arch"
RegVirtual (VirtualRegI u) -> text "%vI_" <> asmSDoc (pprUnique u)
RegVirtual (VirtualRegHi u) -> text "%vHi_" <> asmSDoc (pprUnique u)
RegVirtual (VirtualRegF u) -> text "%vF_" <> asmSDoc (pprUnique u)
RegVirtual (VirtualRegD u) -> text "%vD_" <> asmSDoc (pprUnique u)
RegVirtual (VirtualRegSSE u) -> text "%vSSE_" <> asmSDoc (pprUnique u)
where
#if i386_TARGET_ARCH
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
(case i of {
0 -> sLit "%al"; 1 -> sLit "%bl";
2 -> sLit "%cl"; 3 -> sLit "%dl";
_ -> sLit "very naughty I386 byte register"
})
ppr_reg_word i = ptext
(case i of {
0 -> sLit "%ax"; 1 -> sLit "%bx";
2 -> sLit "%cx"; 3 -> sLit "%dx";
4 -> sLit "%si"; 5 -> sLit "%di";
6 -> sLit "%bp"; 7 -> sLit "%sp";
_ -> sLit "very naughty I386 word register"
})
ppr_reg_long i = ptext
(case i of {
0 -> sLit "%eax"; 1 -> sLit "%ebx";
2 -> sLit "%ecx"; 3 -> sLit "%edx";
4 -> sLit "%esi"; 5 -> sLit "%edi";
6 -> sLit "%ebp"; 7 -> sLit "%esp";
_ -> ppr_reg_float i
})
#elif x86_64_TARGET_ARCH
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
(case i of {
0 -> sLit "%al"; 1 -> sLit "%bl";
2 -> sLit "%cl"; 3 -> sLit "%dl";
4 -> sLit "%sil"; 5 -> sLit "%dil";
6 -> sLit "%bpl"; 7 -> sLit "%spl";
8 -> sLit "%r8b"; 9 -> sLit "%r9b";
10 -> sLit "%r10b"; 11 -> sLit "%r11b";
12 -> sLit "%r12b"; 13 -> sLit "%r13b";
14 -> sLit "%r14b"; 15 -> sLit "%r15b";
_ -> sLit "very naughty x86_64 byte register"
})
ppr_reg_word i = ptext
(case i of {
0 -> sLit "%ax"; 1 -> sLit "%bx";
2 -> sLit "%cx"; 3 -> sLit "%dx";
4 -> sLit "%si"; 5 -> sLit "%di";
6 -> sLit "%bp"; 7 -> sLit "%sp";
8 -> sLit "%r8w"; 9 -> sLit "%r9w";
10 -> sLit "%r10w"; 11 -> sLit "%r11w";
12 -> sLit "%r12w"; 13 -> sLit "%r13w";
14 -> sLit "%r14w"; 15 -> sLit "%r15w";
_ -> sLit "very naughty x86_64 word register"
})
ppr_reg_long i = ptext
(case i of {
0 -> sLit "%eax"; 1 -> sLit "%ebx";
2 -> sLit "%ecx"; 3 -> sLit "%edx";
4 -> sLit "%esi"; 5 -> sLit "%edi";
6 -> sLit "%ebp"; 7 -> sLit "%esp";
8 -> sLit "%r8d"; 9 -> sLit "%r9d";
10 -> sLit "%r10d"; 11 -> sLit "%r11d";
12 -> sLit "%r12d"; 13 -> sLit "%r13d";
14 -> sLit "%r14d"; 15 -> sLit "%r15d";
_ -> sLit "very naughty x86_64 register"
})
ppr_reg_quad i = ptext
(case i of {
0 -> sLit "%rax"; 1 -> sLit "%rbx";
2 -> sLit "%rcx"; 3 -> sLit "%rdx";
4 -> sLit "%rsi"; 5 -> sLit "%rdi";
6 -> sLit "%rbp"; 7 -> sLit "%rsp";
8 -> sLit "%r8"; 9 -> sLit "%r9";
10 -> sLit "%r10"; 11 -> sLit "%r11";
12 -> sLit "%r12"; 13 -> sLit "%r13";
14 -> sLit "%r14"; 15 -> sLit "%r15";
_ -> ppr_reg_float i
})
#else
ppr_reg_no _ = panic "X86.Ppr.ppr_reg_no: no match"
#endif
#if defined(i386_TARGET_ARCH) || defined(x86_64_TARGET_ARCH)
ppr_reg_float :: Int -> LitString
ppr_reg_float i = case i of
16 -> sLit "%fake0"; 17 -> sLit "%fake1"
18 -> sLit "%fake2"; 19 -> sLit "%fake3"
20 -> sLit "%fake4"; 21 -> sLit "%fake5"
24 -> sLit "%xmm0"; 25 -> sLit "%xmm1"
26 -> sLit "%xmm2"; 27 -> sLit "%xmm3"
28 -> sLit "%xmm4"; 29 -> sLit "%xmm5"
30 -> sLit "%xmm6"; 31 -> sLit "%xmm7"
32 -> sLit "%xmm8"; 33 -> sLit "%xmm9"
34 -> sLit "%xmm10"; 35 -> sLit "%xmm11"
36 -> sLit "%xmm12"; 37 -> sLit "%xmm13"
38 -> sLit "%xmm14"; 39 -> sLit "%xmm15"
_ -> sLit "very naughty x86 register"
#endif
pprSize :: Size -> Doc
pprSize x
= ptext (case x of
II8 -> sLit "b"
II16 -> sLit "w"
II32 -> sLit "l"
II64 -> sLit "q"
FF32 -> sLit "ss"
FF64 -> sLit "sd"
FF80 -> sLit "t"
)
pprSize_x87 :: Size -> Doc
pprSize_x87 x
= ptext $ case x of
FF32 -> sLit "s"
FF64 -> sLit "l"
FF80 -> sLit "t"
_ -> panic "X86.Ppr.pprSize_x87"
pprCond :: Cond -> Doc
pprCond c
= ptext (case c of {
GEU -> sLit "ae"; LU -> sLit "b";
EQQ -> sLit "e"; GTT -> sLit "g";
GE -> sLit "ge"; GU -> sLit "a";
LTT -> sLit "l"; LE -> sLit "le";
LEU -> sLit "be"; NE -> sLit "ne";
NEG -> sLit "s"; POS -> sLit "ns";
CARRY -> sLit "c"; OFLO -> sLit "o";
PARITY -> sLit "p"; NOTPARITY -> sLit "np";
ALWAYS -> sLit "mp"})
pprImm :: Imm -> Doc
pprImm (ImmInt i) = int i
pprImm (ImmInteger i) = integer i
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 (ImmDouble _) = ptext (sLit "naughty double immediate")
pprImm (ImmConstantSum a b) = pprImm a <> char '+' <> pprImm b
pprImm (ImmConstantDiff a b) = pprImm a <> char '-'
<> lparen <> pprImm b <> rparen
pprAddr :: AddrMode -> Doc
pprAddr (ImmAddr imm off)
= let pp_imm = pprImm imm
in
if (off == 0) then
pp_imm
else if (off < 0) then
pp_imm <> int off
else
pp_imm <> char '+' <> int off
pprAddr (AddrBaseIndex base index displacement)
= let
pp_disp = ppr_disp displacement
pp_off p = pp_disp <> char '(' <> p <> char ')'
pp_reg r = pprReg archWordSize r
in
case (base, index) of
(EABaseNone, EAIndexNone) -> pp_disp
(EABaseReg b, EAIndexNone) -> pp_off (pp_reg b)
(EABaseRip, EAIndexNone) -> pp_off (ptext (sLit "%rip"))
(EABaseNone, EAIndex r i) -> pp_off (comma <> pp_reg r <> comma <> int i)
(EABaseReg b, EAIndex r i) -> pp_off (pp_reg b <> comma <> pp_reg r
<> comma <> int i)
_ -> panic "X86.Ppr.pprAddr: no match"
where
ppr_disp (ImmInt 0) = empty
ppr_disp imm = pprImm imm
pprSectionHeader :: Section -> Doc
#if i386_TARGET_ARCH
# if darwin_TARGET_OS
pprSectionHeader seg
= case seg of
Text -> ptext (sLit ".text\n\t.align 2")
Data -> ptext (sLit ".data\n\t.align 2")
ReadOnlyData -> ptext (sLit ".const\n.align 2")
RelocatableReadOnlyData -> ptext (sLit ".const_data\n.align 2")
UninitialisedData -> ptext (sLit ".data\n\t.align 2")
ReadOnlyData16 -> ptext (sLit ".const\n.align 4")
OtherSection _ -> panic "X86.Ppr.pprSectionHeader: unknown section"
# else
pprSectionHeader seg
= case seg of
Text -> ptext (sLit ".text\n\t.align 4,0x90")
Data -> ptext (sLit ".data\n\t.align 4")
ReadOnlyData -> ptext (sLit ".section .rodata\n\t.align 4")
RelocatableReadOnlyData -> ptext (sLit ".section .data\n\t.align 4")
UninitialisedData -> ptext (sLit ".section .bss\n\t.align 4")
ReadOnlyData16 -> ptext (sLit ".section .rodata\n\t.align 16")
OtherSection _ -> panic "X86.Ppr.pprSectionHeader: unknown section"
# endif
#elif x86_64_TARGET_ARCH
# if darwin_TARGET_OS
pprSectionHeader seg
= case seg of
Text -> ptext (sLit ".text\n.align 3")
Data -> ptext (sLit ".data\n.align 3")
ReadOnlyData -> ptext (sLit ".const\n.align 3")
RelocatableReadOnlyData -> ptext (sLit ".const_data\n.align 3")
UninitialisedData -> ptext (sLit ".data\n\t.align 3")
ReadOnlyData16 -> ptext (sLit ".const\n.align 4")
OtherSection _ -> panic "PprMach.pprSectionHeader: unknown section"
# else
pprSectionHeader seg
= case seg of
Text -> ptext (sLit ".text\n\t.align 8")
Data -> ptext (sLit ".data\n\t.align 8")
ReadOnlyData -> ptext (sLit ".section .rodata\n\t.align 8")
RelocatableReadOnlyData -> ptext (sLit ".section .data\n\t.align 8")
UninitialisedData -> ptext (sLit ".section .bss\n\t.align 8")
ReadOnlyData16 -> ptext (sLit ".section .rodata.cst16\n\t.align 16")
OtherSection _ -> panic "PprMach.pprSectionHeader: unknown section"
# endif
#else
pprSectionHeader _ = panic "X86.Ppr.pprSectionHeader: not defined for this architecture"
#endif
pprDataItem :: CmmLit -> Doc
pprDataItem lit
= vcat (ppr_item (cmmTypeSize $ cmmLitType lit) lit)
where
imm = litToImm lit
ppr_item II8 _ = [ptext (sLit "\t.byte\t") <> pprImm imm]
ppr_item II32 _ = [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 FF64 (CmmFloat r _)
= let bs = doubleToBytes (fromRational r)
in map (\b -> ptext (sLit "\t.byte\t") <> pprImm (ImmInt b)) bs
#if i386_TARGET_ARCH || x86_64_TARGET_ARCH
ppr_item II16 _ = [ptext (sLit "\t.word\t") <> pprImm imm]
#endif
#if i386_TARGET_ARCH && darwin_TARGET_OS
ppr_item II64 (CmmInt x _) =
[ptext (sLit "\t.long\t")
<> int (fromIntegral (fromIntegral x :: Word32)),
ptext (sLit "\t.long\t")
<> int (fromIntegral
(fromIntegral (x `shiftR` 32) :: Word32))]
#endif
#if i386_TARGET_ARCH || (darwin_TARGET_OS && x86_64_TARGET_ARCH)
ppr_item II64 _ = [ptext (sLit "\t.quad\t") <> pprImm imm]
#endif
#if x86_64_TARGET_ARCH && !darwin_TARGET_OS
ppr_item II64 x
| isRelativeReloc x =
[ptext (sLit "\t.long\t") <> pprImm imm,
ptext (sLit "\t.long\t0")]
| otherwise =
[ptext (sLit "\t.quad\t") <> pprImm imm]
where
isRelativeReloc (CmmLabelDiffOff _ _ _) = True
isRelativeReloc _ = False
#endif
ppr_item _ _
= panic "X86.Ppr.ppr_item: no match"
pprInstr :: Instr -> Doc
pprInstr (COMMENT _) = empty
pprInstr (DELTA d)
= pprInstr (COMMENT (mkFastString ("\tdelta = " ++ show d)))
pprInstr (NEWBLOCK _)
= panic "PprMach.pprInstr: NEWBLOCK"
pprInstr (LDATA _ _)
= panic "PprMach.pprInstr: LDATA"
pprInstr (MOV size src dst)
= pprSizeOpOp (sLit "mov") size src dst
pprInstr (MOVZxL II32 src dst) = pprSizeOpOp (sLit "mov") II32 src dst
pprInstr (MOVZxL sizes src dst) = pprSizeOpOpCoerce (sLit "movz") sizes II32 src dst
pprInstr (MOVSxL sizes src dst) = pprSizeOpOpCoerce (sLit "movs") sizes archWordSize src dst
pprInstr (LEA size (OpAddr (AddrBaseIndex (EABaseReg reg1) (EAIndex reg2 1) (ImmInt 0))) dst@(OpReg reg3))
| reg1 == reg3
= pprSizeOpOp (sLit "add") size (OpReg reg2) dst
pprInstr (LEA size (OpAddr (AddrBaseIndex (EABaseReg reg1) (EAIndex reg2 1) (ImmInt 0))) dst@(OpReg reg3))
| reg2 == reg3
= pprSizeOpOp (sLit "add") size (OpReg reg1) dst
pprInstr (LEA size (OpAddr (AddrBaseIndex (EABaseReg reg1) EAIndexNone displ)) dst@(OpReg reg3))
| reg1 == reg3
= pprInstr (ADD size (OpImm displ) dst)
pprInstr (LEA size src dst) = pprSizeOpOp (sLit "lea") size src dst
pprInstr (ADD size (OpImm (ImmInt (1))) dst)
= pprSizeOp (sLit "dec") size dst
pprInstr (ADD size (OpImm (ImmInt 1)) dst)
= pprSizeOp (sLit "inc") size dst
pprInstr (ADD size src dst)
= pprSizeOpOp (sLit "add") size src dst
pprInstr (ADC size src dst)
= pprSizeOpOp (sLit "adc") size src dst
pprInstr (SUB size src dst) = pprSizeOpOp (sLit "sub") size src dst
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 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 (NEGI size op) = pprSizeOp (sLit "neg") size op
pprInstr (SHL size src dst) = pprShift (sLit "shl") size src dst
pprInstr (SAR size src dst) = pprShift (sLit "sar") size src dst
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)
| is_float size = pprSizeOpOp (sLit "ucomi") size src dst
| otherwise = pprSizeOpOp (sLit "cmp") size src dst
where
is_float FF32 = True
is_float FF64 = True
is_float FF80 = True
is_float _ = False
pprInstr (TEST size src dst) = pprSizeOpOp (sLit "test") size src dst
pprInstr (PUSH size op) = pprSizeOp (sLit "push") size op
pprInstr (POP size op) = pprSizeOp (sLit "pop") size op
pprInstr NOP = ptext (sLit "\tnop")
pprInstr (CLTD II32) = ptext (sLit "\tcltd")
pprInstr (CLTD II64) = ptext (sLit "\tcqto")
pprInstr (SETCC cond op) = pprCondInstr (sLit "set") cond (pprOperand II8 op)
pprInstr (JXX cond (BlockId id))
= pprCondInstr (sLit "j") cond (pprCLabel_asm lab)
where lab = mkAsmTempLabel 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 archWordSize op)
pprInstr (JMP_TBL op _) = pprInstr (JMP op)
pprInstr (CALL (Left imm) _) = (<>) (ptext (sLit "\tcall ")) (pprImm imm)
pprInstr (CALL (Right reg) _) = (<>) (ptext (sLit "\tcall *")) (pprReg archWordSize reg)
pprInstr (IDIV sz op) = pprSizeOp (sLit "idiv") sz op
pprInstr (DIV sz op) = pprSizeOp (sLit "div") sz op
pprInstr (IMUL2 sz op) = pprSizeOp (sLit "imul") sz op
pprInstr (MUL size op1 op2) = pprSizeOpOp (sLit "mul") size op1 op2
pprInstr (FDIV size op1 op2) = pprSizeOpOp (sLit "div") size op1 op2
pprInstr (CVTSS2SD from to) = pprRegReg (sLit "cvtss2sd") from to
pprInstr (CVTSD2SS from to) = pprRegReg (sLit "cvtsd2ss") from to
pprInstr (CVTTSS2SIQ sz from to) = pprSizeOpReg (sLit "cvttss2si") sz from to
pprInstr (CVTTSD2SIQ sz from to) = pprSizeOpReg (sLit "cvttsd2si") sz from to
pprInstr (CVTSI2SS sz from to) = pprSizeOpReg (sLit "cvtsi2ss") sz from to
pprInstr (CVTSI2SD sz from to) = pprSizeOpReg (sLit "cvtsi2sd") sz from to
pprInstr (FETCHGOT reg)
= vcat [ ptext (sLit "\tcall 1f"),
hcat [ ptext (sLit "1:\tpopl\t"), pprReg II32 reg ],
hcat [ ptext (sLit "\taddl\t$_GLOBAL_OFFSET_TABLE_+(.-1b), "),
pprReg II32 reg ]
]
pprInstr (FETCHPC reg)
= vcat [ ptext (sLit "\tcall 1f"),
hcat [ ptext (sLit "1:\tpopl\t"), pprReg II32 reg ]
]
pprInstr g@(GMOV src dst)
| src == dst
= empty
| otherwise
= pprG g (hcat [gtab, gpush src 0, gsemi, gpop dst 1])
pprInstr g@(GLD sz addr dst)
= pprG g (hcat [gtab, text "fld", pprSize_x87 sz, gsp,
pprAddr addr, gsemi, gpop dst 1])
pprInstr g@(GST sz src addr)
| src == fake0 && sz /= FF80
= pprG g (hcat [gtab,
text "fst", pprSize_x87 sz, gsp, pprAddr addr])
| otherwise
= pprG g (hcat [gtab, gpush src 0, gsemi,
text "fstp", pprSize_x87 sz, gsp, pprAddr addr])
pprInstr g@(GLDZ dst)
= pprG g (hcat [gtab, text "fldz ; ", gpop dst 1])
pprInstr g@(GLD1 dst)
= pprG g (hcat [gtab, text "fld1 ; ", gpop dst 1])
pprInstr (GFTOI src dst)
= pprInstr (GDTOI src dst)
pprInstr g@(GDTOI src dst)
= pprG g (vcat [
hcat [gtab, text "subl $8, %esp ; fnstcw 4(%esp)"],
hcat [gtab, gpush src 0],
hcat [gtab, text "movzwl 4(%esp), ", reg,
text " ; orl $0xC00, ", reg],
hcat [gtab, text "movl ", reg, text ", 0(%esp) ; fldcw 0(%esp)"],
hcat [gtab, text "fistpl 0(%esp)"],
hcat [gtab, text "fldcw 4(%esp) ; movl 0(%esp), ", reg],
hcat [gtab, text "addl $8, %esp"]
])
where
reg = pprReg II32 dst
pprInstr (GITOF src dst)
= pprInstr (GITOD src dst)
pprInstr g@(GITOD src dst)
= pprG g (hcat [gtab, text "pushl ", pprReg II32 src,
text " ; fildl (%esp) ; ",
gpop dst 1, text " ; addl $4,%esp"])
pprInstr g@(GCMP cond src1 src2)
| case cond of { NE -> True; _ -> 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
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
fix_FP_cond _ = panic "X86.Ppr.fix_FP_cond: no match"
pprInstr g@(GABS _ src dst)
= pprG g (hcat [gtab, gpush src 0, text " ; fabs ; ", gpop dst 1])
pprInstr g@(GNEG _ src dst)
= pprG g (hcat [gtab, gpush src 0, text " ; fchs ; ", gpop dst 1])
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 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)
pprInstr g@(GADD _ src1 src2 dst)
| src1 == dst
= pprG g (text "\t#GADD-xxxcase1" $$
hcat [gtab, gpush src2 0,
text " ; faddp %st(0),", greg src1 1])
| src2 == dst
= pprG g (text "\t#GADD-xxxcase2" $$
hcat [gtab, gpush src1 0,
text " ; faddp %st(0),", greg src2 1])
| otherwise
= pprG g (hcat [gtab, gpush src1 0,
text " ; fadd ", greg src2 1, text ",%st(0)",
gsemi, gpop dst 1])
pprInstr g@(GMUL _ src1 src2 dst)
| src1 == dst
= pprG g (text "\t#GMUL-xxxcase1" $$
hcat [gtab, gpush src2 0,
text " ; fmulp %st(0),", greg src1 1])
| src2 == dst
= pprG g (text "\t#GMUL-xxxcase2" $$
hcat [gtab, gpush src1 0,
text " ; fmulp %st(0),", greg src2 1])
| otherwise
= pprG g (hcat [gtab, gpush src1 0,
text " ; fmul ", greg src2 1, text ",%st(0)",
gsemi, gpop dst 1])
pprInstr g@(GSUB _ src1 src2 dst)
| src1 == dst
= pprG g (text "\t#GSUB-xxxcase1" $$
hcat [gtab, gpush src2 0,
text " ; fsubrp %st(0),", greg src1 1])
| src2 == dst
= pprG g (text "\t#GSUB-xxxcase2" $$
hcat [gtab, gpush src1 0,
text " ; fsubp %st(0),", greg src2 1])
| otherwise
= pprG g (hcat [gtab, gpush src1 0,
text " ; fsub ", greg src2 1, text ",%st(0)",
gsemi, gpop dst 1])
pprInstr g@(GDIV _ src1 src2 dst)
| src1 == dst
= pprG g (text "\t#GDIV-xxxcase1" $$
hcat [gtab, gpush src2 0,
text " ; fdivrp %st(0),", greg src1 1])
| src2 == dst
= pprG g (text "\t#GDIV-xxxcase2" $$
hcat [gtab, gpush src1 0,
text " ; fdivp %st(0),", greg src2 1])
| otherwise
= pprG g (hcat [gtab, gpush src1 0,
text " ; fdiv ", greg src2 1, text ",%st(0)",
gsemi, gpop dst 1])
pprInstr GFREE
= vcat [ ptext (sLit "\tffree %st(0) ;ffree %st(1) ;ffree %st(2) ;ffree %st(3)"),
ptext (sLit "\tffree %st(4) ;ffree %st(5)")
]
pprInstr _
= panic "X86.Ppr.pprInstr: no match"
pprTrigOp :: String -> Bool -> CLabel -> CLabel -> Reg -> Reg -> Size -> Doc
pprTrigOp op
isTan
l1 l2
src dst sz
=
hcat [gtab, text "pushl %eax;"] $$
(if isTan then hcat [gtab, text "ffree %st(6)"] else empty) $$
hcat [gpush src 0, text ("; " ++ op)] $$
hcat [gtab, text "fnstsw %ax"] $$
hcat [gtab, text "test $0x400,%eax"] $$
hcat [gtab, text "je " <> pprCLabel_asm l1] $$
hcat [gtab, text "ffree %st(7); fldpi"] $$
hcat [gtab, text "fadd %st(0),%st"] $$
hcat [gtab, text "fxch %st(1)"] $$
(pprCLabel_asm l2 <> char ':') $$
hcat [gtab, text "fprem1"] $$
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 ':') $$
(if isTan then hcat [gtab, text "fstp %st(0)"] else empty) $$
hcat [gtab, text "popl %eax;"] $$
hcat [gtab, gcoerceto sz, gpop dst 1]
gcoerceto :: Size -> Doc
gcoerceto FF64 = empty
gcoerceto FF32 = empty
gcoerceto _ = panic "X86.Ppr.gcoerceto: no match"
gpush :: Reg -> RegNo -> Doc
gpush reg offset
= hcat [text "fld ", greg reg offset]
gpop :: Reg -> RegNo -> Doc
gpop reg offset
= hcat [text "fstp ", greg reg offset]
greg :: Reg -> RegNo -> Doc
greg reg offset = text "%st(" <> int (gregno reg firstfake+offset) <> char ')'
gsemi :: Doc
gsemi = text " ; "
gtab :: Doc
gtab = char '\t'
gsp :: Doc
gsp = char ' '
gregno :: Reg -> RegNo
gregno (RegReal (RealRegSingle i)) = i
gregno _ =
999
pprG :: Instr -> Doc -> Doc
pprG fake actual
= (char '#' <> pprGInstr fake) $$ actual
pprGInstr :: Instr -> Doc
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") FF64 dst
pprGInstr (GLD1 dst) = pprSizeReg (sLit "gld1") FF64 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") II32 FF32 src dst
pprGInstr (GITOD src dst) = pprSizeSizeRegReg (sLit "gitod") II32 FF64 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 (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
pprGInstr (GMUL sz src1 src2 dst) = pprSizeRegRegReg (sLit "gmul") sz src1 src2 dst
pprGInstr (GDIV sz src1 src2 dst) = pprSizeRegRegReg (sLit "gdiv") sz src1 src2 dst
pprGInstr _ = panic "X86.Ppr.pprGInstr: no match"
pprDollImm :: Imm -> Doc
pprDollImm i = ptext (sLit "$") <> pprImm i
pprOperand :: Size -> Operand -> Doc
pprOperand s (OpReg r) = pprReg s r
pprOperand _ (OpImm i) = pprDollImm i
pprOperand _ (OpAddr ea) = pprAddr ea
pprMnemonic_ :: LitString -> Doc
pprMnemonic_ name =
char '\t' <> ptext name <> space
pprMnemonic :: LitString -> Size -> Doc
pprMnemonic name size =
char '\t' <> ptext name <> pprSize size <> space
pprSizeImmOp :: LitString -> Size -> Imm -> Operand -> Doc
pprSizeImmOp name size imm op1
= hcat [
pprMnemonic name size,
char '$',
pprImm imm,
comma,
pprOperand size op1
]
pprSizeOp :: LitString -> Size -> Operand -> Doc
pprSizeOp name size op1
= hcat [
pprMnemonic name size,
pprOperand size op1
]
pprSizeOpOp :: LitString -> Size -> Operand -> Operand -> Doc
pprSizeOpOp name size op1 op2
= hcat [
pprMnemonic name size,
pprOperand size op1,
comma,
pprOperand size op2
]
pprOpOp :: LitString -> Size -> Operand -> Operand -> Doc
pprOpOp name size op1 op2
= hcat [
pprMnemonic_ name,
pprOperand size op1,
comma,
pprOperand size op2
]
pprSizeReg :: LitString -> Size -> Reg -> Doc
pprSizeReg name size reg1
= hcat [
pprMnemonic name size,
pprReg size reg1
]
pprSizeRegReg :: LitString -> Size -> Reg -> Reg -> Doc
pprSizeRegReg name size reg1 reg2
= hcat [
pprMnemonic name size,
pprReg size reg1,
comma,
pprReg size reg2
]
pprRegReg :: LitString -> Reg -> Reg -> Doc
pprRegReg name reg1 reg2
= hcat [
pprMnemonic_ name,
pprReg archWordSize reg1,
comma,
pprReg archWordSize reg2
]
pprSizeOpReg :: LitString -> Size -> Operand -> Reg -> Doc
pprSizeOpReg name size op1 reg2
= hcat [
pprMnemonic name size,
pprOperand size op1,
comma,
pprReg archWordSize reg2
]
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',
ptext name,
pprSize size1,
pprSize size2,
space,
pprReg size1 reg1,
comma,
pprReg size2 reg2
]
pprSizeRegRegReg :: LitString -> Size -> Reg -> Reg -> Reg -> Doc
pprSizeRegRegReg name size reg1 reg2 reg3
= hcat [
pprMnemonic name size,
pprReg size reg1,
comma,
pprReg size reg2,
comma,
pprReg size reg3
]
pprSizeAddrReg :: LitString -> Size -> AddrMode -> Reg -> Doc
pprSizeAddrReg name size op dst
= hcat [
pprMnemonic name size,
pprAddr op,
comma,
pprReg size dst
]
pprSizeRegAddr :: LitString -> Size -> Reg -> AddrMode -> Doc
pprSizeRegAddr name size src op
= hcat [
pprMnemonic name size,
pprReg size src,
comma,
pprAddr op
]
pprShift :: LitString -> Size -> Operand -> Operand -> Doc
pprShift name size src dest
= hcat [
pprMnemonic name size,
pprOperand II8 src,
comma,
pprOperand size dest
]
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,
comma,
pprOperand size2 op2
]
pprCondInstr :: LitString -> Cond -> Doc -> Doc
pprCondInstr name cond arg
= hcat [ char '\t', ptext name, pprCond cond, space, arg]