X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FnativeGen%2FPprMach.hs;h=51159559edaa298848516776933f3d9fa2ba035a;hb=dd9d5b34eb64fd45b362eab8aed53b90f1defeec;hp=3e2161e7ade31ef47e16a1325bb6618805b2af8b;hpb=7d817d447d3ee0df22691afad29c94ebbb334120;p=ghc-hetmet.git diff --git a/compiler/nativeGen/PprMach.hs b/compiler/nativeGen/PprMach.hs index 3e2161e..5115955 100644 --- a/compiler/nativeGen/PprMach.hs +++ b/compiler/nativeGen/PprMach.hs @@ -1,3 +1,10 @@ +{-# OPTIONS -w #-} +-- The above warning supression flag is a temporary kludge. +-- While working on this module you are encouraged to remove it and fix +-- any warnings in the module. See +-- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings +-- for details + ----------------------------------------------------------------------------- -- -- Pretty-printing assembly language @@ -13,8 +20,8 @@ #include "nativeGen/NCG.h" module PprMach ( - pprNatCmmTop, pprBasicBlock, - pprInstr, pprSize, pprUserReg, + pprNatCmmTop, pprBasicBlock, pprSectionHeader, pprData, + pprInstr, pprSize, pprUserReg ) where @@ -36,6 +43,7 @@ import Unique ( pprUnique ) import Pretty import FastString import qualified Outputable +import Outputable ( Outputable ) import Data.Array.ST import Data.Word ( Word8 ) @@ -60,27 +68,23 @@ pprNatCmmTop (CmmData section dats) = pprSectionHeader section $$ vcat (map pprData dats) -- special case for split markers: -pprNatCmmTop (CmmProc [] lbl _ []) = pprLabel lbl +pprNatCmmTop (CmmProc [] lbl _ (ListGraph [])) = pprLabel lbl -pprNatCmmTop (CmmProc info lbl params blocks) = +pprNatCmmTop (CmmProc info lbl params (ListGraph blocks)) = pprSectionHeader Text $$ - (if not (null info) - then + (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) - else empty) $$ - (case blocks of - [] -> empty - (BasicBlock _ instrs : rest) -> - (if null info then pprLabel lbl else empty) $$ - -- the first block doesn't get a label: - vcat (map pprInstr instrs) $$ - vcat (map pprBasicBlock rest) - ) + vcat (map pprData info) $$ + pprLabel (entryLblToInfoLbl lbl) + ) $$ + vcat (map pprBasicBlock blocks) + -- ^ 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), @@ -646,9 +650,9 @@ pprSectionHeader RelocatableReadOnlyData IF_ARCH_alpha(SLIT("\t.data\n\t.align 3") ,IF_ARCH_sparc(SLIT(".data\n\t.align 8") {-<8 will break double constants -} ,IF_ARCH_i386(IF_OS_darwin(SLIT(".const_data\n.align 2"), - SLIT(".section .rodata\n\t.align 4")) + SLIT(".section .data\n\t.align 4")) ,IF_ARCH_x86_64(IF_OS_darwin(SLIT(".const_data\n.align 3"), - SLIT(".section .rodata\n\t.align 8")) + SLIT(".section .data\n\t.align 8")) ,IF_ARCH_powerpc(IF_OS_darwin(SLIT(".const_data\n.align 2"), SLIT(".data\n\t.align 2")) ,))))) @@ -692,8 +696,18 @@ pprGloblDecl lbl SLIT(".globl ")) <> pprCLabel_asm lbl +pprTypeAndSizeDecl :: CLabel -> Doc +pprTypeAndSizeDecl lbl +#if linux_TARGET_OS + | not (externallyVisibleCLabel lbl) = empty + | otherwise = ptext SLIT(".type ") <> + pprCLabel_asm lbl <> ptext SLIT(", @object") +#else + = empty +#endif + pprLabel :: CLabel -> Doc -pprLabel lbl = pprGloblDecl lbl $$ (pprCLabel_asm lbl <> char ':') +pprLabel lbl = pprGloblDecl lbl $$ pprTypeAndSizeDecl lbl $$ (pprCLabel_asm lbl <> char ':') pprASCII str @@ -760,7 +774,8 @@ pprDataItem lit -- Fortunately we're assuming the small memory model, in which -- all such offsets will fit into 32 bits, so we have to stick -- to 32-bit offset fields and modify the RTS appropriately - -- (see InfoTables.h). + -- + -- See Note [x86-64-relative] in includes/InfoTables.h -- ppr_item I64 x | isRelativeReloc x = @@ -769,7 +784,6 @@ pprDataItem lit | otherwise = [ptext SLIT("\t.quad\t") <> pprImm imm] where - isRelativeReloc (CmmLabelOff _ _) = True isRelativeReloc (CmmLabelDiffOff _ _ _) = True isRelativeReloc _ = False #endif @@ -788,6 +802,9 @@ pprDataItem lit -- ----------------------------------------------------------------------------- -- pprInstr: print an 'Instr' +instance Outputable Instr where + ppr instr = Outputable.docToSDoc $ pprInstr instr + pprInstr :: Instr -> Doc --pprInstr (COMMENT s) = empty -- nuke 'em @@ -815,6 +832,22 @@ pprInstr (LDATA _ _) #if alpha_TARGET_ARCH +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 size reg addr) = hcat [ ptext SLIT("\tld"), @@ -1197,14 +1230,21 @@ pprSizeRegRegReg name size reg1 reg2 reg3 #if i386_TARGET_ARCH || x86_64_TARGET_ARCH -pprInstr v@(MOV size s@(OpReg src) d@(OpReg dst)) -- hack - | src == dst - = -#if 0 /* #ifdef DEBUG */ - (<>) (ptext SLIT("# warning: ")) (pprSizeOpOp SLIT("mov") size s d) -#else - empty -#endif +pprInstr (SPILL reg slot) + = hcat [ + ptext SLIT("\tSPILL"), + char ' ', + pprUserReg reg, + comma, + ptext SLIT("SLOT") <> parens (int slot)] + +pprInstr (RELOAD slot reg) + = hcat [ + ptext SLIT("\tRELOAD"), + char ' ', + ptext SLIT("SLOT") <> parens (int slot), + comma, + pprUserReg reg] pprInstr (MOV size src dst) = pprSizeOpOp SLIT("mov") size src dst @@ -1767,6 +1807,22 @@ pprCondInstr name cond arg -- reads (bytearrays). -- +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] + -- Translate to the following: -- add g1,g2,g1 -- ld [g1],%fn @@ -2041,6 +2097,23 @@ pp_comma_a = text ",a" -- pprInstr for PowerPC #if powerpc_TARGET_ARCH + +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"),