----------------------------------------------------------------------------- -- -- Pretty-printing assembly language -- -- (c) The University of Glasgow 1993-2005 -- ----------------------------------------------------------------------------- {-# OPTIONS -fno-warn-tabs #-} -- The above warning supression flag is a temporary kludge. -- While working on this module you are encouraged to remove it and -- detab the module (please do the detabbing in a separate patch). See -- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces -- for details 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 qualified Outputable import Outputable (PlatformOutputable, panic) import Platform import Pretty import FastString import Data.Word -- ----------------------------------------------------------------------------- -- Printing this stuff out pprNatCmmDecl :: Platform -> NatCmmDecl CmmStatics Instr -> Doc pprNatCmmDecl platform (CmmData section dats) = pprSectionHeader section $$ pprDatas platform dats -- special case for split markers: pprNatCmmDecl platform (CmmProc Nothing lbl (ListGraph [])) = pprLabel platform lbl -- special case for code without info table: pprNatCmmDecl platform (CmmProc Nothing lbl (ListGraph blocks)) = pprSectionHeader Text $$ pprLabel platform lbl $$ -- blocks guaranteed not null, so label needed vcat (map (pprBasicBlock platform) blocks) pprNatCmmDecl platform (CmmProc (Just (Statics info_lbl info)) _entry_lbl (ListGraph blocks)) = pprSectionHeader Text $$ ( (if platformHasSubsectionsViaSymbols platform then pprCLabel_asm platform (mkDeadStripPreventer info_lbl) <> char ':' else empty) $$ vcat (map (pprData platform) info) $$ pprLabel platform info_lbl ) $$ vcat (map (pprBasicBlock platform) blocks) $$ -- above: Even the first block gets a label, because with branch-chain -- elimination, it might be the target of a goto. (if platformHasSubsectionsViaSymbols platform then -- If we are using the .subsections_via_symbols directive -- (available on recent versions of Darwin), -- we have to make sure that there is some kind of reference -- from the entry code to a label on the _top_ of of the info table, -- so that the linker will not think it is unreferenced and dead-strip -- it. That's why the label is called a DeadStripPreventer (_dsp). text "\t.long " <+> pprCLabel_asm platform info_lbl <+> char '-' <+> pprCLabel_asm platform (mkDeadStripPreventer info_lbl) else empty) pprBasicBlock :: Platform -> NatBasicBlock Instr -> Doc pprBasicBlock platform (BasicBlock blockid instrs) = pprLabel platform (mkAsmTempLabel (getUnique blockid)) $$ vcat (map (pprInstr platform) instrs) pprDatas :: Platform -> CmmStatics -> Doc pprDatas platform (Statics lbl dats) = vcat (pprLabel platform lbl : map (pprData platform) dats) pprData :: Platform -> CmmStatic -> Doc pprData _ (CmmString str) = pprASCII str pprData _ (CmmUninitialised bytes) = ptext (sLit ".skip ") <> int bytes pprData platform (CmmStaticLit lit) = pprDataItem platform lit pprGloblDecl :: Platform -> CLabel -> Doc pprGloblDecl platform lbl | not (externallyVisibleCLabel lbl) = empty | otherwise = ptext (sLit ".global ") <> pprCLabel_asm platform lbl pprTypeAndSizeDecl :: Platform -> CLabel -> Doc pprTypeAndSizeDecl platform lbl | platformOS platform == OSLinux && externallyVisibleCLabel lbl = ptext (sLit ".type ") <> pprCLabel_asm platform lbl <> ptext (sLit ", @object") | otherwise = empty pprLabel :: Platform -> CLabel -> Doc pprLabel platform lbl = pprGloblDecl platform lbl $$ pprTypeAndSizeDecl platform lbl $$ (pprCLabel_asm platform lbl <> char ':') pprASCII :: [Word8] -> Doc pprASCII str = vcat (map do1 str) $$ do1 0 where do1 :: Word8 -> Doc do1 w = ptext (sLit "\t.byte\t") <> int (fromIntegral w) -- ----------------------------------------------------------------------------- -- pprInstr: print an 'Instr' instance PlatformOutputable Instr where pprPlatform platform instr = Outputable.docToSDoc $ pprInstr platform instr -- | Pretty print a register. pprReg :: Reg -> Doc pprReg reg = case reg of RegVirtual vr -> case vr of VirtualRegI u -> text "%vI_" <> asmSDoc (pprUnique u) VirtualRegHi u -> text "%vHi_" <> asmSDoc (pprUnique u) VirtualRegF u -> text "%vF_" <> asmSDoc (pprUnique u) VirtualRegD u -> text "%vD_" <> asmSDoc (pprUnique u) VirtualRegSSE u -> text "%vSSE_" <> asmSDoc (pprUnique u) RegReal rr -> case rr of RealRegSingle r1 -> pprReg_ofRegNo r1 RealRegPair r1 r2 -> text "(" <> pprReg_ofRegNo r1 <> text "|" <> pprReg_ofRegNo r2 <> text ")" -- | Pretty print a register name, based on this register number. -- The definition has been unfolded so we get a jump-table in the -- object code. This function is called quite a lot when emitting the asm file.. -- pprReg_ofRegNo :: Int -> Doc 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" }) -- | Pretty print a size for an instruction suffix. pprSize :: Size -> Doc 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") -- | Pretty print a size for an instruction suffix. -- eg LD is 32bit on sparc, but LDD is 64 bit. 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" _ -> panic "SPARC.Ppr.pprSize: no match") -- | Pretty print a condition code. pprCond :: Cond -> Doc 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") -- | Pretty print an address mode. pprAddr :: Platform -> AddrMode -> Doc 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 ] -- | Pretty print an immediate value. pprImm :: Platform -> Imm -> Doc pprImm platform imm = case imm of ImmInt i -> int i ImmInteger i -> integer i ImmCLbl l -> pprCLabel_asm platform l ImmIndex l i -> pprCLabel_asm 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 ] -- these should have been converted to bytes and placed -- in the data section. ImmFloat _ -> ptext (sLit "naughty float immediate") ImmDouble _ -> ptext (sLit "naughty double immediate") -- | Pretty print a section \/ segment header. -- On SPARC all the data sections must be at least 8 byte aligned -- incase we store doubles in them. -- pprSectionHeader :: Section -> Doc 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" -- | Pretty print a data item. pprDataItem :: Platform -> CmmLit -> Doc 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" -- | Pretty print an instruction. pprInstr :: Platform -> Instr -> Doc -- nuke comments. pprInstr _ (COMMENT _) = empty pprInstr platform (DELTA d) = pprInstr platform (COMMENT (mkFastString ("\tdelta = " ++ show d))) -- Newblocks and LData should have been slurped out before producing the .s file. pprInstr _ (NEWBLOCK _) = panic "X86.Ppr.pprInstr: NEWBLOCK" pprInstr _ (LDATA _ _) = panic "PprMach.pprInstr: LDATA" -- 64 bit FP loads are expanded into individual instructions in CodeGen.Expand 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 ] -- 64 bit FP storees are expanded into individual instructions in CodeGen.Expand pprInstr _ (ST FF64 reg _) | RegReal (RealRegSingle{}) <- reg = panic "SPARC.Ppr: not emitting potentially misaligned ST FF64 instr" -- 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), -- so we call a special-purpose pprSize for ST.. 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_asm 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_asm 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 ] -- | Pretty print a RI pprRI :: Platform -> RI -> Doc pprRI _ (RIReg r) = pprReg r pprRI platform (RIImm r) = pprImm platform r -- | Pretty print a two reg instruction. pprSizeRegReg :: LitString -> Size -> Reg -> Reg -> Doc 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 ] -- | Pretty print a three reg instruction. pprSizeRegRegReg :: LitString -> Size -> Reg -> Reg -> Reg -> Doc 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 ] -- | Pretty print an instruction of two regs and a ri. pprRegRIReg :: Platform -> LitString -> Bool -> Reg -> RI -> Reg -> Doc 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 ] {- pprRIReg :: LitString -> Bool -> RI -> Reg -> Doc pprRIReg name b ri reg1 = hcat [ char '\t', ptext name, if b then ptext (sLit "cc\t") else char '\t', pprRI ri, comma, pprReg reg1 ] -} {- pp_ld_lbracket :: Doc pp_ld_lbracket = ptext (sLit "\tld\t[") -} pp_rbracket_comma :: Doc pp_rbracket_comma = text "]," pp_comma_lbracket :: Doc pp_comma_lbracket = text ",[" pp_comma_a :: Doc pp_comma_a = text ",a"