module SPARC.Ppr (
pprNatCmmDecl,
pprBasicBlock,
pprSectionHeader,
pprData,
pprInstr,
pprSize,
pprImm,
pprDataItem
)
where
#include "HsVersions.h"
#include "nativeGen/NCG.h"
import SPARC.Regs
import SPARC.Instr
import SPARC.Cond
import SPARC.Imm
import SPARC.AddrMode
import SPARC.Base
import Instruction
import Reg
import Size
import PprBase
import OldCmm
import OldPprCmm()
import CLabel
import Unique ( Uniquable(..), pprUnique )
import Outputable
import Platform
import FastString
import Data.Word
pprNatCmmDecl :: Platform -> NatCmmDecl CmmStatics Instr -> SDoc
pprNatCmmDecl platform (CmmData section dats) =
pprSectionHeader section $$ pprDatas platform dats
pprNatCmmDecl platform (CmmProc Nothing lbl (ListGraph [])) = pprLabel platform lbl
pprNatCmmDecl platform (CmmProc Nothing lbl (ListGraph blocks)) =
pprSectionHeader Text $$
pprLabel platform lbl $$
vcat (map (pprBasicBlock platform) blocks)
pprNatCmmDecl platform (CmmProc (Just (Statics info_lbl info)) _entry_lbl (ListGraph blocks)) =
pprSectionHeader Text $$
(
(if platformHasSubsectionsViaSymbols platform
then pprCLabel platform (mkDeadStripPreventer info_lbl) <> char ':'
else empty) $$
vcat (map (pprData platform) info) $$
pprLabel platform info_lbl
) $$
vcat (map (pprBasicBlock platform) blocks) $$
(if platformHasSubsectionsViaSymbols platform
then
text "\t.long "
<+> pprCLabel platform info_lbl
<+> char '-'
<+> pprCLabel platform (mkDeadStripPreventer info_lbl)
else empty)
pprBasicBlock :: Platform -> NatBasicBlock Instr -> SDoc
pprBasicBlock platform (BasicBlock blockid instrs) =
pprLabel platform (mkAsmTempLabel (getUnique blockid)) $$
vcat (map (pprInstr platform) instrs)
pprDatas :: Platform -> CmmStatics -> SDoc
pprDatas platform (Statics lbl dats) = vcat (pprLabel platform lbl : map (pprData platform) dats)
pprData :: Platform -> CmmStatic -> SDoc
pprData _ (CmmString str) = pprASCII str
pprData _ (CmmUninitialised bytes) = ptext (sLit ".skip ") <> int bytes
pprData platform (CmmStaticLit lit) = pprDataItem platform lit
pprGloblDecl :: Platform -> CLabel -> SDoc
pprGloblDecl platform lbl
| not (externallyVisibleCLabel lbl) = empty
| otherwise = ptext (sLit ".global ") <> pprCLabel platform lbl
pprTypeAndSizeDecl :: Platform -> CLabel -> SDoc
pprTypeAndSizeDecl platform lbl
| platformOS platform == OSLinux && externallyVisibleCLabel lbl
= ptext (sLit ".type ") <>
pprCLabel platform lbl <> ptext (sLit ", @object")
| otherwise = empty
pprLabel :: Platform -> CLabel -> SDoc
pprLabel platform lbl = pprGloblDecl platform lbl
$$ pprTypeAndSizeDecl platform lbl
$$ (pprCLabel platform lbl <> char ':')
pprASCII :: [Word8] -> SDoc
pprASCII str
= vcat (map do1 str) $$ do1 0
where
do1 :: Word8 -> SDoc
do1 w = ptext (sLit "\t.byte\t") <> int (fromIntegral w)
instance Outputable Instr where
ppr instr = sdocWithPlatform $ \platform -> pprInstr platform instr
pprReg :: Reg -> SDoc
pprReg reg
= case reg of
RegVirtual vr
-> case vr of
VirtualRegI u -> text "%vI_" <> pprUnique u
VirtualRegHi u -> text "%vHi_" <> pprUnique u
VirtualRegF u -> text "%vF_" <> pprUnique u
VirtualRegD u -> text "%vD_" <> pprUnique u
VirtualRegSSE u -> text "%vSSE_" <> pprUnique u
RegReal rr
-> case rr of
RealRegSingle r1
-> pprReg_ofRegNo r1
RealRegPair r1 r2
-> text "(" <> pprReg_ofRegNo r1
<> text "|" <> pprReg_ofRegNo r2
<> text ")"
pprReg_ofRegNo :: Int -> SDoc
pprReg_ofRegNo i
= ptext
(case i of {
0 -> sLit "%g0"; 1 -> sLit "%g1";
2 -> sLit "%g2"; 3 -> sLit "%g3";
4 -> sLit "%g4"; 5 -> sLit "%g5";
6 -> sLit "%g6"; 7 -> sLit "%g7";
8 -> sLit "%o0"; 9 -> sLit "%o1";
10 -> sLit "%o2"; 11 -> sLit "%o3";
12 -> sLit "%o4"; 13 -> sLit "%o5";
14 -> sLit "%o6"; 15 -> sLit "%o7";
16 -> sLit "%l0"; 17 -> sLit "%l1";
18 -> sLit "%l2"; 19 -> sLit "%l3";
20 -> sLit "%l4"; 21 -> sLit "%l5";
22 -> sLit "%l6"; 23 -> sLit "%l7";
24 -> sLit "%i0"; 25 -> sLit "%i1";
26 -> sLit "%i2"; 27 -> sLit "%i3";
28 -> sLit "%i4"; 29 -> sLit "%i5";
30 -> sLit "%i6"; 31 -> sLit "%i7";
32 -> sLit "%f0"; 33 -> sLit "%f1";
34 -> sLit "%f2"; 35 -> sLit "%f3";
36 -> sLit "%f4"; 37 -> sLit "%f5";
38 -> sLit "%f6"; 39 -> sLit "%f7";
40 -> sLit "%f8"; 41 -> sLit "%f9";
42 -> sLit "%f10"; 43 -> sLit "%f11";
44 -> sLit "%f12"; 45 -> sLit "%f13";
46 -> sLit "%f14"; 47 -> sLit "%f15";
48 -> sLit "%f16"; 49 -> sLit "%f17";
50 -> sLit "%f18"; 51 -> sLit "%f19";
52 -> sLit "%f20"; 53 -> sLit "%f21";
54 -> sLit "%f22"; 55 -> sLit "%f23";
56 -> sLit "%f24"; 57 -> sLit "%f25";
58 -> sLit "%f26"; 59 -> sLit "%f27";
60 -> sLit "%f28"; 61 -> sLit "%f29";
62 -> sLit "%f30"; 63 -> sLit "%f31";
_ -> sLit "very naughty sparc register" })
pprSize :: Size -> SDoc
pprSize x
= ptext
(case x of
II8 -> sLit "ub"
II16 -> sLit "uh"
II32 -> sLit ""
II64 -> sLit "d"
FF32 -> sLit ""
FF64 -> sLit "d"
_ -> panic "SPARC.Ppr.pprSize: no match")
pprStSize :: Size -> SDoc
pprStSize x
= ptext
(case x of
II8 -> sLit "b"
II16 -> sLit "h"
II32 -> sLit ""
II64 -> sLit "x"
FF32 -> sLit ""
FF64 -> sLit "d"
_ -> panic "SPARC.Ppr.pprSize: no match")
pprCond :: Cond -> SDoc
pprCond c
= ptext
(case c of
ALWAYS -> sLit ""
NEVER -> sLit "n"
GEU -> sLit "geu"
LU -> sLit "lu"
EQQ -> sLit "e"
GTT -> sLit "g"
GE -> sLit "ge"
GU -> sLit "gu"
LTT -> sLit "l"
LE -> sLit "le"
LEU -> sLit "leu"
NE -> sLit "ne"
NEG -> sLit "neg"
POS -> sLit "pos"
VC -> sLit "vc"
VS -> sLit "vs")
pprAddr :: Platform -> AddrMode -> SDoc
pprAddr platform am
= case am of
AddrRegReg r1 (RegReal (RealRegSingle 0))
-> pprReg r1
AddrRegReg r1 r2
-> hcat [ pprReg r1, char '+', pprReg r2 ]
AddrRegImm r1 (ImmInt i)
| i == 0 -> pprReg r1
| not (fits13Bits i) -> largeOffsetError i
| otherwise -> hcat [ pprReg r1, pp_sign, int i ]
where
pp_sign = if i > 0 then char '+' else empty
AddrRegImm r1 (ImmInteger i)
| i == 0 -> pprReg r1
| not (fits13Bits i) -> largeOffsetError i
| otherwise -> hcat [ pprReg r1, pp_sign, integer i ]
where
pp_sign = if i > 0 then char '+' else empty
AddrRegImm r1 imm
-> hcat [ pprReg r1, char '+', pprImm platform imm ]
pprImm :: Platform -> Imm -> SDoc
pprImm platform imm
= case imm of
ImmInt i -> int i
ImmInteger i -> integer i
ImmCLbl l -> pprCLabel platform l
ImmIndex l i -> pprCLabel platform l <> char '+' <> int i
ImmLit s -> s
ImmConstantSum a b
-> pprImm platform a <> char '+' <> pprImm platform b
ImmConstantDiff a b
-> pprImm platform a <> char '-' <> lparen <> pprImm platform b <> rparen
LO i
-> hcat [ text "%lo(", pprImm platform i, rparen ]
HI i
-> hcat [ text "%hi(", pprImm platform i, rparen ]
ImmFloat _ -> ptext (sLit "naughty float immediate")
ImmDouble _ -> ptext (sLit "naughty double immediate")
pprSectionHeader :: Section -> SDoc
pprSectionHeader seg
= case seg of
Text -> ptext (sLit ".text\n\t.align 4")
Data -> ptext (sLit ".data\n\t.align 8")
ReadOnlyData -> ptext (sLit ".text\n\t.align 8")
RelocatableReadOnlyData -> ptext (sLit ".text\n\t.align 8")
UninitialisedData -> ptext (sLit ".bss\n\t.align 8")
ReadOnlyData16 -> ptext (sLit ".data\n\t.align 16")
OtherSection _ -> panic "PprMach.pprSectionHeader: unknown section"
pprDataItem :: Platform -> CmmLit -> SDoc
pprDataItem platform lit
= vcat (ppr_item (cmmTypeSize $ cmmLitType lit) lit)
where
imm = litToImm lit
ppr_item II8 _ = [ptext (sLit "\t.byte\t") <> pprImm platform imm]
ppr_item II32 _ = [ptext (sLit "\t.long\t") <> pprImm platform imm]
ppr_item FF32 (CmmFloat r _)
= let bs = floatToBytes (fromRational r)
in map (\b -> ptext (sLit "\t.byte\t") <> pprImm platform (ImmInt b)) bs
ppr_item FF64 (CmmFloat r _)
= let bs = doubleToBytes (fromRational r)
in map (\b -> ptext (sLit "\t.byte\t") <> pprImm platform (ImmInt b)) bs
ppr_item II16 _ = [ptext (sLit "\t.short\t") <> pprImm platform imm]
ppr_item II64 _ = [ptext (sLit "\t.quad\t") <> pprImm platform imm]
ppr_item _ _ = panic "SPARC.Ppr.pprDataItem: no match"
pprInstr :: Platform -> Instr -> SDoc
pprInstr _ (COMMENT _)
= empty
pprInstr platform (DELTA d)
= pprInstr platform (COMMENT (mkFastString ("\tdelta = " ++ show d)))
pprInstr _ (NEWBLOCK _)
= panic "X86.Ppr.pprInstr: NEWBLOCK"
pprInstr _ (LDATA _ _)
= panic "PprMach.pprInstr: LDATA"
pprInstr _ (LD FF64 _ reg)
| RegReal (RealRegSingle{}) <- reg
= panic "SPARC.Ppr: not emitting potentially misaligned LD FF64 instr"
pprInstr platform (LD size addr reg)
= hcat [
ptext (sLit "\tld"),
pprSize size,
char '\t',
lbrack,
pprAddr platform addr,
pp_rbracket_comma,
pprReg reg
]
pprInstr _ (ST FF64 reg _)
| RegReal (RealRegSingle{}) <- reg
= panic "SPARC.Ppr: not emitting potentially misaligned ST FF64 instr"
pprInstr platform (ST size reg addr)
= hcat [
ptext (sLit "\tst"),
pprStSize size,
char '\t',
pprReg reg,
pp_comma_lbracket,
pprAddr platform addr,
rbrack
]
pprInstr platform (ADD x cc reg1 ri reg2)
| not x && not cc && riZero ri
= hcat [ ptext (sLit "\tmov\t"), pprReg reg1, comma, pprReg reg2 ]
| otherwise
= pprRegRIReg platform (if x then sLit "addx" else sLit "add") cc reg1 ri reg2
pprInstr platform (SUB x cc reg1 ri reg2)
| not x && cc && reg2 == g0
= hcat [ ptext (sLit "\tcmp\t"), pprReg reg1, comma, pprRI platform ri ]
| not x && not cc && riZero ri
= hcat [ ptext (sLit "\tmov\t"), pprReg reg1, comma, pprReg reg2 ]
| otherwise
= pprRegRIReg platform (if x then sLit "subx" else sLit "sub") cc reg1 ri reg2
pprInstr platform (AND b reg1 ri reg2) = pprRegRIReg platform (sLit "and") b reg1 ri reg2
pprInstr platform (ANDN b reg1 ri reg2) = pprRegRIReg platform (sLit "andn") b reg1 ri reg2
pprInstr platform (OR b reg1 ri reg2)
| not b && reg1 == g0
= let doit = hcat [ ptext (sLit "\tmov\t"), pprRI platform ri, comma, pprReg reg2 ]
in case ri of
RIReg rrr | rrr == reg2 -> empty
_ -> doit
| otherwise
= pprRegRIReg platform (sLit "or") b reg1 ri reg2
pprInstr platform (ORN b reg1 ri reg2) = pprRegRIReg platform (sLit "orn") b reg1 ri reg2
pprInstr platform (XOR b reg1 ri reg2) = pprRegRIReg platform (sLit "xor") b reg1 ri reg2
pprInstr platform (XNOR b reg1 ri reg2) = pprRegRIReg platform (sLit "xnor") b reg1 ri reg2
pprInstr platform (SLL reg1 ri reg2) = pprRegRIReg platform (sLit "sll") False reg1 ri reg2
pprInstr platform (SRL reg1 ri reg2) = pprRegRIReg platform (sLit "srl") False reg1 ri reg2
pprInstr platform (SRA reg1 ri reg2) = pprRegRIReg platform (sLit "sra") False 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 platform (SMUL b reg1 ri reg2) = pprRegRIReg platform (sLit "smul") b reg1 ri reg2
pprInstr platform (UMUL b reg1 ri reg2) = pprRegRIReg platform (sLit "umul") b reg1 ri reg2
pprInstr platform (SDIV b reg1 ri reg2) = pprRegRIReg platform (sLit "sdiv") b reg1 ri reg2
pprInstr platform (UDIV b reg1 ri reg2) = pprRegRIReg platform (sLit "udiv") b reg1 ri reg2
pprInstr platform (SETHI imm reg)
= hcat [
ptext (sLit "\tsethi\t"),
pprImm platform imm,
comma,
pprReg reg
]
pprInstr _ NOP
= ptext (sLit "\tnop")
pprInstr _ (FABS size reg1 reg2)
= pprSizeRegReg (sLit "fabs") size reg1 reg2
pprInstr _ (FADD size reg1 reg2 reg3)
= pprSizeRegRegReg (sLit "fadd") size reg1 reg2 reg3
pprInstr _ (FCMP e size reg1 reg2)
= pprSizeRegReg (if e then sLit "fcmpe" else sLit "fcmp") size reg1 reg2
pprInstr _ (FDIV size reg1 reg2 reg3)
= pprSizeRegRegReg (sLit "fdiv") size reg1 reg2 reg3
pprInstr _ (FMOV size reg1 reg2)
= pprSizeRegReg (sLit "fmov") size reg1 reg2
pprInstr _ (FMUL size reg1 reg2 reg3)
= pprSizeRegRegReg (sLit "fmul") size reg1 reg2 reg3
pprInstr _ (FNEG size reg1 reg2)
= pprSizeRegReg (sLit "fneg") size reg1 reg2
pprInstr _ (FSQRT size reg1 reg2)
= pprSizeRegReg (sLit "fsqrt") size reg1 reg2
pprInstr _ (FSUB size reg1 reg2 reg3)
= pprSizeRegRegReg (sLit "fsub") size reg1 reg2 reg3
pprInstr _ (FxTOy size1 size2 reg1 reg2)
= hcat [
ptext (sLit "\tf"),
ptext
(case size1 of
II32 -> sLit "ito"
FF32 -> sLit "sto"
FF64 -> sLit "dto"
_ -> panic "SPARC.Ppr.pprInstr.FxToY: no match"),
ptext
(case size2 of
II32 -> sLit "i\t"
II64 -> sLit "x\t"
FF32 -> sLit "s\t"
FF64 -> sLit "d\t"
_ -> panic "SPARC.Ppr.pprInstr.FxToY: no match"),
pprReg reg1, comma, pprReg reg2
]
pprInstr platform (BI cond b blockid)
= hcat [
ptext (sLit "\tb"), pprCond cond,
if b then pp_comma_a else empty,
char '\t',
pprCLabel platform (mkAsmTempLabel (getUnique blockid))
]
pprInstr platform (BF cond b blockid)
= hcat [
ptext (sLit "\tfb"), pprCond cond,
if b then pp_comma_a else empty,
char '\t',
pprCLabel platform (mkAsmTempLabel (getUnique blockid))
]
pprInstr platform (JMP addr) = (<>) (ptext (sLit "\tjmp\t")) (pprAddr platform addr)
pprInstr platform (JMP_TBL op _ _) = pprInstr platform (JMP op)
pprInstr platform (CALL (Left imm) n _)
= hcat [ ptext (sLit "\tcall\t"), pprImm platform imm, comma, int n ]
pprInstr _ (CALL (Right reg) n _)
= hcat [ ptext (sLit "\tcall\t"), pprReg reg, comma, int n ]
pprRI :: Platform -> RI -> SDoc
pprRI _ (RIReg r) = pprReg r
pprRI platform (RIImm r) = pprImm platform r
pprSizeRegReg :: LitString -> Size -> Reg -> Reg -> SDoc
pprSizeRegReg name size reg1 reg2
= hcat [
char '\t',
ptext name,
(case size of
FF32 -> ptext (sLit "s\t")
FF64 -> ptext (sLit "d\t")
_ -> panic "SPARC.Ppr.pprSizeRegReg: no match"),
pprReg reg1,
comma,
pprReg reg2
]
pprSizeRegRegReg :: LitString -> Size -> Reg -> Reg -> Reg -> SDoc
pprSizeRegRegReg name size reg1 reg2 reg3
= hcat [
char '\t',
ptext name,
(case size of
FF32 -> ptext (sLit "s\t")
FF64 -> ptext (sLit "d\t")
_ -> panic "SPARC.Ppr.pprSizeRegReg: no match"),
pprReg reg1,
comma,
pprReg reg2,
comma,
pprReg reg3
]
pprRegRIReg :: Platform -> LitString -> Bool -> Reg -> RI -> Reg -> SDoc
pprRegRIReg platform name b reg1 ri reg2
= hcat [
char '\t',
ptext name,
if b then ptext (sLit "cc\t") else char '\t',
pprReg reg1,
comma,
pprRI platform ri,
comma,
pprReg reg2
]
pp_rbracket_comma :: SDoc
pp_rbracket_comma = text "],"
pp_comma_lbracket :: SDoc
pp_comma_lbracket = text ",["
pp_comma_a :: SDoc
pp_comma_a = text ",a"