X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FnativeGen%2FPprMach.hs;h=55e3930786dc161c3b2a253bdde2c011f8a7dfce;hp=24ba78fd5e8634ac84e295aa2be89182bd1e6b00;hb=232e72122fa7f08690e3be2bb9f8a7f8024e37d5;hpb=8480018a7f5f1cd961f3bd8ae758cc01910d5e6a diff --git a/compiler/nativeGen/PprMach.hs b/compiler/nativeGen/PprMach.hs index 24ba78f..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 ) @@ -395,18 +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 @@ -482,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) @@ -640,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", @@ -651,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", @@ -689,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 @@ -1886,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 [ @@ -1925,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] ] @@ -1937,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), @@ -1964,8 +1970,8 @@ 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 ] + | 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 @@ -1982,12 +1988,12 @@ pprInstr (AND b reg1 ri reg2) = pprRegRIReg (sLit "and") b reg1 ri reg2 pprInstr (ANDN b reg1 ri reg2) = pprRegRIReg (sLit "andn") b reg1 ri reg2 pprInstr (OR b reg1 ri reg2) -{- | not b && reg1 == g0 + | not b && reg1 == g0 = let doit = hcat [ ptext (sLit "\tmov\t"), pprRI ri, comma, pprReg reg2 ] in case ri of RIReg rrr | rrr == reg2 -> empty other -> doit --} + | otherwise = pprRegRIReg (sLit "or") b reg1 ri reg2 @@ -2000,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 [ @@ -2016,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 @@ -2029,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 @@ -2058,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 ]