X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FnativeGen%2FX86%2FPpr.hs;h=c0f465791c41e81f47e50cd03929574d01975e71;hb=7854ec4b11e117f8514553890851d14a66690fbb;hp=c0ad496d7878f9032558c2774435b5b60c6a8515;hpb=efbf8ab4eabc1636417b3ea0ca3f5aa227491d9a;p=ghc-hetmet.git diff --git a/compiler/nativeGen/X86/Ppr.hs b/compiler/nativeGen/X86/Ppr.hs index c0ad496..c0f4657 100644 --- a/compiler/nativeGen/X86/Ppr.hs +++ b/compiler/nativeGen/X86/Ppr.hs @@ -7,12 +7,15 @@ ----------------------------------------------------------------------------- module X86.Ppr ( + pprNatCmmTop, + pprBasicBlock, + pprSectionHeader, + pprData, + pprInstr, pprUserReg, pprSize, pprImm, - pprSectionHeader, pprDataItem, - pprInstr ) where @@ -20,24 +23,143 @@ 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 @@ -49,16 +171,16 @@ pprUserReg = panic "X86.Ppr.pprUserReg: not defined" #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 @@ -178,6 +300,7 @@ pprSize x #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 @@ -228,7 +351,7 @@ pprAddr (AddrBaseIndex base index displacement) = 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 @@ -256,7 +379,7 @@ pprSectionHeader seg 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 @@ -267,7 +390,7 @@ 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 @@ -281,7 +404,7 @@ pprSectionHeader seg 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 @@ -292,7 +415,7 @@ 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 @@ -343,7 +466,7 @@ pprDataItem lit -- 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 = @@ -384,6 +507,7 @@ pprInstr (NEWBLOCK _) pprInstr (LDATA _ _) = panic "PprMach.pprInstr: LDATA" +{- pprInstr (SPILL reg slot) = hcat [ ptext (sLit "\tSPILL"), @@ -399,6 +523,7 @@ pprInstr (RELOAD slot reg) ptext (sLit "SLOT") <> parens (int slot), comma, pprUserReg reg] +-} pprInstr (MOV size src dst) = pprSizeOpOp (sLit "mov") size src dst @@ -414,7 +539,7 @@ pprInstr (MOVZxL sizes src dst) = pprSizeOpOpCoerce (sLit "movz") sizes II32 src -- 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. @@ -497,10 +622,10 @@ pprInstr (JXX cond (BlockId id)) 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 @@ -822,7 +947,7 @@ gsp :: Doc 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 @@ -941,9 +1066,9 @@ pprRegReg :: LitString -> Reg -> Reg -> Doc pprRegReg name reg1 reg2 = hcat [ pprMnemonic_ name, - pprReg wordSize reg1, + pprReg archWordSize reg1, comma, - pprReg wordSize reg2 + pprReg archWordSize reg2 ] @@ -951,9 +1076,9 @@ pprOpReg :: LitString -> Operand -> Reg -> Doc pprOpReg name op1 reg2 = hcat [ pprMnemonic_ name, - pprOperand wordSize op1, + pprOperand archWordSize op1, comma, - pprReg wordSize reg2 + pprReg archWordSize reg2 ]