X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FnativeGen%2FPprMach.hs;h=55e3930786dc161c3b2a253bdde2c011f8a7dfce;hp=2d59cf417f472c9590749a2883e319a5dc085b35;hb=232e72122fa7f08690e3be2bb9f8a7f8024e37d5;hpb=e6243a818496aad82b6f47511d3bd9bc800f747d diff --git a/compiler/nativeGen/PprMach.hs b/compiler/nativeGen/PprMach.hs index 2d59cf4..55e3930 100644 --- a/compiler/nativeGen/PprMach.hs +++ b/compiler/nativeGen/PprMach.hs @@ -21,15 +21,16 @@ 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 ) @@ -42,7 +43,7 @@ import Unique ( pprUnique ) import Pretty import FastString import qualified Outputable -import Outputable ( Outputable ) +import Outputable ( Outputable, pprPanic, ppr, docToSDoc) import Data.Array.ST import Data.Word ( Word8 ) @@ -354,7 +355,10 @@ pprReg IF_ARCH_i386(s,) IF_ARCH_x86_64(s,) r -- ----------------------------------------------------------------------------- --- 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 @@ -392,17 +396,21 @@ pprSize x = ptext (case x of 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 @@ -478,14 +486,14 @@ 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) @@ -636,7 +644,7 @@ pprSectionHeader Data 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", @@ -647,7 +655,7 @@ pprSectionHeader ReadOnlyData 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", @@ -685,7 +693,7 @@ pprData :: CmmStatic -> Doc 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 @@ -806,17 +814,18 @@ instance Outputable Instr where 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))) @@ -1881,25 +1890,25 @@ pprInstr (RELOAD slot reg) -- 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 [ @@ -1920,11 +1929,12 @@ pprInstr (LD size addr reg) -- 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] ] @@ -1932,16 +1942,17 @@ pprInstr (ST FF64 reg (AddrRegReg g1 g2)) -- 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), @@ -1961,6 +1972,7 @@ pprInstr (ST size reg addr) 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 @@ -1981,6 +1993,7 @@ pprInstr (OR b reg1 ri reg2) in case ri of RIReg rrr | rrr == reg2 -> empty other -> doit + | otherwise = pprRegRIReg (sLit "or") b reg1 ri reg2 @@ -1993,9 +2006,19 @@ pprInstr (SLL reg1 ri reg2) = pprRegRIReg (sLit "sll") False reg1 ri reg2 pprInstr (SRL reg1 ri reg2) = pprRegRIReg (sLit "srl") False reg1 ri reg2 pprInstr (SRA reg1 ri reg2) = pprRegRIReg (sLit "sra") False reg1 ri reg2 -pprInstr (RDY rd) = ptext (sLit "\trd\t%y,") <> pprReg rd -pprInstr (SMUL b reg1 ri reg2) = pprRegRIReg (sLit "smul") b reg1 ri reg2 -pprInstr (UMUL b reg1 ri reg2) = pprRegRIReg (sLit "umul") b reg1 ri reg2 +pprInstr (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 [ @@ -2009,10 +2032,13 @@ pprInstr NOP = ptext (sLit "\tnop") 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 @@ -2022,21 +2048,31 @@ pprInstr (FDIV 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 @@ -2051,29 +2087,31 @@ pprInstr (FxTOy size1 size2 reg1 reg2) 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 ]