module PprMach (
pprNatCmmTop, pprBasicBlock, pprSectionHeader, pprData,
- pprInstr, pprSize, pprUserReg
+ pprInstr, pprSize, pprUserReg, pprImm
) where
#include "HsVersions.h"
import BlockId
import Cmm
-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 )
-- -----------------------------------------------------------------------------
--- 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 :: Size -> Doc
FF64 -> sLit "sd" -- "scalar double-precision float" (SSE2)
#endif
#if sparc_TARGET_ARCH
- II8 -> sLit "sb"
- II16 -> sLit "sh"
+ II8 -> sLit "ub"
+ II16 -> sLit "uh"
II32 -> sLit ""
+ II64 -> sLit "d"
FF32 -> sLit ""
FF64 -> sLit "d"
)
+
+-- suffix to store/ ST instruction
pprStSize :: Size -> Doc
pprStSize x = ptext (case x of
II8 -> sLit "b"
II16 -> sLit "h"
II32 -> sLit ""
+ II64 -> sLit "x"
FF32 -> sLit ""
FF64 -> sLit "d"
#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)
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
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)))
-- sub g1,g2,g1 -- to restore g1
pprInstr (LD FF64 (AddrRegReg g1 g2) reg)
- = vcat [
+ = 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 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)]
- ]
- 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 %f(n+1),[g1+4]
-- sub g1,g2,g1 -- to restore g1
pprInstr (ST FF64 reg (AddrRegReg g1 g2))
- = vcat [
+ = 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 FF64 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 (FABS FF32 reg1 reg2) = pprSizeRegReg (sLit "fabs") FF32 reg1 reg2
pprInstr (FABS FF64 reg1 reg2)
- = (<>) (pprSizeRegReg (sLit "fabs") FF32 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") FF32 (fPair reg1) (fPair reg2)))
+ (pprSizeRegReg (sLit "fmov") FF32 reg1H reg2H))
pprInstr (FADD size reg1 reg2 reg3)
= pprSizeRegRegReg (sLit "fadd") size reg1 reg2 reg3
= pprSizeRegRegReg (sLit "fdiv") size reg1 reg2 reg3
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)
- = (<>) (pprSizeRegReg (sLit "fmov") FF32 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") FF32 (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 FF32 reg1 reg2) = pprSizeRegReg (sLit "fneg") FF32 reg1 reg2
pprInstr (FNEG FF64 reg1 reg2)
- = (<>) (pprSizeRegReg (sLit "fneg") FF32 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") FF32 (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
(case size2 of
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 ]
projects / ghc-hetmet.git / blobdiff