-----------------------------------------------------------------------------
module X86.Ppr (
+ pprNatCmmTop,
+ pprBasicBlock,
+ pprSectionHeader,
+ pprData,
+ pprInstr,
pprUserReg,
pprSize,
pprImm,
- pprSectionHeader,
pprDataItem,
- pprInstr
)
where
#include "HsVersions.h"
#include "nativeGen/NCG.h"
-import PprBase
-import RegsBase
import X86.Regs
import X86.Instr
+import X86.Cond
+import Instruction
+import Size
+import Reg
+import PprBase
+
import BlockId
import Cmm
-
-import CLabel ( CLabel, mkAsmTempLabel )
-#if HAVE_SUBSECTIONS_VIA_SYMBOLS
-import CLabel ( mkDeadStripPreventer )
-#endif
-
+import CLabel
import Unique ( pprUnique )
import Pretty
import FastString
import qualified Outputable
-import Outputable (panic)
+import Outputable (panic, Outputable)
+
+import Data.Word
+
+#if i386_TARGET_ARCH && darwin_TARGET_OS
+import Data.Bits
+#endif
+
+-- -----------------------------------------------------------------------------
+-- 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 IF_OS_darwin(pow2, bytes)
+ where
+
+#if darwin_TARGET_OS
+ 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)
+#endif
+
+-- -----------------------------------------------------------------------------
+-- pprInstr: print an 'Instr'
+
+instance Outputable Instr where
+ ppr instr = Outputable.docToSDoc $ pprInstr instr
+
#if i386_TARGET_ARCH || x86_64_TARGET_ARCH
pprUserReg :: Reg -> Doc
#endif
-
pprReg :: Size -> Reg -> Doc
pprReg s r
= case r of
- RealReg i -> ppr_reg_no s i
- 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)
+ RegReal (RealRegSingle i) -> ppr_reg_no s i
+ RegReal (RealRegPair _ _) -> panic "X86.Ppr: 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 i386_TARGET_ARCH
ppr_reg_no :: Size -> Int -> Doc
#elif x86_64_TARGET_ARCH
FF32 -> sLit "ss" -- "scalar single-precision float" (SSE2)
FF64 -> sLit "sd" -- "scalar double-precision float" (SSE2)
+ _ -> panic "X86.Ppr.pprSize: no match"
#else
_ -> panic "X86.Ppr.pprSize: no match"
#endif
= let
pp_disp = ppr_disp displacement
pp_off p = pp_disp <> char '(' <> p <> char ')'
- pp_reg r = pprReg wordSize r
+ pp_reg r = pprReg archWordSize r
in
case (base, index) of
(EABaseNone, EAIndexNone) -> pp_disp
RelocatableReadOnlyData -> ptext (sLit ".const_data\n.align 2")
UninitialisedData -> ptext (sLit ".data\n\t.align 2")
ReadOnlyData16 -> ptext (sLit ".const\n.align 4")
- OtherSection sec -> panic "X86.Ppr.pprSectionHeader: unknown section"
+ OtherSection _ -> panic "X86.Ppr.pprSectionHeader: unknown section"
# else
pprSectionHeader seg
RelocatableReadOnlyData -> ptext (sLit ".section .data\n\t.align 4")
UninitialisedData -> ptext (sLit ".section .bss\n\t.align 4")
ReadOnlyData16 -> ptext (sLit ".section .rodata\n\t.align 16")
- OtherSection sec -> panic "X86.Ppr.pprSectionHeader: unknown section"
+ OtherSection _ -> panic "X86.Ppr.pprSectionHeader: unknown section"
# endif
RelocatableReadOnlyData -> ptext (sLit ".const_data\n.align 3")
UninitialisedData -> ptext (sLit ".data\n\t.align 3")
ReadOnlyData16 -> ptext (sLit ".const\n.align 4")
- OtherSection sec -> panic "PprMach.pprSectionHeader: unknown section"
+ OtherSection _ -> panic "PprMach.pprSectionHeader: unknown section"
# else
pprSectionHeader seg
RelocatableReadOnlyData -> ptext (sLit ".section .data\n\t.align 8")
UninitialisedData -> ptext (sLit ".section .bss\n\t.align 8")
ReadOnlyData16 -> ptext (sLit ".section .rodata.cst16\n\t.align 16")
- OtherSection sec -> panic "PprMach.pprSectionHeader: unknown section"
+ OtherSection _ -> panic "PprMach.pprSectionHeader: unknown section"
# endif
-- all such offsets will fit into 32 bits, so we have to stick
-- to 32-bit offset fields and modify the RTS appropriately
--
- -- See Note [x86-64-relative] in includes/InfoTables.h
+ -- See Note [x86-64-relative] in includes/rts/storage/InfoTables.h
--
ppr_item II64 x
| isRelativeReloc x =
pprInstr (LDATA _ _)
= panic "PprMach.pprInstr: LDATA"
+{-
pprInstr (SPILL reg slot)
= hcat [
ptext (sLit "\tSPILL"),
ptext (sLit "SLOT") <> parens (int slot),
comma,
pprUserReg reg]
+-}
pprInstr (MOV size src dst)
= pprSizeOpOp (sLit "mov") size src dst
-- the remaining zero-extension to 64 bits is automatic, and the 32-bit
-- instruction is shorter.
-pprInstr (MOVSxL sizes src dst) = pprSizeOpOpCoerce (sLit "movs") sizes wordSize src dst
+pprInstr (MOVSxL sizes src dst) = pprSizeOpOpCoerce (sLit "movs") sizes archWordSize src dst
-- here we do some patching, since the physical registers are only set late
-- in the code generation.
pprInstr (JXX_GBL cond imm) = pprCondInstr (sLit "j") cond (pprImm imm)
pprInstr (JMP (OpImm imm)) = (<>) (ptext (sLit "\tjmp ")) (pprImm imm)
-pprInstr (JMP op) = (<>) (ptext (sLit "\tjmp *")) (pprOperand wordSize op)
+pprInstr (JMP op) = (<>) (ptext (sLit "\tjmp *")) (pprOperand archWordSize op)
pprInstr (JMP_TBL op _) = pprInstr (JMP op)
pprInstr (CALL (Left imm) _) = (<>) (ptext (sLit "\tcall ")) (pprImm imm)
-pprInstr (CALL (Right reg) _) = (<>) (ptext (sLit "\tcall *")) (pprReg wordSize reg)
+pprInstr (CALL (Right reg) _) = (<>) (ptext (sLit "\tcall *")) (pprReg archWordSize reg)
pprInstr (IDIV sz op) = pprSizeOp (sLit "idiv") sz op
pprInstr (DIV sz op) = pprSizeOp (sLit "div") sz op
gsp = char ' '
gregno :: Reg -> RegNo
-gregno (RealReg i) = i
+gregno (RegReal (RealRegSingle i)) = i
gregno _ = --pprPanic "gregno" (ppr other)
999 -- bogus; only needed for debug printing
pprRegReg name reg1 reg2
= hcat [
pprMnemonic_ name,
- pprReg wordSize reg1,
+ pprReg archWordSize reg1,
comma,
- pprReg wordSize reg2
+ pprReg archWordSize reg2
]
pprOpReg name op1 reg2
= hcat [
pprMnemonic_ name,
- pprOperand wordSize op1,
+ pprOperand archWordSize op1,
comma,
- pprReg wordSize reg2
+ pprReg archWordSize reg2
]
projects / ghc-hetmet.git / blobdiff