X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FnativeGen%2FPPC%2FPpr.hs;h=bd12a8188cddc48dcadb6ad579b432e7732691cb;hp=ac83600f9cac527402ed1414d9456ffeb8b25abb;hb=7867349134ee26e4276ff04ace7c815c1de43338;hpb=efbf8ab4eabc1636417b3ea0ca3f5aa227491d9a diff --git a/compiler/nativeGen/PPC/Ppr.hs b/compiler/nativeGen/PPC/Ppr.hs index ac83600..bd12a81 100644 --- a/compiler/nativeGen/PPC/Ppr.hs +++ b/compiler/nativeGen/PPC/Ppr.hs @@ -7,12 +7,14 @@ ----------------------------------------------------------------------------- module PPC.Ppr ( - pprUserReg, + pprNatCmmTop, + pprBasicBlock, + pprSectionHeader, + pprData, + pprInstr, pprSize, pprImm, - pprSectionHeader, pprDataItem, - pprInstr ) where @@ -20,38 +22,149 @@ where #include "nativeGen/NCG.h" #include "HsVersions.h" -import RegsBase -import PprBase 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 OldCmm -import CLabel ( mkAsmTempLabel ) +import CLabel -import Unique ( pprUnique ) +import Unique ( pprUnique, Uniquable(..) ) import Pretty import FastString import qualified Outputable -import Outputable ( panic ) +import Outputable ( Outputable, panic ) -import Data.Word(Word32) +import Data.Word import Data.Bits -pprUserReg :: Reg -> Doc -pprUserReg = pprReg +-- ----------------------------------------------------------------------------- +-- 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 instrs) = + pprLabel (mkAsmTempLabel (getUnique blockid)) $$ + 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 (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 + pprReg :: Reg -> Doc pprReg r = case r of - RealReg i -> ppr_reg_no 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 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) + RegVirtual (VirtualRegSSE u) -> text "%vSSE_" <> asmSDoc (pprUnique u) where #if darwin_TARGET_OS ppr_reg_no :: Int -> Doc @@ -237,14 +350,9 @@ 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( + IF_OS_linux( ((<>) (ptext (sLit "# ")) (ftext s)), ((<>) (ptext (sLit "; ")) (ftext s))) - ,))))) -} pprInstr (DELTA d) = pprInstr (COMMENT (mkFastString ("\tdelta = " ++ show d))) @@ -255,7 +363,7 @@ pprInstr (NEWBLOCK _) pprInstr (LDATA _ _) = panic "PprMach.pprInstr: LDATA" - +{- pprInstr (SPILL reg slot) = hcat [ ptext (sLit "\tSPILL"), @@ -271,6 +379,7 @@ pprInstr (RELOAD slot reg) ptext (sLit "SLOT") <> parens (int slot), comma, pprReg reg] +-} pprInstr (LD sz reg addr) = hcat [ char '\t', @@ -350,7 +459,7 @@ pprInstr (MR reg1 reg2) | reg1 == reg2 = empty | otherwise = hcat [ char '\t', - case regClass reg1 of + case targetClassOfReg reg1 of RcInteger -> ptext (sLit "mr") _ -> ptext (sLit "fmr"), char '\t', @@ -390,16 +499,16 @@ pprInstr (CMPL sz reg ri) = hcat [ RIReg _ -> empty RIImm _ -> char 'i' ] -pprInstr (BCC cond (BlockId id)) = hcat [ +pprInstr (BCC cond blockid) = hcat [ char '\t', ptext (sLit "b"), pprCond cond, char '\t', pprCLabel_asm lbl ] - where lbl = mkAsmTempLabel id + where lbl = mkAsmTempLabel (getUnique blockid) -pprInstr (BCCFAR cond (BlockId id)) = vcat [ +pprInstr (BCCFAR cond blockid) = vcat [ hcat [ ptext (sLit "\tb"), pprCond (condNegate cond), @@ -410,7 +519,7 @@ pprInstr (BCCFAR cond (BlockId id)) = vcat [ pprCLabel_asm lbl ] ] - where lbl = mkAsmTempLabel id + where lbl = mkAsmTempLabel (getUnique blockid) pprInstr (JMP lbl) = hcat [ -- an alias for b that takes a CLabel char '\t', @@ -425,7 +534,7 @@ pprInstr (MTCTR reg) = hcat [ char '\t', pprReg reg ] -pprInstr (BCTR _) = hcat [ +pprInstr (BCTR _ _) = hcat [ char '\t', ptext (sLit "bctr") ]