-----------------------------------------------------------------------------
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 elf_OBJ_FORMAT
+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)
+ RegVirtual (VirtualRegSSE u) -> text "%vSSE_" <> asmSDoc (pprUnique u)
where
#if i386_TARGET_ARCH
ppr_reg_no :: Size -> Int -> Doc
2 -> sLit "%ecx"; 3 -> sLit "%edx";
4 -> sLit "%esi"; 5 -> sLit "%edi";
6 -> sLit "%ebp"; 7 -> sLit "%esp";
- 8 -> sLit "%fake0"; 9 -> sLit "%fake1";
- 10 -> sLit "%fake2"; 11 -> sLit "%fake3";
- 12 -> sLit "%fake4"; 13 -> sLit "%fake5";
- _ -> sLit "very naughty I386 register"
+ _ -> ppr_reg_float i
})
#elif x86_64_TARGET_ARCH
ppr_reg_no :: Size -> Int -> Doc
10 -> sLit "%r10"; 11 -> sLit "%r11";
12 -> sLit "%r12"; 13 -> sLit "%r13";
14 -> sLit "%r14"; 15 -> sLit "%r15";
- 16 -> sLit "%xmm0"; 17 -> sLit "%xmm1";
- 18 -> sLit "%xmm2"; 19 -> sLit "%xmm3";
- 20 -> sLit "%xmm4"; 21 -> sLit "%xmm5";
- 22 -> sLit "%xmm6"; 23 -> sLit "%xmm7";
- 24 -> sLit "%xmm8"; 25 -> sLit "%xmm9";
- 26 -> sLit "%xmm10"; 27 -> sLit "%xmm11";
- 28 -> sLit "%xmm12"; 29 -> sLit "%xmm13";
- 30 -> sLit "%xmm14"; 31 -> sLit "%xmm15";
- _ -> sLit "very naughty x86_64 register"
+ _ -> ppr_reg_float i
})
#else
ppr_reg_no _ = panic "X86.Ppr.ppr_reg_no: no match"
#endif
+ppr_reg_float :: Int -> LitString
+ppr_reg_float i = case i of
+ 16 -> sLit "%fake0"; 17 -> sLit "%fake1"
+ 18 -> sLit "%fake2"; 19 -> sLit "%fake3"
+ 20 -> sLit "%fake4"; 21 -> sLit "%fake5"
+ 24 -> sLit "%xmm0"; 25 -> sLit "%xmm1"
+ 26 -> sLit "%xmm2"; 27 -> sLit "%xmm3"
+ 28 -> sLit "%xmm4"; 29 -> sLit "%xmm5"
+ 30 -> sLit "%xmm6"; 31 -> sLit "%xmm7"
+ 32 -> sLit "%xmm8"; 33 -> sLit "%xmm9"
+ 34 -> sLit "%xmm10"; 35 -> sLit "%xmm11"
+ 36 -> sLit "%xmm12"; 37 -> sLit "%xmm13"
+ 38 -> sLit "%xmm14"; 39 -> sLit "%xmm15"
+ _ -> sLit "very naughty x86 register"
pprSize :: Size -> Doc
pprSize x
II16 -> sLit "w"
II32 -> sLit "l"
II64 -> sLit "q"
-#if i386_TARGET_ARCH
- FF32 -> sLit "s"
- FF64 -> sLit "l"
- FF80 -> sLit "t"
-#elif x86_64_TARGET_ARCH
FF32 -> sLit "ss" -- "scalar single-precision float" (SSE2)
FF64 -> sLit "sd" -- "scalar double-precision float" (SSE2)
-#else
- _ -> panic "X86.Ppr.pprSize: no match"
-#endif
+ FF80 -> sLit "t"
)
+pprSize_x87 :: Size -> Doc
+pprSize_x87 x
+ = ptext $ case x of
+ FF32 -> sLit "s"
+ FF64 -> sLit "l"
+ FF80 -> sLit "t"
+ _ -> panic "X86.Ppr.pprSize_x87"
+
pprCond :: Cond -> Doc
pprCond c
= ptext (case c of {
= 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
pprInstr (FDIV size op1 op2) = pprSizeOpOp (sLit "div") size op1 op2
-pprInstr (CVTSS2SD from to) = pprRegReg (sLit "cvtss2sd") from to
-pprInstr (CVTSD2SS from to) = pprRegReg (sLit "cvtsd2ss") from to
-pprInstr (CVTTSS2SIQ from to) = pprOpReg (sLit "cvttss2siq") from to
-pprInstr (CVTTSD2SIQ from to) = pprOpReg (sLit "cvttsd2siq") from to
-pprInstr (CVTSI2SS from to) = pprOpReg (sLit "cvtsi2ssq") from to
-pprInstr (CVTSI2SD from to) = pprOpReg (sLit "cvtsi2sdq") from to
+pprInstr (CVTSS2SD from to) = pprRegReg (sLit "cvtss2sd") from to
+pprInstr (CVTSD2SS from to) = pprRegReg (sLit "cvtsd2ss") from to
+pprInstr (CVTTSS2SIQ sz from to) = pprSizeOpReg (sLit "cvttss2si") sz from to
+pprInstr (CVTTSD2SIQ sz from to) = pprSizeOpReg (sLit "cvttsd2si") sz from to
+pprInstr (CVTSI2SS sz from to) = pprSizeOpReg (sLit "cvtsi2ss") sz from to
+pprInstr (CVTSI2SD sz from to) = pprSizeOpReg (sLit "cvtsi2sd") sz from to
-- FETCHGOT for PIC on ELF platforms
pprInstr (FETCHGOT reg)
| otherwise
= pprG g (hcat [gtab, gpush src 0, gsemi, gpop dst 1])
--- GLD sz addr dst ==> FFREE %st(7) ; FLDsz addr ; FSTP (dst+1)
+-- GLD sz addr dst ==> FLDsz addr ; FSTP (dst+1)
pprInstr g@(GLD sz addr dst)
- = pprG g (hcat [gtab, text "ffree %st(7) ; fld", pprSize sz, gsp,
+ = pprG g (hcat [gtab, text "fld", pprSize_x87 sz, gsp,
pprAddr addr, gsemi, gpop dst 1])
--- GST sz src addr ==> FFREE %st(7) ; FLD dst ; FSTPsz addr
+-- GST sz src addr ==> FLD dst ; FSTPsz addr
pprInstr g@(GST sz src addr)
+ | src == fake0 && sz /= FF80 -- fstt instruction doesn't exist
+ = pprG g (hcat [gtab,
+ text "fst", pprSize_x87 sz, gsp, pprAddr addr])
+ | otherwise
= pprG g (hcat [gtab, gpush src 0, gsemi,
- text "fstp", pprSize sz, gsp, pprAddr addr])
+ text "fstp", pprSize_x87 sz, gsp, pprAddr addr])
pprInstr g@(GLDZ dst)
- = pprG g (hcat [gtab, text "ffree %st(7) ; fldz ; ", gpop dst 1])
+ = pprG g (hcat [gtab, text "fldz ; ", gpop dst 1])
pprInstr g@(GLD1 dst)
- = pprG g (hcat [gtab, text "ffree %st(7) ; fld1 ; ", gpop dst 1])
+ = pprG g (hcat [gtab, text "fld1 ; ", gpop dst 1])
pprInstr (GFTOI src dst)
= pprInstr (GDTOI src dst)
pprInstr g@(GITOD src dst)
= pprG g (hcat [gtab, text "pushl ", pprReg II32 src,
- text " ; ffree %st(7); fildl (%esp) ; ",
+ text " ; fildl (%esp) ; ",
gpop dst 1, text " ; addl $4,%esp"])
{- Gruesome swamp follows. If you're unfortunate enough to have ventured
pprInstr GFREE
= vcat [ ptext (sLit "\tffree %st(0) ;ffree %st(1) ;ffree %st(2) ;ffree %st(3)"),
- ptext (sLit "\tffree %st(4) ;ffree %st(5) ;ffree %st(6) ;ffree %st(7)")
+ ptext (sLit "\tffree %st(4) ;ffree %st(5)")
]
pprInstr _
gpush :: Reg -> RegNo -> Doc
gpush reg offset
- = hcat [text "ffree %st(7) ; fld ", greg reg offset]
-
+ = hcat [text "fld ", greg reg offset]
gpop :: Reg -> RegNo -> Doc
gpop reg offset
= hcat [text "fstp ", greg reg offset]
greg :: Reg -> RegNo -> Doc
-greg reg offset = text "%st(" <> int (gregno reg - 8+offset) <> char ')'
+greg reg offset = text "%st(" <> int (gregno reg - 16+offset) <> char ')'
gsemi :: Doc
gsemi = text " ; "
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 :: LitString -> Operand -> Reg -> Doc
-pprOpReg name op1 reg2
+pprSizeOpReg :: LitString -> Size -> Operand -> Reg -> Doc
+pprSizeOpReg name size op1 reg2
= hcat [
- pprMnemonic_ name,
- pprOperand wordSize op1,
+ pprMnemonic name size,
+ pprOperand size op1,
comma,
- pprReg wordSize reg2
+ pprReg archWordSize reg2
]
projects / ghc-hetmet.git / blobdiff