X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FnativeGen%2FPprMach.hs;h=822dc0de0337213ca125bff5e2fc393488618d5a;hb=bca11b6352ea379329a645df1d706e2b28378629;hp=24ba78fd5e8634ac84e295aa2be89182bd1e6b00;hpb=8480018a7f5f1cd961f3bd8ae758cc01910d5e6a;p=ghc-hetmet.git diff --git a/compiler/nativeGen/PprMach.hs b/compiler/nativeGen/PprMach.hs index 24ba78f..822dc0d 100644 --- a/compiler/nativeGen/PprMach.hs +++ b/compiler/nativeGen/PprMach.hs @@ -42,7 +42,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 ) @@ -482,14 +482,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 +640,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 +651,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", @@ -1886,25 +1886,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 +1925,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 +1938,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 +1966,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 +1984,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 @@ -2016,10 +2018,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 +2034,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 @@ -2064,20 +2079,20 @@ pprInstr (FxTOy size1 size2 reg1 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)