X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FnativeGen%2FSPARC%2FPpr.hs;h=d78d1a760e3090f7cac12e0eb2a7262916a1128e;hp=7d64df1b15dc26c95ccf91c7ac1835ee7a19e1ae;hb=7867349134ee26e4276ff04ace7c815c1de43338;hpb=efbf8ab4eabc1636417b3ea0ca3f5aa227491d9a diff --git a/compiler/nativeGen/SPARC/Ppr.hs b/compiler/nativeGen/SPARC/Ppr.hs index 7d64df1..d78d1a7 100644 --- a/compiler/nativeGen/SPARC/Ppr.hs +++ b/compiler/nativeGen/SPARC/Ppr.hs @@ -7,12 +7,14 @@ ----------------------------------------------------------------------------- module SPARC.Ppr ( - pprUserReg, + pprNatCmmTop, + pprBasicBlock, + pprSectionHeader, + pprData, + pprInstr, pprSize, pprImm, - pprSectionHeader, - pprDataItem, - pprInstr + pprDataItem ) where @@ -20,37 +22,143 @@ where #include "HsVersions.h" #include "nativeGen/NCG.h" -import PprBase -import RegsBase import SPARC.Regs import SPARC.Instr +import SPARC.Cond +import SPARC.Imm +import SPARC.AddrMode +import SPARC.Base +import Instruction +import Reg +import Size +import PprBase -import BlockId -import Cmm - +import OldCmm +import OldPprCmm() import CLabel -import Panic ( panic ) -import Unique ( pprUnique ) +import Unique ( Uniquable(..), pprUnique ) +import qualified Outputable +import Outputable (Outputable, panic) import Pretty import FastString +import Data.Word + +-- ----------------------------------------------------------------------------- +-- 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 +pprData (CmmUninitialised bytes) = ptext (sLit ".skip ") <> int bytes +pprData (CmmStaticLit lit) = pprDataItem lit + +pprGloblDecl :: CLabel -> Doc +pprGloblDecl lbl + | not (externallyVisibleCLabel lbl) = empty + | otherwise = ptext (sLit ".global ") <> 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 bytes --- | Pretty print a register. --- This is an alias of pprReg for legacy reasons, should remove it. -pprUserReg :: Reg -> Doc -pprUserReg = pprReg + +-- ----------------------------------------------------------------------------- +-- pprInstr: print an 'Instr' + +instance Outputable Instr where + ppr instr = Outputable.docToSDoc $ pprInstr instr -- | Pretty print a register. pprReg :: Reg -> Doc -pprReg r - = case r of - RealReg i -> pprReg_ofRegNo 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) +pprReg reg + = case reg of + RegVirtual vr + -> case vr of + 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) + VirtualRegSSE u -> text "%vSSE_" <> asmSDoc (pprUnique u) + + RegReal rr + -> case rr of + RealRegSingle r1 + -> pprReg_ofRegNo r1 + + RealRegPair r1 r2 + -> text "(" <> pprReg_ofRegNo r1 + <> text "|" <> pprReg_ofRegNo r2 + <> text ")" + -- | Pretty print a register name, based on this register number. @@ -101,12 +209,13 @@ pprSize :: Size -> Doc pprSize x = ptext (case x of - II8 -> sLit "ub" - II16 -> sLit "uh" - II32 -> sLit "" - II64 -> sLit "d" - FF32 -> sLit "" - FF64 -> sLit "d") + II8 -> sLit "ub" + II16 -> sLit "uh" + II32 -> sLit "" + II64 -> sLit "d" + FF32 -> sLit "" + FF64 -> sLit "d" + _ -> panic "SPARC.Ppr.pprSize: no match") -- | Pretty print a size for an instruction suffix. @@ -120,7 +229,8 @@ pprStSize x II32 -> sLit "" II64 -> sLit "x" FF32 -> sLit "" - FF64 -> sLit "d") + FF64 -> sLit "d" + _ -> panic "SPARC.Ppr.pprSize: no match") -- | Pretty print a condition code. @@ -150,7 +260,7 @@ pprCond c pprAddr :: AddrMode -> Doc pprAddr am = case am of - AddrRegReg r1 (RealReg 0) + AddrRegReg r1 (RegReal (RealRegSingle 0)) -> pprReg r1 AddrRegReg r1 r2 @@ -258,110 +368,40 @@ pprInstr (NEWBLOCK _) pprInstr (LDATA _ _) = panic "PprMach.pprInstr: LDATA" -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] - - --- a clumsy hack for now, to handle possible double alignment problems --- even clumsier, to allow for RegReg regs that show when doing indexed --- reads (bytearrays). - --- Translate to the following: --- add g1,g2,g1 --- ld [g1],%fn --- ld [g1+4],%f(n+1) --- sub g1,g2,g1 -- to restore g1 - -pprInstr (LD FF64 (AddrRegReg g1 g2) reg) - = let Just regH = fPair reg - in vcat [ - hcat [ptext (sLit "\tadd\t"), pprReg g1, comma, pprReg g2, comma, pprReg g1], - hcat [pp_ld_lbracket, pprReg g1, pp_rbracket_comma, pprReg reg], - hcat [pp_ld_lbracket, pprReg g1, ptext (sLit "+4]"), comma, pprReg regH], - hcat [ptext (sLit "\tsub\t"), pprReg g1, comma, pprReg g2, comma, pprReg g1] - ] - --- Translate to --- ld [addr],%fn --- ld [addr+4],%f(n+1) -pprInstr (LD FF64 addr reg) - = let Just addr2 = addrOffset addr 4 - Just regH = fPair reg - in vcat [ - hcat [pp_ld_lbracket, pprAddr addr, pp_rbracket_comma, pprReg reg], - hcat [pp_ld_lbracket, pprAddr addr2, pp_rbracket_comma,pprReg regH] - ] +-- 64 bit FP loads are expanded into individual instructions in CodeGen.Expand +pprInstr (LD FF64 _ reg) + | RegReal (RealRegSingle{}) <- reg + = panic "SPARC.Ppr: not emitting potentially misaligned LD FF64 instr" - pprInstr (LD size addr reg) - = hcat [ - ptext (sLit "\tld"), - pprSize size, - char '\t', - lbrack, - pprAddr addr, - pp_rbracket_comma, - pprReg reg - ] - --- The same clumsy hack as above --- Translate to the following: --- add g1,g2,g1 --- st %fn,[g1] --- st %f(n+1),[g1+4] --- sub g1,g2,g1 -- to restore g1 - -pprInstr (ST FF64 reg (AddrRegReg g1 g2)) - = let Just regH = fPair reg - in vcat [ - hcat [ptext (sLit "\tadd\t"), pprReg g1, comma, pprReg g2, comma, pprReg g1], - hcat [ptext (sLit "\tst\t"), pprReg reg, pp_comma_lbracket, - pprReg g1, rbrack], - hcat [ptext (sLit "\tst\t"), pprReg regH, pp_comma_lbracket, - pprReg g1, ptext (sLit "+4]")], - hcat [ptext (sLit "\tsub\t"), pprReg g1, comma, pprReg g2, comma, pprReg g1] - ] - --- Translate to --- st %fn,[addr] --- st %f(n+1),[addr+4] -pprInstr (ST FF64 reg addr) - = let Just addr2 = addrOffset addr 4 - Just regH = fPair reg - in vcat [ - hcat [ptext (sLit "\tst\t"), pprReg reg, pp_comma_lbracket, - pprAddr addr, rbrack], - hcat [ptext (sLit "\tst\t"), pprReg regH, pp_comma_lbracket, - pprAddr addr2, rbrack] + = hcat [ + ptext (sLit "\tld"), + pprSize size, + char '\t', + lbrack, + pprAddr addr, + pp_rbracket_comma, + pprReg reg ] - + +-- 64 bit FP storees are expanded into individual instructions in CodeGen.Expand +pprInstr (ST FF64 reg _) + | RegReal (RealRegSingle{}) <- reg + = panic "SPARC.Ppr: not emitting potentially misaligned ST FF64 instr" -- no distinction is made between signed and unsigned bytes on stores for the -- Sparc opcodes (at least I cannot see any, and gas is nagging me --SOF), -- so we call a special-purpose pprSize for ST.. pprInstr (ST size reg addr) - = hcat [ - ptext (sLit "\tst"), - pprStSize size, - char '\t', - pprReg reg, - pp_comma_lbracket, - pprAddr addr, - rbrack - ] + = hcat [ + ptext (sLit "\tst"), + pprStSize size, + char '\t', + pprReg reg, + pp_comma_lbracket, + pprAddr addr, + rbrack + ] pprInstr (ADD x cc reg1 ri reg2) @@ -427,20 +467,11 @@ pprInstr (SETHI imm reg) pprReg reg ] -pprInstr NOP = ptext (sLit "\tnop") +pprInstr NOP + = ptext (sLit "\tnop") -pprInstr (FABS FF32 reg1 reg2) = pprSizeRegReg (sLit "fabs") FF32 reg1 reg2 -pprInstr (FABS FF64 reg1 reg2) - = let Just reg1H = fPair reg1 - Just reg2H = fPair reg2 - in - (<>) (pprSizeRegReg (sLit "fabs") FF32 reg1 reg2) - (if (reg1 == reg2) then empty - else (<>) (char '\n') - (pprSizeRegReg (sLit "fmov") FF32 reg1H reg2H)) - -pprInstr (FABS _ _ _) - =panic "SPARC.Ppr.pprInstr(FABS): no match" +pprInstr (FABS size reg1 reg2) + = pprSizeRegReg (sLit "fabs") size reg1 reg2 pprInstr (FADD size reg1 reg2 reg3) = pprSizeRegRegReg (sLit "fadd") size reg1 reg2 reg3 @@ -451,40 +482,14 @@ pprInstr (FCMP e size reg1 reg2) pprInstr (FDIV size reg1 reg2 reg3) = pprSizeRegRegReg (sLit "fdiv") size reg1 reg2 reg3 -pprInstr (FMOV FF32 reg1 reg2) = pprSizeRegReg (sLit "fmov") FF32 reg1 reg2 -pprInstr (FMOV FF64 reg1 reg2) = pprSizeRegReg (sLit "fmov") FF64 reg1 reg2 - -pprInstr (FMOV _ _ _) - = panic "SPARC.Ppr.pprInstr(FMOV): no match" - -{- -pprInstr (FMOV FF64 reg1 reg2) - = let Just reg1H = fPair reg1 - Just reg2H = fPair reg2 - in - (<>) (pprSizeRegReg (sLit "fmov") FF32 reg1 reg2) - (if (reg1 == reg2) then empty - else (<>) (char '\n') - (pprSizeRegReg (sLit "fmov") FF32 reg1H reg2H)) --} +pprInstr (FMOV size reg1 reg2) + = pprSizeRegReg (sLit "fmov") size reg1 reg2 pprInstr (FMUL size reg1 reg2 reg3) = pprSizeRegRegReg (sLit "fmul") size reg1 reg2 reg3 -pprInstr (FNEG FF32 reg1 reg2) - = pprSizeRegReg (sLit "fneg") FF32 reg1 reg2 - -pprInstr (FNEG FF64 reg1 reg2) - = let Just reg1H = fPair reg1 - Just reg2H = fPair reg2 - in - (<>) (pprSizeRegReg (sLit "fneg") FF32 reg1 reg2) - (if (reg1 == reg2) then empty - else (<>) (char '\n') - (pprSizeRegReg (sLit "fmov") FF32 reg1H reg2H)) - -pprInstr (FNEG _ _ _) - = panic "SPARC.Ppr.pprInstr(FNEG): no match" +pprInstr (FNEG size reg1 reg2) + = pprSizeRegReg (sLit "fneg") size reg1 reg2 pprInstr (FSQRT size reg1 reg2) = pprSizeRegReg (sLit "fsqrt") size reg1 reg2 @@ -512,27 +517,28 @@ pprInstr (FxTOy size1 size2 reg1 reg2) ] -pprInstr (BI cond b (BlockId id)) +pprInstr (BI cond b blockid) = hcat [ ptext (sLit "\tb"), pprCond cond, if b then pp_comma_a else empty, char '\t', - pprCLabel_asm (mkAsmTempLabel id) + pprCLabel_asm (mkAsmTempLabel (getUnique blockid)) ] -pprInstr (BF cond b (BlockId id)) +pprInstr (BF cond b blockid) = hcat [ ptext (sLit "\tfb"), pprCond cond, if b then pp_comma_a else empty, char '\t', - pprCLabel_asm (mkAsmTempLabel id) + pprCLabel_asm (mkAsmTempLabel (getUnique blockid)) ] pprInstr (JMP addr) = (<>) (ptext (sLit "\tjmp\t")) (pprAddr addr) -pprInstr (JMP_TBL op _) = pprInstr (JMP op) +pprInstr (JMP_TBL op _ _) = pprInstr (JMP op) pprInstr (CALL (Left imm) n _) = hcat [ ptext (sLit "\tcall\t"), pprImm imm, comma, int n ] + pprInstr (CALL (Right reg) n _) = hcat [ ptext (sLit "\tcall\t"), pprReg reg, comma, int n ] @@ -605,10 +611,10 @@ pprRIReg name b ri reg1 ] -} - +{- pp_ld_lbracket :: Doc pp_ld_lbracket = ptext (sLit "\tld\t[") - +-} pp_rbracket_comma :: Doc pp_rbracket_comma = text "],"