----------------------------------------------------------------------------- -- -- Pretty-printing assembly language -- -- (c) The University of Glasgow 1993-2005 -- ----------------------------------------------------------------------------- module PPC.Ppr ( pprNatCmmTop, pprBasicBlock, pprSectionHeader, pprData, pprInstr, pprUserReg, pprSize, pprImm, pprDataItem, ) where #include "nativeGen/NCG.h" #include "HsVersions.h" import PPC.Regs import PPC.Instr import PPC.Cond import PprBase import Instruction import Size import Reg import RegClass import TargetReg import BlockId import Cmm import CLabel import Unique ( pprUnique ) import Pretty import FastString import qualified Outputable import Outputable ( Outputable, panic ) import Data.Word import Data.Bits -- ----------------------------------------------------------------------------- -- Printing this stuff out pprNatCmmTop :: NatCmmTop Instr -> Doc pprNatCmmTop (CmmData section dats) = pprSectionHeader section $$ vcat (map pprData dats) -- special case for split markers: pprNatCmmTop (CmmProc [] lbl _ (ListGraph [])) = pprLabel lbl pprNatCmmTop (CmmProc info lbl _ (ListGraph blocks)) = pprSectionHeader Text $$ (if null info then -- blocks guaranteed not null, so label needed pprLabel lbl else #if HAVE_SUBSECTIONS_VIA_SYMBOLS pprCLabel_asm (mkDeadStripPreventer $ entryLblToInfoLbl lbl) <> char ':' $$ #endif vcat (map pprData info) $$ pprLabel (entryLblToInfoLbl lbl) ) $$ vcat (map pprBasicBlock blocks) -- above: Even the first block gets a label, because with branch-chain -- elimination, it might be the target of a goto. #if HAVE_SUBSECTIONS_VIA_SYMBOLS -- 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). $$ if not (null info) then text "\t.long " <+> pprCLabel_asm (entryLblToInfoLbl lbl) <+> char '-' <+> pprCLabel_asm (mkDeadStripPreventer $ entryLblToInfoLbl lbl) else empty #endif pprBasicBlock :: NatBasicBlock Instr -> Doc pprBasicBlock (BasicBlock (BlockId id) instrs) = pprLabel (mkAsmTempLabel id) $$ vcat (map pprInstr instrs) pprData :: CmmStatic -> Doc pprData (CmmAlign bytes) = pprAlign bytes pprData (CmmDataLabel lbl) = pprLabel lbl pprData (CmmString str) = pprASCII str #if darwin_TARGET_OS pprData (CmmUninitialised bytes) = ptext (sLit ".space ") <> int bytes #else pprData (CmmUninitialised bytes) = ptext (sLit ".skip ") <> int bytes #endif pprData (CmmStaticLit lit) = pprDataItem lit pprGloblDecl :: CLabel -> Doc pprGloblDecl lbl | not (externallyVisibleCLabel lbl) = empty | otherwise = ptext IF_ARCH_sparc((sLit ".global "), (sLit ".globl ")) <> pprCLabel_asm lbl pprTypeAndSizeDecl :: CLabel -> Doc #if linux_TARGET_OS pprTypeAndSizeDecl lbl | not (externallyVisibleCLabel lbl) = empty | otherwise = ptext (sLit ".type ") <> pprCLabel_asm lbl <> ptext (sLit ", @object") #else pprTypeAndSizeDecl _ = empty #endif pprLabel :: CLabel -> Doc pprLabel lbl = pprGloblDecl lbl $$ pprTypeAndSizeDecl lbl $$ (pprCLabel_asm 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) pprAlign :: Int -> Doc pprAlign bytes = ptext (sLit ".align ") <> int pow2 where pow2 = log2 bytes log2 :: Int -> Int -- cache the common ones log2 1 = 0 log2 2 = 1 log2 4 = 2 log2 8 = 3 log2 n = 1 + log2 (n `quot` 2) -- ----------------------------------------------------------------------------- -- pprInstr: print an 'Instr' instance Outputable Instr where ppr instr = Outputable.docToSDoc $ pprInstr instr pprUserReg :: Reg -> Doc pprUserReg = pprReg pprReg :: Reg -> Doc pprReg r = case r of RegReal (RealRegSingle i) -> ppr_reg_no i RegReal (RealRegPair{}) -> panic "PPC.pprReg: no reg pairs on this arch" RegVirtual (VirtualRegI u) -> text "%vI_" <> asmSDoc (pprUnique u) RegVirtual (VirtualRegHi u) -> text "%vHi_" <> asmSDoc (pprUnique u) RegVirtual (VirtualRegF u) -> text "%vF_" <> asmSDoc (pprUnique u) RegVirtual (VirtualRegD u) -> text "%vD_" <> asmSDoc (pprUnique u) where #if darwin_TARGET_OS ppr_reg_no :: Int -> Doc ppr_reg_no i = ptext (case i of { 0 -> sLit "r0"; 1 -> sLit "r1"; 2 -> sLit "r2"; 3 -> sLit "r3"; 4 -> sLit "r4"; 5 -> sLit "r5"; 6 -> sLit "r6"; 7 -> sLit "r7"; 8 -> sLit "r8"; 9 -> sLit "r9"; 10 -> sLit "r10"; 11 -> sLit "r11"; 12 -> sLit "r12"; 13 -> sLit "r13"; 14 -> sLit "r14"; 15 -> sLit "r15"; 16 -> sLit "r16"; 17 -> sLit "r17"; 18 -> sLit "r18"; 19 -> sLit "r19"; 20 -> sLit "r20"; 21 -> sLit "r21"; 22 -> sLit "r22"; 23 -> sLit "r23"; 24 -> sLit "r24"; 25 -> sLit "r25"; 26 -> sLit "r26"; 27 -> sLit "r27"; 28 -> sLit "r28"; 29 -> sLit "r29"; 30 -> sLit "r30"; 31 -> sLit "r31"; 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 powerpc register" }) #else ppr_reg_no :: Int -> Doc ppr_reg_no i | i <= 31 = int i -- GPRs | i <= 63 = int (i-32) -- FPRs | otherwise = ptext (sLit "very naughty powerpc register") #endif pprSize :: Size -> Doc pprSize x = ptext (case x of II8 -> sLit "b" II16 -> sLit "h" II32 -> sLit "w" FF32 -> sLit "fs" FF64 -> sLit "fd" _ -> panic "PPC.Ppr.pprSize: no match") pprCond :: Cond -> Doc pprCond c = ptext (case c of { ALWAYS -> sLit ""; EQQ -> sLit "eq"; NE -> sLit "ne"; LTT -> sLit "lt"; GE -> sLit "ge"; GTT -> sLit "gt"; LE -> sLit "le"; LU -> sLit "lt"; GEU -> sLit "ge"; GU -> sLit "gt"; LEU -> sLit "le"; }) pprImm :: Imm -> Doc pprImm (ImmInt i) = int i pprImm (ImmInteger i) = integer i pprImm (ImmCLbl l) = pprCLabel_asm l pprImm (ImmIndex l i) = pprCLabel_asm l <> char '+' <> int i pprImm (ImmLit s) = s pprImm (ImmFloat _) = ptext (sLit "naughty float immediate") pprImm (ImmDouble _) = ptext (sLit "naughty double immediate") pprImm (ImmConstantSum a b) = pprImm a <> char '+' <> pprImm b pprImm (ImmConstantDiff a b) = pprImm a <> char '-' <> lparen <> pprImm b <> rparen #if darwin_TARGET_OS pprImm (LO i) = hcat [ pp_lo, pprImm i, rparen ] where pp_lo = text "lo16(" pprImm (HI i) = hcat [ pp_hi, pprImm i, rparen ] where pp_hi = text "hi16(" pprImm (HA i) = hcat [ pp_ha, pprImm i, rparen ] where pp_ha = text "ha16(" #else pprImm (LO i) = pprImm i <> text "@l" pprImm (HI i) = pprImm i <> text "@h" pprImm (HA i) = pprImm i <> text "@ha" #endif pprAddr :: AddrMode -> Doc pprAddr (AddrRegReg r1 r2) = pprReg r1 <+> ptext (sLit ", ") <+> pprReg r2 pprAddr (AddrRegImm r1 (ImmInt i)) = hcat [ int i, char '(', pprReg r1, char ')' ] pprAddr (AddrRegImm r1 (ImmInteger i)) = hcat [ integer i, char '(', pprReg r1, char ')' ] pprAddr (AddrRegImm r1 imm) = hcat [ pprImm imm, char '(', pprReg r1, char ')' ] pprSectionHeader :: Section -> Doc #if darwin_TARGET_OS pprSectionHeader seg = case seg of Text -> ptext (sLit ".text\n.align 2") Data -> ptext (sLit ".data\n.align 2") ReadOnlyData -> ptext (sLit ".const\n.align 2") RelocatableReadOnlyData -> ptext (sLit ".const_data\n.align 2") UninitialisedData -> ptext (sLit ".const_data\n.align 2") ReadOnlyData16 -> ptext (sLit ".const\n.align 4") OtherSection _ -> panic "PprMach.pprSectionHeader: unknown section" #else pprSectionHeader seg = case seg of Text -> ptext (sLit ".text\n.align 2") Data -> ptext (sLit ".data\n.align 2") ReadOnlyData -> ptext (sLit ".section .rodata\n\t.align 2") RelocatableReadOnlyData -> ptext (sLit ".data\n\t.align 2") UninitialisedData -> ptext (sLit ".section .bss\n\t.align 2") ReadOnlyData16 -> ptext (sLit ".section .rodata\n\t.align 4") OtherSection _ -> panic "PprMach.pprSectionHeader: unknown section" #endif pprDataItem :: CmmLit -> Doc pprDataItem lit = vcat (ppr_item (cmmTypeSize $ cmmLitType lit) lit) where imm = litToImm lit ppr_item II8 _ = [ptext (sLit "\t.byte\t") <> pprImm imm] ppr_item II32 _ = [ptext (sLit "\t.long\t") <> pprImm imm] ppr_item FF32 (CmmFloat r _) = let bs = floatToBytes (fromRational r) in map (\b -> ptext (sLit "\t.byte\t") <> pprImm (ImmInt b)) bs ppr_item FF64 (CmmFloat r _) = let bs = doubleToBytes (fromRational r) in map (\b -> ptext (sLit "\t.byte\t") <> pprImm (ImmInt b)) bs ppr_item II16 _ = [ptext (sLit "\t.short\t") <> pprImm imm] ppr_item II64 (CmmInt x _) = [ptext (sLit "\t.long\t") <> int (fromIntegral (fromIntegral (x `shiftR` 32) :: Word32)), ptext (sLit "\t.long\t") <> int (fromIntegral (fromIntegral x :: Word32))] ppr_item _ _ = panic "PPC.Ppr.pprDataItem: no match" pprInstr :: Instr -> Doc pprInstr (COMMENT _) = empty -- nuke 'em {- pprInstr (COMMENT s) = IF_ARCH_alpha( ((<>) (ptext (sLit "\t# ")) (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))) pprInstr (NEWBLOCK _) = panic "PprMach.pprInstr: NEWBLOCK" pprInstr (LDATA _ _) = panic "PprMach.pprInstr: LDATA" {- pprInstr (SPILL reg slot) = hcat [ ptext (sLit "\tSPILL"), char '\t', pprReg reg, comma, ptext (sLit "SLOT") <> parens (int slot)] pprInstr (RELOAD slot reg) = hcat [ ptext (sLit "\tRELOAD"), char '\t', ptext (sLit "SLOT") <> parens (int slot), comma, pprReg reg] -} pprInstr (LD sz reg addr) = hcat [ char '\t', ptext (sLit "l"), ptext (case sz of II8 -> sLit "bz" II16 -> sLit "hz" II32 -> sLit "wz" FF32 -> sLit "fs" FF64 -> sLit "fd" _ -> panic "PPC.Ppr.pprInstr: no match" ), case addr of AddrRegImm _ _ -> empty AddrRegReg _ _ -> char 'x', char '\t', pprReg reg, ptext (sLit ", "), pprAddr addr ] pprInstr (LA sz reg addr) = hcat [ char '\t', ptext (sLit "l"), ptext (case sz of II8 -> sLit "ba" II16 -> sLit "ha" II32 -> sLit "wa" FF32 -> sLit "fs" FF64 -> sLit "fd" _ -> panic "PPC.Ppr.pprInstr: no match" ), case addr of AddrRegImm _ _ -> empty AddrRegReg _ _ -> char 'x', char '\t', pprReg reg, ptext (sLit ", "), pprAddr addr ] pprInstr (ST sz reg addr) = hcat [ char '\t', ptext (sLit "st"), pprSize sz, case addr of AddrRegImm _ _ -> empty AddrRegReg _ _ -> char 'x', char '\t', pprReg reg, ptext (sLit ", "), pprAddr addr ] pprInstr (STU sz reg addr) = hcat [ char '\t', ptext (sLit "st"), pprSize sz, ptext (sLit "u\t"), case addr of AddrRegImm _ _ -> empty AddrRegReg _ _ -> char 'x', pprReg reg, ptext (sLit ", "), pprAddr addr ] pprInstr (LIS reg imm) = hcat [ char '\t', ptext (sLit "lis"), char '\t', pprReg reg, ptext (sLit ", "), pprImm imm ] pprInstr (LI reg imm) = hcat [ char '\t', ptext (sLit "li"), char '\t', pprReg reg, ptext (sLit ", "), pprImm imm ] pprInstr (MR reg1 reg2) | reg1 == reg2 = empty | otherwise = hcat [ char '\t', case targetClassOfReg reg1 of RcInteger -> ptext (sLit "mr") _ -> ptext (sLit "fmr"), char '\t', pprReg reg1, ptext (sLit ", "), pprReg reg2 ] pprInstr (CMP sz reg ri) = hcat [ char '\t', op, char '\t', pprReg reg, ptext (sLit ", "), pprRI ri ] where op = hcat [ ptext (sLit "cmp"), pprSize sz, case ri of RIReg _ -> empty RIImm _ -> char 'i' ] pprInstr (CMPL sz reg ri) = hcat [ char '\t', op, char '\t', pprReg reg, ptext (sLit ", "), pprRI ri ] where op = hcat [ ptext (sLit "cmpl"), pprSize sz, case ri of RIReg _ -> empty RIImm _ -> char 'i' ] pprInstr (BCC cond (BlockId id)) = hcat [ char '\t', ptext (sLit "b"), pprCond cond, char '\t', pprCLabel_asm lbl ] where lbl = mkAsmTempLabel id pprInstr (BCCFAR cond (BlockId id)) = vcat [ hcat [ ptext (sLit "\tb"), pprCond (condNegate cond), ptext (sLit "\t$+8") ], hcat [ ptext (sLit "\tb\t"), pprCLabel_asm lbl ] ] where lbl = mkAsmTempLabel id pprInstr (JMP lbl) = hcat [ -- an alias for b that takes a CLabel char '\t', ptext (sLit "b"), char '\t', pprCLabel_asm lbl ] pprInstr (MTCTR reg) = hcat [ char '\t', ptext (sLit "mtctr"), char '\t', pprReg reg ] pprInstr (BCTR _) = hcat [ char '\t', ptext (sLit "bctr") ] pprInstr (BL lbl _) = hcat [ ptext (sLit "\tbl\t"), pprCLabel_asm lbl ] pprInstr (BCTRL _) = hcat [ char '\t', ptext (sLit "bctrl") ] pprInstr (ADD reg1 reg2 ri) = pprLogic (sLit "add") reg1 reg2 ri pprInstr (ADDIS reg1 reg2 imm) = hcat [ char '\t', ptext (sLit "addis"), char '\t', pprReg reg1, ptext (sLit ", "), pprReg reg2, ptext (sLit ", "), pprImm imm ] pprInstr (ADDC reg1 reg2 reg3) = pprLogic (sLit "addc") reg1 reg2 (RIReg reg3) pprInstr (ADDE reg1 reg2 reg3) = pprLogic (sLit "adde") reg1 reg2 (RIReg reg3) pprInstr (SUBF reg1 reg2 reg3) = pprLogic (sLit "subf") reg1 reg2 (RIReg reg3) pprInstr (MULLW reg1 reg2 ri@(RIReg _)) = pprLogic (sLit "mullw") reg1 reg2 ri pprInstr (MULLW reg1 reg2 ri@(RIImm _)) = pprLogic (sLit "mull") reg1 reg2 ri pprInstr (DIVW reg1 reg2 reg3) = pprLogic (sLit "divw") reg1 reg2 (RIReg reg3) pprInstr (DIVWU reg1 reg2 reg3) = pprLogic (sLit "divwu") reg1 reg2 (RIReg reg3) pprInstr (MULLW_MayOflo reg1 reg2 reg3) = vcat [ hcat [ ptext (sLit "\tmullwo\t"), pprReg reg1, ptext (sLit ", "), pprReg reg2, ptext (sLit ", "), pprReg reg3 ], hcat [ ptext (sLit "\tmfxer\t"), pprReg reg1 ], hcat [ ptext (sLit "\trlwinm\t"), pprReg reg1, ptext (sLit ", "), pprReg reg1, ptext (sLit ", "), ptext (sLit "2, 31, 31") ] ] -- for some reason, "andi" doesn't exist. -- we'll use "andi." instead. pprInstr (AND reg1 reg2 (RIImm imm)) = hcat [ char '\t', ptext (sLit "andi."), char '\t', pprReg reg1, ptext (sLit ", "), pprReg reg2, ptext (sLit ", "), pprImm imm ] pprInstr (AND reg1 reg2 ri) = pprLogic (sLit "and") reg1 reg2 ri pprInstr (OR reg1 reg2 ri) = pprLogic (sLit "or") reg1 reg2 ri pprInstr (XOR reg1 reg2 ri) = pprLogic (sLit "xor") reg1 reg2 ri pprInstr (XORIS reg1 reg2 imm) = hcat [ char '\t', ptext (sLit "xoris"), char '\t', pprReg reg1, ptext (sLit ", "), pprReg reg2, ptext (sLit ", "), pprImm imm ] pprInstr (EXTS sz reg1 reg2) = hcat [ char '\t', ptext (sLit "exts"), pprSize sz, char '\t', pprReg reg1, ptext (sLit ", "), pprReg reg2 ] pprInstr (NEG reg1 reg2) = pprUnary (sLit "neg") reg1 reg2 pprInstr (NOT reg1 reg2) = pprUnary (sLit "not") reg1 reg2 pprInstr (SLW reg1 reg2 ri) = pprLogic (sLit "slw") reg1 reg2 (limitShiftRI ri) pprInstr (SRW reg1 reg2 ri) = pprLogic (sLit "srw") reg1 reg2 (limitShiftRI ri) pprInstr (SRAW reg1 reg2 ri) = pprLogic (sLit "sraw") reg1 reg2 (limitShiftRI ri) pprInstr (RLWINM reg1 reg2 sh mb me) = hcat [ ptext (sLit "\trlwinm\t"), pprReg reg1, ptext (sLit ", "), pprReg reg2, ptext (sLit ", "), int sh, ptext (sLit ", "), int mb, ptext (sLit ", "), int me ] pprInstr (FADD sz reg1 reg2 reg3) = pprBinaryF (sLit "fadd") sz reg1 reg2 reg3 pprInstr (FSUB sz reg1 reg2 reg3) = pprBinaryF (sLit "fsub") sz reg1 reg2 reg3 pprInstr (FMUL sz reg1 reg2 reg3) = pprBinaryF (sLit "fmul") sz reg1 reg2 reg3 pprInstr (FDIV sz reg1 reg2 reg3) = pprBinaryF (sLit "fdiv") sz reg1 reg2 reg3 pprInstr (FNEG reg1 reg2) = pprUnary (sLit "fneg") reg1 reg2 pprInstr (FCMP reg1 reg2) = hcat [ char '\t', ptext (sLit "fcmpu\tcr0, "), -- Note: we're using fcmpu, not fcmpo -- The difference is with fcmpo, compare with NaN is an invalid operation. -- We don't handle invalid fp ops, so we don't care pprReg reg1, ptext (sLit ", "), pprReg reg2 ] pprInstr (FCTIWZ reg1 reg2) = pprUnary (sLit "fctiwz") reg1 reg2 pprInstr (FRSP reg1 reg2) = pprUnary (sLit "frsp") reg1 reg2 pprInstr (CRNOR dst src1 src2) = hcat [ ptext (sLit "\tcrnor\t"), int dst, ptext (sLit ", "), int src1, ptext (sLit ", "), int src2 ] pprInstr (MFCR reg) = hcat [ char '\t', ptext (sLit "mfcr"), char '\t', pprReg reg ] pprInstr (MFLR reg) = hcat [ char '\t', ptext (sLit "mflr"), char '\t', pprReg reg ] pprInstr (FETCHPC reg) = vcat [ ptext (sLit "\tbcl\t20,31,1f"), hcat [ ptext (sLit "1:\tmflr\t"), pprReg reg ] ] pprInstr LWSYNC = ptext (sLit "\tlwsync") -- pprInstr _ = panic "pprInstr (ppc)" pprLogic :: LitString -> Reg -> Reg -> RI -> Doc pprLogic op reg1 reg2 ri = hcat [ char '\t', ptext op, case ri of RIReg _ -> empty RIImm _ -> char 'i', char '\t', pprReg reg1, ptext (sLit ", "), pprReg reg2, ptext (sLit ", "), pprRI ri ] pprUnary :: LitString -> Reg -> Reg -> Doc pprUnary op reg1 reg2 = hcat [ char '\t', ptext op, char '\t', pprReg reg1, ptext (sLit ", "), pprReg reg2 ] pprBinaryF :: LitString -> Size -> Reg -> Reg -> Reg -> Doc pprBinaryF op sz reg1 reg2 reg3 = hcat [ char '\t', ptext op, pprFSize sz, char '\t', pprReg reg1, ptext (sLit ", "), pprReg reg2, ptext (sLit ", "), pprReg reg3 ] pprRI :: RI -> Doc pprRI (RIReg r) = pprReg r pprRI (RIImm r) = pprImm r pprFSize :: Size -> Doc pprFSize FF64 = empty pprFSize FF32 = char 's' pprFSize _ = panic "PPC.Ppr.pprFSize: no match" -- limit immediate argument for shift instruction to range 0..32 -- (yes, the maximum is really 32, not 31) limitShiftRI :: RI -> RI limitShiftRI (RIImm (ImmInt i)) | i > 32 || i < 0 = RIImm (ImmInt 32) limitShiftRI x = x