-----------------------------------------------------------------------------
module SPARC.Ppr (
- pprUserReg,
+ pprNatCmmTop,
+ pprBasicBlock,
+ pprSectionHeader,
+ pprData,
+ pprInstr,
pprSize,
pprImm,
- pprSectionHeader,
- pprDataItem,
- pprInstr
+ pprDataItem
)
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.
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.
II32 -> sLit ""
II64 -> sLit "x"
FF32 -> sLit ""
- FF64 -> sLit "d")
+ FF64 -> sLit "d"
+ _ -> panic "SPARC.Ppr.pprSize: no match")
-- | Pretty print a condition code.
pprAddr :: AddrMode -> Doc
pprAddr am
= case am of
- AddrRegReg r1 (RealReg 0)
+ AddrRegReg r1 (RegReal (RealRegSingle 0))
-> pprReg r1
AddrRegReg r1 r2
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)
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
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
]
-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 ]
]
-}
-
+{-
pp_ld_lbracket :: Doc
pp_ld_lbracket = ptext (sLit "\tld\t[")
-
+-}
pp_rbracket_comma :: Doc
pp_rbracket_comma = text "],"
projects / ghc-hetmet.git / blobdiff