RegsBase
Instrs
RegAllocInfo
+ PprMach
+ PprBase
Alpha.Regs
Alpha.RegInfo
Alpha.Instr
+ Alpha.Ppr
X86.Regs
X86.RegInfo
X86.Instr
+ X86.Ppr
PPC.Regs
PPC.RegInfo
PPC.Instr
+ PPC.Ppr
SPARC.Regs
SPARC.RegInfo
SPARC.Instr
+ SPARC.Ppr
NCGMonad
PositionIndependentCode
- PprMach
RegAlloc.Liveness
RegAlloc.Graph.Main
RegAlloc.Graph.Stats
--- /dev/null
+
+module Alpha.Ppr (
+{-
+ pprReg,
+ pprSize,
+ pprCond,
+ pprAddr,
+ pprSectionHeader,
+ pprTypeAndSizeDecl,
+ pprRI,
+ pprRegRIReg,
+ pprSizeRegRegReg
+-}
+)
+
+where
+
+{-
+#include "nativeGen/NCG.h"
+#include "HsVersions.h"
+
+import BlockId
+import Cmm
+import Regs -- may differ per-platform
+import Instrs
+
+import CLabel ( CLabel, pprCLabel, externallyVisibleCLabel,
+ labelDynamic, mkAsmTempLabel, entryLblToInfoLbl )
+
+#if HAVE_SUBSECTIONS_VIA_SYMBOLS
+import CLabel ( mkDeadStripPreventer )
+#endif
+
+import Panic ( panic )
+import Unique ( pprUnique )
+import Pretty
+import FastString
+import qualified Outputable
+import Outputable ( Outputable, pprPanic, ppr, docToSDoc)
+
+import Data.Array.ST
+import Data.Word ( Word8 )
+import Control.Monad.ST
+import Data.Char ( chr, ord )
+import Data.Maybe ( isJust )
+
+
+
+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)
+ where
+ ppr_reg_no :: Int -> Doc
+ ppr_reg_no i = ptext
+ (case i of {
+ 0 -> sLit "$0"; 1 -> sLit "$1";
+ 2 -> sLit "$2"; 3 -> sLit "$3";
+ 4 -> sLit "$4"; 5 -> sLit "$5";
+ 6 -> sLit "$6"; 7 -> sLit "$7";
+ 8 -> sLit "$8"; 9 -> sLit "$9";
+ 10 -> sLit "$10"; 11 -> sLit "$11";
+ 12 -> sLit "$12"; 13 -> sLit "$13";
+ 14 -> sLit "$14"; 15 -> sLit "$15";
+ 16 -> sLit "$16"; 17 -> sLit "$17";
+ 18 -> sLit "$18"; 19 -> sLit "$19";
+ 20 -> sLit "$20"; 21 -> sLit "$21";
+ 22 -> sLit "$22"; 23 -> sLit "$23";
+ 24 -> sLit "$24"; 25 -> sLit "$25";
+ 26 -> sLit "$26"; 27 -> sLit "$27";
+ 28 -> sLit "$28"; 29 -> sLit "$29";
+ 30 -> sLit "$30"; 31 -> sLit "$31";
+ 32 -> sLit "$f0"; 33 -> sLit "$f1";
+ 34 -> sLit "$f2"; 35 -> sLit "$f3";
+ 36 -> sLit "$f4"; 37 -> sLit "$f5";
+ 38 -> sLit "$f6"; 39 -> sLit "$f7";
+ 40 -> sLit "$f8"; 41 -> sLit "$f9";
+ 42 -> sLit "$f10"; 43 -> sLit "$f11";
+ 44 -> sLit "$f12"; 45 -> sLit "$f13";
+ 46 -> sLit "$f14"; 47 -> sLit "$f15";
+ 48 -> sLit "$f16"; 49 -> sLit "$f17";
+ 50 -> sLit "$f18"; 51 -> sLit "$f19";
+ 52 -> sLit "$f20"; 53 -> sLit "$f21";
+ 54 -> sLit "$f22"; 55 -> sLit "$f23";
+ 56 -> sLit "$f24"; 57 -> sLit "$f25";
+ 58 -> sLit "$f26"; 59 -> sLit "$f27";
+ 60 -> sLit "$f28"; 61 -> sLit "$f29";
+ 62 -> sLit "$f30"; 63 -> sLit "$f31";
+ _ -> sLit "very naughty alpha register"
+ })
+
+
+pprSize :: Size -> Doc
+pprSize x = ptext (case x of
+ B -> sLit "b"
+ Bu -> sLit "bu"
+-- W -> sLit "w" UNUSED
+-- Wu -> sLit "wu" UNUSED
+ L -> sLit "l"
+ Q -> sLit "q"
+-- FF -> sLit "f" UNUSED
+-- DF -> sLit "d" UNUSED
+-- GF -> sLit "g" UNUSED
+-- SF -> sLit "s" UNUSED
+ TF -> sLit "t"
+
+
+pprCond :: Cond -> Doc
+pprCond c
+ = ptext (case c of
+ EQQ -> sLit "eq"
+ LTT -> sLit "lt"
+ LE -> sLit "le"
+ ULT -> sLit "ult"
+ ULE -> sLit "ule"
+ NE -> sLit "ne"
+ GTT -> sLit "gt"
+ GE -> sLit "ge")
+
+
+pprAddr :: AddrMode -> Doc
+pprAddr (AddrReg r) = parens (pprReg r)
+pprAddr (AddrImm i) = pprImm i
+pprAddr (AddrRegImm r1 i)
+ = (<>) (pprImm i) (parens (pprReg r1))
+
+
+pprSectionHeader Text
+ = ptext (sLit "\t.text\n\t.align 3")
+
+pprSectionHeader Data
+ = ptext (sLit "\t.data\n\t.align 3")
+
+pprSectionHeader ReadOnlyData
+ = ptext (sLit "\t.data\n\t.align 3")
+
+pprSectionHeader RelocatableReadOnlyData
+ = ptext (sLit "\t.data\n\t.align 3")
+
+pprSectionHeader UninitialisedData
+ = ptext (sLit "\t.bss\n\t.align 3")
+
+pprSectionHeader ReadOnlyData16
+ = ptext (sLit "\t.data\n\t.align 4")
+
+pprSectionHeader (OtherSection sec)
+ = panic "PprMach.pprSectionHeader: unknown section"
+
+
+pprTypeAndSizeDecl :: CLabel -> Doc
+pprTypeAndSizeDecl lbl
+ = empty
+
+
+
+pprInstr :: Instr -> Doc
+pprInstr (COMMENT s) = 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(
+ ((<>) (ptext (sLit "# ")) (ftext s)),
+ ((<>) (ptext (sLit "; ")) (ftext s)))
+ ,)))))
+-}
+pprInstr (DELTA d)
+ = pprInstr (COMMENT (mkFastString ("\tdelta = " ++ show d)))
+
+pprInstr (NEWBLOCK _)
+ = panic "PprMach.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]
+
+pprInstr (LD size reg addr)
+ = hcat [
+ ptext (sLit "\tld"),
+ pprSize size,
+ char '\t',
+ pprReg reg,
+ comma,
+ pprAddr addr
+ ]
+
+pprInstr (LDA reg addr)
+ = hcat [
+ ptext (sLit "\tlda\t"),
+ pprReg reg,
+ comma,
+ pprAddr addr
+ ]
+
+pprInstr (LDAH reg addr)
+ = hcat [
+ ptext (sLit "\tldah\t"),
+ pprReg reg,
+ comma,
+ pprAddr addr
+ ]
+
+pprInstr (LDGP reg addr)
+ = hcat [
+ ptext (sLit "\tldgp\t"),
+ pprReg reg,
+ comma,
+ pprAddr addr
+ ]
+
+pprInstr (LDI size reg imm)
+ = hcat [
+ ptext (sLit "\tldi"),
+ pprSize size,
+ char '\t',
+ pprReg reg,
+ comma,
+ pprImm imm
+ ]
+
+pprInstr (ST size reg addr)
+ = hcat [
+ ptext (sLit "\tst"),
+ pprSize size,
+ char '\t',
+ pprReg reg,
+ comma,
+ pprAddr addr
+ ]
+
+pprInstr (CLR reg)
+ = hcat [
+ ptext (sLit "\tclr\t"),
+ pprReg reg
+ ]
+
+pprInstr (ABS size ri reg)
+ = hcat [
+ ptext (sLit "\tabs"),
+ pprSize size,
+ char '\t',
+ pprRI ri,
+ comma,
+ pprReg reg
+ ]
+
+pprInstr (NEG size ov ri reg)
+ = hcat [
+ ptext (sLit "\tneg"),
+ pprSize size,
+ if ov then ptext (sLit "v\t") else char '\t',
+ pprRI ri,
+ comma,
+ pprReg reg
+ ]
+
+pprInstr (ADD size ov reg1 ri reg2)
+ = hcat [
+ ptext (sLit "\tadd"),
+ pprSize size,
+ if ov then ptext (sLit "v\t") else char '\t',
+ pprReg reg1,
+ comma,
+ pprRI ri,
+ comma,
+ pprReg reg2
+ ]
+
+pprInstr (SADD size scale reg1 ri reg2)
+ = hcat [
+ ptext (case scale of {{-UNUSED:L -> (sLit "\ts4");-} Q -> (sLit "\ts8")}),
+ ptext (sLit "add"),
+ pprSize size,
+ char '\t',
+ pprReg reg1,
+ comma,
+ pprRI ri,
+ comma,
+ pprReg reg2
+ ]
+
+pprInstr (SUB size ov reg1 ri reg2)
+ = hcat [
+ ptext (sLit "\tsub"),
+ pprSize size,
+ if ov then ptext (sLit "v\t") else char '\t',
+ pprReg reg1,
+ comma,
+ pprRI ri,
+ comma,
+ pprReg reg2
+ ]
+
+pprInstr (SSUB size scale reg1 ri reg2)
+ = hcat [
+ ptext (case scale of {{-UNUSED:L -> (sLit "\ts4");-} Q -> (sLit "\ts8")}),
+ ptext (sLit "sub"),
+ pprSize size,
+ char '\t',
+ pprReg reg1,
+ comma,
+ pprRI ri,
+ comma,
+ pprReg reg2
+ ]
+
+pprInstr (MUL size ov reg1 ri reg2)
+ = hcat [
+ ptext (sLit "\tmul"),
+ pprSize size,
+ if ov then ptext (sLit "v\t") else char '\t',
+ pprReg reg1,
+ comma,
+ pprRI ri,
+ comma,
+ pprReg reg2
+ ]
+
+pprInstr (DIV size uns reg1 ri reg2)
+ = hcat [
+ ptext (sLit "\tdiv"),
+ pprSize size,
+ if uns then ptext (sLit "u\t") else char '\t',
+ pprReg reg1,
+ comma,
+ pprRI ri,
+ comma,
+ pprReg reg2
+ ]
+
+pprInstr (REM size uns reg1 ri reg2)
+ = hcat [
+ ptext (sLit "\trem"),
+ pprSize size,
+ if uns then ptext (sLit "u\t") else char '\t',
+ pprReg reg1,
+ comma,
+ pprRI ri,
+ comma,
+ pprReg reg2
+ ]
+
+pprInstr (NOT ri reg)
+ = hcat [
+ ptext (sLit "\tnot"),
+ char '\t',
+ pprRI ri,
+ comma,
+ pprReg reg
+ ]
+
+pprInstr (AND reg1 ri reg2) = pprRegRIReg (sLit "and") reg1 ri reg2
+pprInstr (ANDNOT reg1 ri reg2) = pprRegRIReg (sLit "andnot") reg1 ri reg2
+pprInstr (OR reg1 ri reg2) = pprRegRIReg (sLit "or") reg1 ri reg2
+pprInstr (ORNOT reg1 ri reg2) = pprRegRIReg (sLit "ornot") reg1 ri reg2
+pprInstr (XOR reg1 ri reg2) = pprRegRIReg (sLit "xor") reg1 ri reg2
+pprInstr (XORNOT reg1 ri reg2) = pprRegRIReg (sLit "xornot") reg1 ri reg2
+
+pprInstr (SLL reg1 ri reg2) = pprRegRIReg (sLit "sll") reg1 ri reg2
+pprInstr (SRL reg1 ri reg2) = pprRegRIReg (sLit "srl") reg1 ri reg2
+pprInstr (SRA reg1 ri reg2) = pprRegRIReg (sLit "sra") reg1 ri reg2
+
+pprInstr (ZAP reg1 ri reg2) = pprRegRIReg (sLit "zap") reg1 ri reg2
+pprInstr (ZAPNOT reg1 ri reg2) = pprRegRIReg (sLit "zapnot") reg1 ri reg2
+
+pprInstr (NOP) = ptext (sLit "\tnop")
+
+pprInstr (CMP cond reg1 ri reg2)
+ = hcat [
+ ptext (sLit "\tcmp"),
+ pprCond cond,
+ char '\t',
+ pprReg reg1,
+ comma,
+ pprRI ri,
+ comma,
+ pprReg reg2
+ ]
+
+pprInstr (FCLR reg)
+ = hcat [
+ ptext (sLit "\tfclr\t"),
+ pprReg reg
+ ]
+
+pprInstr (FABS reg1 reg2)
+ = hcat [
+ ptext (sLit "\tfabs\t"),
+ pprReg reg1,
+ comma,
+ pprReg reg2
+ ]
+
+pprInstr (FNEG size reg1 reg2)
+ = hcat [
+ ptext (sLit "\tneg"),
+ pprSize size,
+ char '\t',
+ pprReg reg1,
+ comma,
+ pprReg reg2
+ ]
+
+pprInstr (FADD size reg1 reg2 reg3) = pprSizeRegRegReg (sLit "add") size reg1 reg2 reg3
+pprInstr (FDIV size reg1 reg2 reg3) = pprSizeRegRegReg (sLit "div") size reg1 reg2 reg3
+pprInstr (FMUL size reg1 reg2 reg3) = pprSizeRegRegReg (sLit "mul") size reg1 reg2 reg3
+pprInstr (FSUB size reg1 reg2 reg3) = pprSizeRegRegReg (sLit "sub") size reg1 reg2 reg3
+
+pprInstr (CVTxy size1 size2 reg1 reg2)
+ = hcat [
+ ptext (sLit "\tcvt"),
+ pprSize size1,
+ case size2 of {Q -> ptext (sLit "qc"); _ -> pprSize size2},
+ char '\t',
+ pprReg reg1,
+ comma,
+ pprReg reg2
+ ]
+
+pprInstr (FCMP size cond reg1 reg2 reg3)
+ = hcat [
+ ptext (sLit "\tcmp"),
+ pprSize size,
+ pprCond cond,
+ char '\t',
+ pprReg reg1,
+ comma,
+ pprReg reg2,
+ comma,
+ pprReg reg3
+ ]
+
+pprInstr (FMOV reg1 reg2)
+ = hcat [
+ ptext (sLit "\tfmov\t"),
+ pprReg reg1,
+ comma,
+ pprReg reg2
+ ]
+
+pprInstr (BI ALWAYS reg lab) = pprInstr (BR lab)
+
+pprInstr (BI NEVER reg lab) = empty
+
+pprInstr (BI cond reg lab)
+ = hcat [
+ ptext (sLit "\tb"),
+ pprCond cond,
+ char '\t',
+ pprReg reg,
+ comma,
+ pprImm lab
+ ]
+
+pprInstr (BF cond reg lab)
+ = hcat [
+ ptext (sLit "\tfb"),
+ pprCond cond,
+ char '\t',
+ pprReg reg,
+ comma,
+ pprImm lab
+ ]
+
+pprInstr (BR lab)
+ = (<>) (ptext (sLit "\tbr\t")) (pprImm lab)
+
+pprInstr (JMP reg addr hint)
+ = hcat [
+ ptext (sLit "\tjmp\t"),
+ pprReg reg,
+ comma,
+ pprAddr addr,
+ comma,
+ int hint
+ ]
+
+pprInstr (BSR imm n)
+ = (<>) (ptext (sLit "\tbsr\t")) (pprImm imm)
+
+pprInstr (JSR reg addr n)
+ = hcat [
+ ptext (sLit "\tjsr\t"),
+ pprReg reg,
+ comma,
+ pprAddr addr
+ ]
+
+pprInstr (FUNBEGIN clab)
+ = hcat [
+ if (externallyVisibleCLabel clab) then
+ hcat [ptext (sLit "\t.globl\t"), pp_lab, char '\n']
+ else
+ empty,
+ ptext (sLit "\t.ent "),
+ pp_lab,
+ char '\n',
+ pp_lab,
+ pp_ldgp,
+ pp_lab,
+ pp_frame
+ ]
+ where
+ pp_lab = pprCLabel_asm clab
+
+ -- NEVER use commas within those string literals, cpp will ruin your day
+ pp_ldgp = hcat [ ptext (sLit ":\n\tldgp $29"), char ',', ptext (sLit "0($27)\n") ]
+ pp_frame = hcat [ ptext (sLit "..ng:\n\t.frame $30"), char ',',
+ ptext (sLit "4240"), char ',',
+ ptext (sLit "$26"), char ',',
+ ptext (sLit "0\n\t.prologue 1") ]
+
+pprInstr (FUNEND clab)
+ = (<>) (ptext (sLit "\t.align 4\n\t.end ")) (pprCLabel_asm clab)
+
+
+pprRI :: RI -> Doc
+
+pprRI (RIReg r) = pprReg r
+pprRI (RIImm r) = pprImm r
+
+pprRegRIReg :: LitString -> Reg -> RI -> Reg -> Doc
+pprRegRIReg name reg1 ri reg2
+ = hcat [
+ char '\t',
+ ptext name,
+ char '\t',
+ pprReg reg1,
+ comma,
+ pprRI ri,
+ comma,
+ pprReg reg2
+ ]
+
+pprSizeRegRegReg :: LitString -> Size -> Reg -> Reg -> Reg -> Doc
+pprSizeRegRegReg name size reg1 reg2 reg3
+ = hcat [
+ char '\t',
+ ptext name,
+ pprSize size,
+ char '\t',
+ pprReg reg1,
+ comma,
+ pprReg reg2,
+ comma,
+ pprReg reg3
+ ]
+
+-}
--- /dev/null
+-----------------------------------------------------------------------------
+--
+-- Pretty-printing assembly language
+--
+-- (c) The University of Glasgow 1993-2005
+--
+-----------------------------------------------------------------------------
+
+module PPC.Ppr (
+ pprUserReg,
+ pprSize,
+ pprImm,
+ pprSectionHeader,
+ pprDataItem,
+ pprInstr
+)
+
+where
+
+#include "nativeGen/NCG.h"
+#include "HsVersions.h"
+
+import RegsBase
+import PprBase
+import PPC.Regs
+import PPC.Instr
+
+import BlockId
+import Cmm
+
+import CLabel ( mkAsmTempLabel )
+
+import Unique ( pprUnique )
+import Pretty
+import FastString
+import qualified Outputable
+import Outputable ( panic )
+
+import Data.Word(Word32)
+import Data.Bits
+
+
+pprUserReg :: Reg -> Doc
+pprUserReg = pprReg
+
+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)
+ where
+#if darwin_TARGET_OS
+ ppr_reg_no :: Int -> Doc
+ ppr_reg_no i = ptext
+ (case i of {
+ 0 -> sLit "r0"; 1 -> sLit "r1";
+ 2 -> sLit "r2"; 3 -> sLit "r3";
+ 4 -> sLit "r4"; 5 -> sLit "r5";
+ 6 -> sLit "r6"; 7 -> sLit "r7";
+ 8 -> sLit "r8"; 9 -> sLit "r9";
+ 10 -> sLit "r10"; 11 -> sLit "r11";
+ 12 -> sLit "r12"; 13 -> sLit "r13";
+ 14 -> sLit "r14"; 15 -> sLit "r15";
+ 16 -> sLit "r16"; 17 -> sLit "r17";
+ 18 -> sLit "r18"; 19 -> sLit "r19";
+ 20 -> sLit "r20"; 21 -> sLit "r21";
+ 22 -> sLit "r22"; 23 -> sLit "r23";
+ 24 -> sLit "r24"; 25 -> sLit "r25";
+ 26 -> sLit "r26"; 27 -> sLit "r27";
+ 28 -> sLit "r28"; 29 -> sLit "r29";
+ 30 -> sLit "r30"; 31 -> sLit "r31";
+ 32 -> sLit "f0"; 33 -> sLit "f1";
+ 34 -> sLit "f2"; 35 -> sLit "f3";
+ 36 -> sLit "f4"; 37 -> sLit "f5";
+ 38 -> sLit "f6"; 39 -> sLit "f7";
+ 40 -> sLit "f8"; 41 -> sLit "f9";
+ 42 -> sLit "f10"; 43 -> sLit "f11";
+ 44 -> sLit "f12"; 45 -> sLit "f13";
+ 46 -> sLit "f14"; 47 -> sLit "f15";
+ 48 -> sLit "f16"; 49 -> sLit "f17";
+ 50 -> sLit "f18"; 51 -> sLit "f19";
+ 52 -> sLit "f20"; 53 -> sLit "f21";
+ 54 -> sLit "f22"; 55 -> sLit "f23";
+ 56 -> sLit "f24"; 57 -> sLit "f25";
+ 58 -> sLit "f26"; 59 -> sLit "f27";
+ 60 -> sLit "f28"; 61 -> sLit "f29";
+ 62 -> sLit "f30"; 63 -> sLit "f31";
+ _ -> sLit "very naughty powerpc register"
+ })
+#else
+ ppr_reg_no :: Int -> Doc
+ ppr_reg_no i | i <= 31 = int i -- GPRs
+ | i <= 63 = int (i-32) -- FPRs
+ | otherwise = ptext (sLit "very naughty powerpc register")
+#endif
+
+
+
+pprSize :: Size -> Doc
+pprSize x
+ = ptext (case x of
+ II8 -> sLit "b"
+ II16 -> sLit "h"
+ II32 -> sLit "w"
+ FF32 -> sLit "fs"
+ FF64 -> sLit "fd"
+ _ -> panic "PPC.Ppr.pprSize: no match")
+
+
+pprCond :: Cond -> Doc
+pprCond c
+ = ptext (case c of {
+ ALWAYS -> sLit "";
+ EQQ -> sLit "eq"; NE -> sLit "ne";
+ LTT -> sLit "lt"; GE -> sLit "ge";
+ GTT -> sLit "gt"; LE -> sLit "le";
+ LU -> sLit "lt"; GEU -> sLit "ge";
+ GU -> sLit "gt"; LEU -> sLit "le"; })
+
+
+pprImm :: Imm -> Doc
+
+pprImm (ImmInt i) = int i
+pprImm (ImmInteger i) = integer i
+pprImm (ImmCLbl l) = pprCLabel_asm l
+pprImm (ImmIndex l i) = pprCLabel_asm l <> char '+' <> int i
+pprImm (ImmLit s) = s
+
+pprImm (ImmFloat _) = ptext (sLit "naughty float immediate")
+pprImm (ImmDouble _) = ptext (sLit "naughty double immediate")
+
+pprImm (ImmConstantSum a b) = pprImm a <> char '+' <> pprImm b
+pprImm (ImmConstantDiff a b) = pprImm a <> char '-'
+ <> lparen <> pprImm b <> rparen
+
+#if darwin_TARGET_OS
+pprImm (LO i)
+ = hcat [ pp_lo, pprImm i, rparen ]
+ where
+ pp_lo = text "lo16("
+
+pprImm (HI i)
+ = hcat [ pp_hi, pprImm i, rparen ]
+ where
+ pp_hi = text "hi16("
+
+pprImm (HA i)
+ = hcat [ pp_ha, pprImm i, rparen ]
+ where
+ pp_ha = text "ha16("
+
+#else
+pprImm (LO i)
+ = pprImm i <> text "@l"
+
+pprImm (HI i)
+ = pprImm i <> text "@h"
+
+pprImm (HA i)
+ = pprImm i <> text "@ha"
+#endif
+
+
+
+pprAddr :: AddrMode -> Doc
+pprAddr (AddrRegReg r1 r2)
+ = pprReg r1 <+> ptext (sLit ", ") <+> pprReg r2
+
+pprAddr (AddrRegImm r1 (ImmInt i)) = hcat [ int i, char '(', pprReg r1, char ')' ]
+pprAddr (AddrRegImm r1 (ImmInteger i)) = hcat [ integer i, char '(', pprReg r1, char ')' ]
+pprAddr (AddrRegImm r1 imm) = hcat [ pprImm imm, char '(', pprReg r1, char ')' ]
+
+
+pprSectionHeader :: Section -> Doc
+#if darwin_TARGET_OS
+pprSectionHeader seg
+ = case seg of
+ Text -> ptext (sLit ".text\n.align 2")
+ Data -> ptext (sLit ".data\n.align 2")
+ ReadOnlyData -> ptext (sLit ".const\n.align 2")
+ RelocatableReadOnlyData -> ptext (sLit ".const_data\n.align 2")
+ UninitialisedData -> ptext (sLit ".const_data\n.align 2")
+ ReadOnlyData16 -> ptext (sLit ".const\n.align 4")
+ OtherSection _ -> panic "PprMach.pprSectionHeader: unknown section"
+
+#else
+pprSectionHeader seg
+ = case seg of
+ Text -> ptext (sLit ".text\n.align 2")
+ Data -> ptext (sLit ".data\n.align 2")
+ ReadOnlyData -> ptext (sLit ".section .rodata\n\t.align 2")
+ RelocatableReadOnlyData -> ptext (sLit ".data\n\t.align 2")
+ UninitialisedData -> ptext (sLit ".section .bss\n\t.align 2")
+ ReadOnlyData16 -> ptext (sLit ".section .rodata\n\t.align 4")
+ OtherSection _ -> panic "PprMach.pprSectionHeader: unknown section"
+
+#endif
+
+
+pprDataItem :: CmmLit -> Doc
+pprDataItem lit
+ = vcat (ppr_item (cmmTypeSize $ cmmLitType lit) lit)
+ where
+ imm = litToImm lit
+
+ ppr_item II8 _ = [ptext (sLit "\t.byte\t") <> pprImm imm]
+
+ ppr_item II32 _ = [ptext (sLit "\t.long\t") <> pprImm imm]
+
+ ppr_item FF32 (CmmFloat r _)
+ = let bs = floatToBytes (fromRational r)
+ in map (\b -> ptext (sLit "\t.byte\t") <> pprImm (ImmInt b)) bs
+
+ ppr_item FF64 (CmmFloat r _)
+ = let bs = doubleToBytes (fromRational r)
+ in map (\b -> ptext (sLit "\t.byte\t") <> pprImm (ImmInt b)) bs
+
+ ppr_item II16 _ = [ptext (sLit "\t.short\t") <> pprImm imm]
+
+ ppr_item II64 (CmmInt x _) =
+ [ptext (sLit "\t.long\t")
+ <> int (fromIntegral
+ (fromIntegral (x `shiftR` 32) :: Word32)),
+ ptext (sLit "\t.long\t")
+ <> int (fromIntegral (fromIntegral x :: Word32))]
+
+ ppr_item _ _
+ = panic "PPC.Ppr.pprDataItem: no match"
+
+
+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(
+ ((<>) (ptext (sLit "# ")) (ftext s)),
+ ((<>) (ptext (sLit "; ")) (ftext s)))
+ ,)))))
+-}
+pprInstr (DELTA d)
+ = pprInstr (COMMENT (mkFastString ("\tdelta = " ++ show d)))
+
+pprInstr (NEWBLOCK _)
+ = panic "PprMach.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]
+
+pprInstr (LD sz reg addr) = hcat [
+ char '\t',
+ ptext (sLit "l"),
+ ptext (case sz of
+ II8 -> sLit "bz"
+ II16 -> sLit "hz"
+ II32 -> sLit "wz"
+ FF32 -> sLit "fs"
+ FF64 -> sLit "fd"
+ _ -> panic "PPC.Ppr.pprInstr: no match"
+ ),
+ case addr of AddrRegImm _ _ -> empty
+ AddrRegReg _ _ -> char 'x',
+ char '\t',
+ pprReg reg,
+ ptext (sLit ", "),
+ pprAddr addr
+ ]
+pprInstr (LA sz reg addr) = hcat [
+ char '\t',
+ ptext (sLit "l"),
+ ptext (case sz of
+ II8 -> sLit "ba"
+ II16 -> sLit "ha"
+ II32 -> sLit "wa"
+ FF32 -> sLit "fs"
+ FF64 -> sLit "fd"
+ _ -> panic "PPC.Ppr.pprInstr: no match"
+ ),
+ case addr of AddrRegImm _ _ -> empty
+ AddrRegReg _ _ -> char 'x',
+ char '\t',
+ pprReg reg,
+ ptext (sLit ", "),
+ pprAddr addr
+ ]
+pprInstr (ST sz reg addr) = hcat [
+ char '\t',
+ ptext (sLit "st"),
+ pprSize sz,
+ case addr of AddrRegImm _ _ -> empty
+ AddrRegReg _ _ -> char 'x',
+ char '\t',
+ pprReg reg,
+ ptext (sLit ", "),
+ pprAddr addr
+ ]
+pprInstr (STU sz reg addr) = hcat [
+ char '\t',
+ ptext (sLit "st"),
+ pprSize sz,
+ ptext (sLit "u\t"),
+ case addr of AddrRegImm _ _ -> empty
+ AddrRegReg _ _ -> char 'x',
+ pprReg reg,
+ ptext (sLit ", "),
+ pprAddr addr
+ ]
+pprInstr (LIS reg imm) = hcat [
+ char '\t',
+ ptext (sLit "lis"),
+ char '\t',
+ pprReg reg,
+ ptext (sLit ", "),
+ pprImm imm
+ ]
+pprInstr (LI reg imm) = hcat [
+ char '\t',
+ ptext (sLit "li"),
+ char '\t',
+ pprReg reg,
+ ptext (sLit ", "),
+ pprImm imm
+ ]
+pprInstr (MR reg1 reg2)
+ | reg1 == reg2 = empty
+ | otherwise = hcat [
+ char '\t',
+ case regClass reg1 of
+ RcInteger -> ptext (sLit "mr")
+ _ -> ptext (sLit "fmr"),
+ char '\t',
+ pprReg reg1,
+ ptext (sLit ", "),
+ pprReg reg2
+ ]
+pprInstr (CMP sz reg ri) = hcat [
+ char '\t',
+ op,
+ char '\t',
+ pprReg reg,
+ ptext (sLit ", "),
+ pprRI ri
+ ]
+ where
+ op = hcat [
+ ptext (sLit "cmp"),
+ pprSize sz,
+ case ri of
+ RIReg _ -> empty
+ RIImm _ -> char 'i'
+ ]
+pprInstr (CMPL sz reg ri) = hcat [
+ char '\t',
+ op,
+ char '\t',
+ pprReg reg,
+ ptext (sLit ", "),
+ pprRI ri
+ ]
+ where
+ op = hcat [
+ ptext (sLit "cmpl"),
+ pprSize sz,
+ case ri of
+ RIReg _ -> empty
+ RIImm _ -> char 'i'
+ ]
+pprInstr (BCC cond (BlockId id)) = hcat [
+ char '\t',
+ ptext (sLit "b"),
+ pprCond cond,
+ char '\t',
+ pprCLabel_asm lbl
+ ]
+ where lbl = mkAsmTempLabel id
+
+pprInstr (BCCFAR cond (BlockId id)) = vcat [
+ hcat [
+ ptext (sLit "\tb"),
+ pprCond (condNegate cond),
+ ptext (sLit "\t$+8")
+ ],
+ hcat [
+ ptext (sLit "\tb\t"),
+ pprCLabel_asm lbl
+ ]
+ ]
+ where lbl = mkAsmTempLabel id
+
+pprInstr (JMP lbl) = hcat [ -- an alias for b that takes a CLabel
+ char '\t',
+ ptext (sLit "b"),
+ char '\t',
+ pprCLabel_asm lbl
+ ]
+
+pprInstr (MTCTR reg) = hcat [
+ char '\t',
+ ptext (sLit "mtctr"),
+ char '\t',
+ pprReg reg
+ ]
+pprInstr (BCTR _) = hcat [
+ char '\t',
+ ptext (sLit "bctr")
+ ]
+pprInstr (BL lbl _) = hcat [
+ ptext (sLit "\tbl\t"),
+ pprCLabel_asm lbl
+ ]
+pprInstr (BCTRL _) = hcat [
+ char '\t',
+ ptext (sLit "bctrl")
+ ]
+pprInstr (ADD reg1 reg2 ri) = pprLogic (sLit "add") reg1 reg2 ri
+pprInstr (ADDIS reg1 reg2 imm) = hcat [
+ char '\t',
+ ptext (sLit "addis"),
+ char '\t',
+ pprReg reg1,
+ ptext (sLit ", "),
+ pprReg reg2,
+ ptext (sLit ", "),
+ pprImm imm
+ ]
+
+pprInstr (ADDC reg1 reg2 reg3) = pprLogic (sLit "addc") reg1 reg2 (RIReg reg3)
+pprInstr (ADDE reg1 reg2 reg3) = pprLogic (sLit "adde") reg1 reg2 (RIReg reg3)
+pprInstr (SUBF reg1 reg2 reg3) = pprLogic (sLit "subf") reg1 reg2 (RIReg reg3)
+pprInstr (MULLW reg1 reg2 ri@(RIReg _)) = pprLogic (sLit "mullw") reg1 reg2 ri
+pprInstr (MULLW reg1 reg2 ri@(RIImm _)) = pprLogic (sLit "mull") reg1 reg2 ri
+pprInstr (DIVW reg1 reg2 reg3) = pprLogic (sLit "divw") reg1 reg2 (RIReg reg3)
+pprInstr (DIVWU reg1 reg2 reg3) = pprLogic (sLit "divwu") reg1 reg2 (RIReg reg3)
+
+pprInstr (MULLW_MayOflo reg1 reg2 reg3) = vcat [
+ hcat [ ptext (sLit "\tmullwo\t"), pprReg reg1, ptext (sLit ", "),
+ pprReg reg2, ptext (sLit ", "),
+ pprReg reg3 ],
+ hcat [ ptext (sLit "\tmfxer\t"), pprReg reg1 ],
+ hcat [ ptext (sLit "\trlwinm\t"), pprReg reg1, ptext (sLit ", "),
+ pprReg reg1, ptext (sLit ", "),
+ ptext (sLit "2, 31, 31") ]
+ ]
+
+ -- for some reason, "andi" doesn't exist.
+ -- we'll use "andi." instead.
+pprInstr (AND reg1 reg2 (RIImm imm)) = hcat [
+ char '\t',
+ ptext (sLit "andi."),
+ char '\t',
+ pprReg reg1,
+ ptext (sLit ", "),
+ pprReg reg2,
+ ptext (sLit ", "),
+ pprImm imm
+ ]
+pprInstr (AND reg1 reg2 ri) = pprLogic (sLit "and") reg1 reg2 ri
+
+pprInstr (OR reg1 reg2 ri) = pprLogic (sLit "or") reg1 reg2 ri
+pprInstr (XOR reg1 reg2 ri) = pprLogic (sLit "xor") reg1 reg2 ri
+
+pprInstr (XORIS reg1 reg2 imm) = hcat [
+ char '\t',
+ ptext (sLit "xoris"),
+ char '\t',
+ pprReg reg1,
+ ptext (sLit ", "),
+ pprReg reg2,
+ ptext (sLit ", "),
+ pprImm imm
+ ]
+
+pprInstr (EXTS sz reg1 reg2) = hcat [
+ char '\t',
+ ptext (sLit "exts"),
+ pprSize sz,
+ char '\t',
+ pprReg reg1,
+ ptext (sLit ", "),
+ pprReg reg2
+ ]
+
+pprInstr (NEG reg1 reg2) = pprUnary (sLit "neg") reg1 reg2
+pprInstr (NOT reg1 reg2) = pprUnary (sLit "not") reg1 reg2
+
+pprInstr (SLW reg1 reg2 ri) = pprLogic (sLit "slw") reg1 reg2 (limitShiftRI ri)
+pprInstr (SRW reg1 reg2 ri) = pprLogic (sLit "srw") reg1 reg2 (limitShiftRI ri)
+pprInstr (SRAW reg1 reg2 ri) = pprLogic (sLit "sraw") reg1 reg2 (limitShiftRI ri)
+pprInstr (RLWINM reg1 reg2 sh mb me) = hcat [
+ ptext (sLit "\trlwinm\t"),
+ pprReg reg1,
+ ptext (sLit ", "),
+ pprReg reg2,
+ ptext (sLit ", "),
+ int sh,
+ ptext (sLit ", "),
+ int mb,
+ ptext (sLit ", "),
+ int me
+ ]
+
+pprInstr (FADD sz reg1 reg2 reg3) = pprBinaryF (sLit "fadd") sz reg1 reg2 reg3
+pprInstr (FSUB sz reg1 reg2 reg3) = pprBinaryF (sLit "fsub") sz reg1 reg2 reg3
+pprInstr (FMUL sz reg1 reg2 reg3) = pprBinaryF (sLit "fmul") sz reg1 reg2 reg3
+pprInstr (FDIV sz reg1 reg2 reg3) = pprBinaryF (sLit "fdiv") sz reg1 reg2 reg3
+pprInstr (FNEG reg1 reg2) = pprUnary (sLit "fneg") reg1 reg2
+
+pprInstr (FCMP reg1 reg2) = hcat [
+ char '\t',
+ ptext (sLit "fcmpu\tcr0, "),
+ -- Note: we're using fcmpu, not fcmpo
+ -- The difference is with fcmpo, compare with NaN is an invalid operation.
+ -- We don't handle invalid fp ops, so we don't care
+ pprReg reg1,
+ ptext (sLit ", "),
+ pprReg reg2
+ ]
+
+pprInstr (FCTIWZ reg1 reg2) = pprUnary (sLit "fctiwz") reg1 reg2
+pprInstr (FRSP reg1 reg2) = pprUnary (sLit "frsp") reg1 reg2
+
+pprInstr (CRNOR dst src1 src2) = hcat [
+ ptext (sLit "\tcrnor\t"),
+ int dst,
+ ptext (sLit ", "),
+ int src1,
+ ptext (sLit ", "),
+ int src2
+ ]
+
+pprInstr (MFCR reg) = hcat [
+ char '\t',
+ ptext (sLit "mfcr"),
+ char '\t',
+ pprReg reg
+ ]
+
+pprInstr (MFLR reg) = hcat [
+ char '\t',
+ ptext (sLit "mflr"),
+ char '\t',
+ pprReg reg
+ ]
+
+pprInstr (FETCHPC reg) = vcat [
+ ptext (sLit "\tbcl\t20,31,1f"),
+ hcat [ ptext (sLit "1:\tmflr\t"), pprReg reg ]
+ ]
+
+pprInstr LWSYNC = ptext (sLit "\tlwsync")
+
+-- pprInstr _ = panic "pprInstr (ppc)"
+
+
+pprLogic :: LitString -> Reg -> Reg -> RI -> Doc
+pprLogic op reg1 reg2 ri = hcat [
+ char '\t',
+ ptext op,
+ case ri of
+ RIReg _ -> empty
+ RIImm _ -> char 'i',
+ char '\t',
+ pprReg reg1,
+ ptext (sLit ", "),
+ pprReg reg2,
+ ptext (sLit ", "),
+ pprRI ri
+ ]
+
+
+pprUnary :: LitString -> Reg -> Reg -> Doc
+pprUnary op reg1 reg2 = hcat [
+ char '\t',
+ ptext op,
+ char '\t',
+ pprReg reg1,
+ ptext (sLit ", "),
+ pprReg reg2
+ ]
+
+
+pprBinaryF :: LitString -> Size -> Reg -> Reg -> Reg -> Doc
+pprBinaryF op sz reg1 reg2 reg3 = hcat [
+ char '\t',
+ ptext op,
+ pprFSize sz,
+ char '\t',
+ pprReg reg1,
+ ptext (sLit ", "),
+ pprReg reg2,
+ ptext (sLit ", "),
+ pprReg reg3
+ ]
+
+pprRI :: RI -> Doc
+pprRI (RIReg r) = pprReg r
+pprRI (RIImm r) = pprImm r
+
+
+pprFSize :: Size -> Doc
+pprFSize FF64 = empty
+pprFSize FF32 = char 's'
+pprFSize _ = panic "PPC.Ppr.pprFSize: no match"
+
+ -- limit immediate argument for shift instruction to range 0..32
+ -- (yes, the maximum is really 32, not 31)
+limitShiftRI :: RI -> RI
+limitShiftRI (RIImm (ImmInt i)) | i > 32 || i < 0 = RIImm (ImmInt 32)
+limitShiftRI x = x
+
--- /dev/null
+-----------------------------------------------------------------------------
+--
+-- Pretty-printing assembly language
+--
+-- (c) The University of Glasgow 1993-2005
+--
+-----------------------------------------------------------------------------
+
+module PprBase (
+ asmSDoc,
+ pprCLabel_asm,
+ castFloatToWord8Array,
+ castDoubleToWord8Array,
+ floatToBytes,
+ doubleToBytes
+)
+
+where
+
+import qualified Outputable
+import CLabel
+import Pretty
+
+import Data.Array.ST
+import Control.Monad.ST
+
+import Data.Word
+
+
+
+asmSDoc :: Outputable.SDoc -> Doc
+asmSDoc d
+ = Outputable.withPprStyleDoc (Outputable.mkCodeStyle Outputable.AsmStyle) d
+
+
+pprCLabel_asm :: CLabel -> Doc
+pprCLabel_asm l
+ = asmSDoc (pprCLabel l)
+
+
+-- -----------------------------------------------------------------------------
+-- Converting floating-point literals to integrals for printing
+
+castFloatToWord8Array :: STUArray s Int Float -> ST s (STUArray s Int Word8)
+castFloatToWord8Array = castSTUArray
+
+castDoubleToWord8Array :: STUArray s Int Double -> ST s (STUArray s Int Word8)
+castDoubleToWord8Array = castSTUArray
+
+-- floatToBytes and doubleToBytes convert to the host's byte
+-- order. Providing that we're not cross-compiling for a
+-- target with the opposite endianness, this should work ok
+-- on all targets.
+
+-- ToDo: this stuff is very similar to the shenanigans in PprAbs,
+-- could they be merged?
+
+floatToBytes :: Float -> [Int]
+floatToBytes f
+ = runST (do
+ arr <- newArray_ ((0::Int),3)
+ writeArray arr 0 f
+ arr <- castFloatToWord8Array arr
+ i0 <- readArray arr 0
+ i1 <- readArray arr 1
+ i2 <- readArray arr 2
+ i3 <- readArray arr 3
+ return (map fromIntegral [i0,i1,i2,i3])
+ )
+
+doubleToBytes :: Double -> [Int]
+doubleToBytes d
+ = runST (do
+ arr <- newArray_ ((0::Int),7)
+ writeArray arr 0 d
+ arr <- castDoubleToWord8Array arr
+ i0 <- readArray arr 0
+ i1 <- readArray arr 1
+ i2 <- readArray arr 2
+ i3 <- readArray arr 3
+ i4 <- readArray arr 4
+ i5 <- readArray arr 5
+ i6 <- readArray arr 6
+ i7 <- readArray arr 7
+ return (map fromIntegral [i0,i1,i2,i3,i4,i5,i6,i7])
+ )
#include "HsVersions.h"
+import PprBase
+
import BlockId
import Cmm
import Regs -- may differ per-platform
import Data.Char ( chr, ord )
import Data.Maybe ( isJust )
-#if powerpc_TARGET_ARCH || darwin_TARGET_OS
-import Data.Word(Word32)
-import Data.Bits
+
+#if alpha_TARGET_ARCH
+import Alpha.Ppr
+#elif powerpc_TARGET_ARCH
+import PPC.Ppr
+#elif i386_TARGET_ARCH || x86_64_TARGET_ARCH
+import X86.Ppr
+#elif sparc_TARGET_ARCH
+import SPARC.Ppr
+#else
+#error "Regs: not defined for this architecture"
#endif
+
+
-- -----------------------------------------------------------------------------
-- Printing this stuff out
-asmSDoc d = Outputable.withPprStyleDoc (
- Outputable.mkCodeStyle Outputable.AsmStyle) d
-pprCLabel_asm l = asmSDoc (pprCLabel l)
-
pprNatCmmTop :: NatCmmTop -> Doc
pprNatCmmTop (CmmData section dats) =
pprSectionHeader section $$ vcat (map pprData dats)
pprLabel (mkAsmTempLabel id) $$
vcat (map pprInstr instrs)
--- -----------------------------------------------------------------------------
--- pprReg: print a 'Reg'
-
--- For x86, the way we print a register name depends
--- on which bit of it we care about. Yurgh.
-
-pprUserReg :: Reg -> Doc
-pprUserReg = pprReg IF_ARCH_i386(II32,) IF_ARCH_x86_64(II64,)
-
-pprReg :: IF_ARCH_i386(Size ->,) IF_ARCH_x86_64(Size ->,) Reg -> Doc
-
-pprReg IF_ARCH_i386(s,) IF_ARCH_x86_64(s,) r
- = case r of
- RealReg i -> ppr_reg_no IF_ARCH_i386(s,) IF_ARCH_x86_64(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)
- where
-#if alpha_TARGET_ARCH
- ppr_reg_no :: Int -> Doc
- ppr_reg_no i = ptext
- (case i of {
- 0 -> sLit "$0"; 1 -> sLit "$1";
- 2 -> sLit "$2"; 3 -> sLit "$3";
- 4 -> sLit "$4"; 5 -> sLit "$5";
- 6 -> sLit "$6"; 7 -> sLit "$7";
- 8 -> sLit "$8"; 9 -> sLit "$9";
- 10 -> sLit "$10"; 11 -> sLit "$11";
- 12 -> sLit "$12"; 13 -> sLit "$13";
- 14 -> sLit "$14"; 15 -> sLit "$15";
- 16 -> sLit "$16"; 17 -> sLit "$17";
- 18 -> sLit "$18"; 19 -> sLit "$19";
- 20 -> sLit "$20"; 21 -> sLit "$21";
- 22 -> sLit "$22"; 23 -> sLit "$23";
- 24 -> sLit "$24"; 25 -> sLit "$25";
- 26 -> sLit "$26"; 27 -> sLit "$27";
- 28 -> sLit "$28"; 29 -> sLit "$29";
- 30 -> sLit "$30"; 31 -> sLit "$31";
- 32 -> sLit "$f0"; 33 -> sLit "$f1";
- 34 -> sLit "$f2"; 35 -> sLit "$f3";
- 36 -> sLit "$f4"; 37 -> sLit "$f5";
- 38 -> sLit "$f6"; 39 -> sLit "$f7";
- 40 -> sLit "$f8"; 41 -> sLit "$f9";
- 42 -> sLit "$f10"; 43 -> sLit "$f11";
- 44 -> sLit "$f12"; 45 -> sLit "$f13";
- 46 -> sLit "$f14"; 47 -> sLit "$f15";
- 48 -> sLit "$f16"; 49 -> sLit "$f17";
- 50 -> sLit "$f18"; 51 -> sLit "$f19";
- 52 -> sLit "$f20"; 53 -> sLit "$f21";
- 54 -> sLit "$f22"; 55 -> sLit "$f23";
- 56 -> sLit "$f24"; 57 -> sLit "$f25";
- 58 -> sLit "$f26"; 59 -> sLit "$f27";
- 60 -> sLit "$f28"; 61 -> sLit "$f29";
- 62 -> sLit "$f30"; 63 -> sLit "$f31";
- _ -> sLit "very naughty alpha register"
- })
-#endif
-#if i386_TARGET_ARCH
- ppr_reg_no :: Size -> Int -> Doc
- ppr_reg_no II8 = ppr_reg_byte
- ppr_reg_no II16 = ppr_reg_word
- ppr_reg_no _ = ppr_reg_long
-
- ppr_reg_byte i = ptext
- (case i of {
- 0 -> sLit "%al"; 1 -> sLit "%bl";
- 2 -> sLit "%cl"; 3 -> sLit "%dl";
- _ -> sLit "very naughty I386 byte register"
- })
-
- ppr_reg_word i = ptext
- (case i of {
- 0 -> sLit "%ax"; 1 -> sLit "%bx";
- 2 -> sLit "%cx"; 3 -> sLit "%dx";
- 4 -> sLit "%si"; 5 -> sLit "%di";
- 6 -> sLit "%bp"; 7 -> sLit "%sp";
- _ -> sLit "very naughty I386 word register"
- })
-
- ppr_reg_long i = ptext
- (case i of {
- 0 -> sLit "%eax"; 1 -> sLit "%ebx";
- 2 -> sLit "%ecx"; 3 -> sLit "%edx";
- 4 -> sLit "%esi"; 5 -> sLit "%edi";
- 6 -> sLit "%ebp"; 7 -> sLit "%esp";
- 8 -> sLit "%fake0"; 9 -> sLit "%fake1";
- 10 -> sLit "%fake2"; 11 -> sLit "%fake3";
- 12 -> sLit "%fake4"; 13 -> sLit "%fake5";
- _ -> sLit "very naughty I386 register"
- })
-#endif
-
-#if x86_64_TARGET_ARCH
- ppr_reg_no :: Size -> Int -> Doc
- ppr_reg_no II8 = ppr_reg_byte
- ppr_reg_no II16 = ppr_reg_word
- ppr_reg_no II32 = ppr_reg_long
- ppr_reg_no _ = ppr_reg_quad
-
- ppr_reg_byte i = ptext
- (case i of {
- 0 -> sLit "%al"; 1 -> sLit "%bl";
- 2 -> sLit "%cl"; 3 -> sLit "%dl";
- 4 -> sLit "%sil"; 5 -> sLit "%dil"; -- new 8-bit regs!
- 6 -> sLit "%bpl"; 7 -> sLit "%spl";
- 8 -> sLit "%r8b"; 9 -> sLit "%r9b";
- 10 -> sLit "%r10b"; 11 -> sLit "%r11b";
- 12 -> sLit "%r12b"; 13 -> sLit "%r13b";
- 14 -> sLit "%r14b"; 15 -> sLit "%r15b";
- _ -> sLit "very naughty x86_64 byte register"
- })
-
- ppr_reg_word i = ptext
- (case i of {
- 0 -> sLit "%ax"; 1 -> sLit "%bx";
- 2 -> sLit "%cx"; 3 -> sLit "%dx";
- 4 -> sLit "%si"; 5 -> sLit "%di";
- 6 -> sLit "%bp"; 7 -> sLit "%sp";
- 8 -> sLit "%r8w"; 9 -> sLit "%r9w";
- 10 -> sLit "%r10w"; 11 -> sLit "%r11w";
- 12 -> sLit "%r12w"; 13 -> sLit "%r13w";
- 14 -> sLit "%r14w"; 15 -> sLit "%r15w";
- _ -> sLit "very naughty x86_64 word register"
- })
-
- ppr_reg_long i = ptext
- (case i of {
- 0 -> sLit "%eax"; 1 -> sLit "%ebx";
- 2 -> sLit "%ecx"; 3 -> sLit "%edx";
- 4 -> sLit "%esi"; 5 -> sLit "%edi";
- 6 -> sLit "%ebp"; 7 -> sLit "%esp";
- 8 -> sLit "%r8d"; 9 -> sLit "%r9d";
- 10 -> sLit "%r10d"; 11 -> sLit "%r11d";
- 12 -> sLit "%r12d"; 13 -> sLit "%r13d";
- 14 -> sLit "%r14d"; 15 -> sLit "%r15d";
- _ -> sLit "very naughty x86_64 register"
- })
-
- ppr_reg_quad i = ptext
- (case i of {
- 0 -> sLit "%rax"; 1 -> sLit "%rbx";
- 2 -> sLit "%rcx"; 3 -> sLit "%rdx";
- 4 -> sLit "%rsi"; 5 -> sLit "%rdi";
- 6 -> sLit "%rbp"; 7 -> sLit "%rsp";
- 8 -> sLit "%r8"; 9 -> sLit "%r9";
- 10 -> sLit "%r10"; 11 -> sLit "%r11";
- 12 -> sLit "%r12"; 13 -> sLit "%r13";
- 14 -> sLit "%r14"; 15 -> sLit "%r15";
- 16 -> sLit "%xmm0"; 17 -> sLit "%xmm1";
- 18 -> sLit "%xmm2"; 19 -> sLit "%xmm3";
- 20 -> sLit "%xmm4"; 21 -> sLit "%xmm5";
- 22 -> sLit "%xmm6"; 23 -> sLit "%xmm7";
- 24 -> sLit "%xmm8"; 25 -> sLit "%xmm9";
- 26 -> sLit "%xmm10"; 27 -> sLit "%xmm11";
- 28 -> sLit "%xmm12"; 29 -> sLit "%xmm13";
- 30 -> sLit "%xmm14"; 31 -> sLit "%xmm15";
- _ -> sLit "very naughty x86_64 register"
- })
-#endif
-
-#if sparc_TARGET_ARCH
- ppr_reg_no :: Int -> Doc
- ppr_reg_no i = ptext
- (case i of {
- 0 -> sLit "%g0"; 1 -> sLit "%g1";
- 2 -> sLit "%g2"; 3 -> sLit "%g3";
- 4 -> sLit "%g4"; 5 -> sLit "%g5";
- 6 -> sLit "%g6"; 7 -> sLit "%g7";
- 8 -> sLit "%o0"; 9 -> sLit "%o1";
- 10 -> sLit "%o2"; 11 -> sLit "%o3";
- 12 -> sLit "%o4"; 13 -> sLit "%o5";
- 14 -> sLit "%o6"; 15 -> sLit "%o7";
- 16 -> sLit "%l0"; 17 -> sLit "%l1";
- 18 -> sLit "%l2"; 19 -> sLit "%l3";
- 20 -> sLit "%l4"; 21 -> sLit "%l5";
- 22 -> sLit "%l6"; 23 -> sLit "%l7";
- 24 -> sLit "%i0"; 25 -> sLit "%i1";
- 26 -> sLit "%i2"; 27 -> sLit "%i3";
- 28 -> sLit "%i4"; 29 -> sLit "%i5";
- 30 -> sLit "%i6"; 31 -> sLit "%i7";
- 32 -> sLit "%f0"; 33 -> sLit "%f1";
- 34 -> sLit "%f2"; 35 -> sLit "%f3";
- 36 -> sLit "%f4"; 37 -> sLit "%f5";
- 38 -> sLit "%f6"; 39 -> sLit "%f7";
- 40 -> sLit "%f8"; 41 -> sLit "%f9";
- 42 -> sLit "%f10"; 43 -> sLit "%f11";
- 44 -> sLit "%f12"; 45 -> sLit "%f13";
- 46 -> sLit "%f14"; 47 -> sLit "%f15";
- 48 -> sLit "%f16"; 49 -> sLit "%f17";
- 50 -> sLit "%f18"; 51 -> sLit "%f19";
- 52 -> sLit "%f20"; 53 -> sLit "%f21";
- 54 -> sLit "%f22"; 55 -> sLit "%f23";
- 56 -> sLit "%f24"; 57 -> sLit "%f25";
- 58 -> sLit "%f26"; 59 -> sLit "%f27";
- 60 -> sLit "%f28"; 61 -> sLit "%f29";
- 62 -> sLit "%f30"; 63 -> sLit "%f31";
- _ -> sLit "very naughty sparc register"
- })
-#endif
-#if powerpc_TARGET_ARCH
-#if darwin_TARGET_OS
- ppr_reg_no :: Int -> Doc
- ppr_reg_no i = ptext
- (case i of {
- 0 -> sLit "r0"; 1 -> sLit "r1";
- 2 -> sLit "r2"; 3 -> sLit "r3";
- 4 -> sLit "r4"; 5 -> sLit "r5";
- 6 -> sLit "r6"; 7 -> sLit "r7";
- 8 -> sLit "r8"; 9 -> sLit "r9";
- 10 -> sLit "r10"; 11 -> sLit "r11";
- 12 -> sLit "r12"; 13 -> sLit "r13";
- 14 -> sLit "r14"; 15 -> sLit "r15";
- 16 -> sLit "r16"; 17 -> sLit "r17";
- 18 -> sLit "r18"; 19 -> sLit "r19";
- 20 -> sLit "r20"; 21 -> sLit "r21";
- 22 -> sLit "r22"; 23 -> sLit "r23";
- 24 -> sLit "r24"; 25 -> sLit "r25";
- 26 -> sLit "r26"; 27 -> sLit "r27";
- 28 -> sLit "r28"; 29 -> sLit "r29";
- 30 -> sLit "r30"; 31 -> sLit "r31";
- 32 -> sLit "f0"; 33 -> sLit "f1";
- 34 -> sLit "f2"; 35 -> sLit "f3";
- 36 -> sLit "f4"; 37 -> sLit "f5";
- 38 -> sLit "f6"; 39 -> sLit "f7";
- 40 -> sLit "f8"; 41 -> sLit "f9";
- 42 -> sLit "f10"; 43 -> sLit "f11";
- 44 -> sLit "f12"; 45 -> sLit "f13";
- 46 -> sLit "f14"; 47 -> sLit "f15";
- 48 -> sLit "f16"; 49 -> sLit "f17";
- 50 -> sLit "f18"; 51 -> sLit "f19";
- 52 -> sLit "f20"; 53 -> sLit "f21";
- 54 -> sLit "f22"; 55 -> sLit "f23";
- 56 -> sLit "f24"; 57 -> sLit "f25";
- 58 -> sLit "f26"; 59 -> sLit "f27";
- 60 -> sLit "f28"; 61 -> sLit "f29";
- 62 -> sLit "f30"; 63 -> sLit "f31";
- _ -> sLit "very naughty powerpc register"
- })
-#else
- ppr_reg_no :: Int -> Doc
- ppr_reg_no i | i <= 31 = int i -- GPRs
- | i <= 63 = int (i-32) -- FPRs
- | otherwise = ptext (sLit "very naughty powerpc register")
-#endif
-#endif
-
-
--- -----------------------------------------------------------------------------
--- | print a 'Size'
--- Used for instruction suffixes.
--- eg LD is 32bit on sparc, but LDD is 64 bit.
---
-
-#if powerpc_TARGET_ARCH || i386_TARGET_ARCH || x86_64_TARGET_ARCH || sparc_TARGET_ARCH
-pprSize :: Size -> Doc
-#else
-pprSize :: Size -> Doc
-#endif
-
-pprSize x = ptext (case x of
-#if alpha_TARGET_ARCH
- B -> sLit "b"
- Bu -> sLit "bu"
--- W -> sLit "w" UNUSED
--- Wu -> sLit "wu" UNUSED
- L -> sLit "l"
- Q -> sLit "q"
--- FF -> sLit "f" UNUSED
--- DF -> sLit "d" UNUSED
--- GF -> sLit "g" UNUSED
--- SF -> sLit "s" UNUSED
- TF -> sLit "t"
-#endif
-#if i386_TARGET_ARCH || x86_64_TARGET_ARCH
- II8 -> sLit "b"
- II16 -> sLit "w"
- II32 -> sLit "l"
- II64 -> sLit "q"
-#endif
-#if i386_TARGET_ARCH
- FF32 -> sLit "s"
- FF64 -> sLit "l"
- FF80 -> sLit "t"
-#endif
-#if x86_64_TARGET_ARCH
- FF32 -> sLit "ss" -- "scalar single-precision float" (SSE2)
- FF64 -> sLit "sd" -- "scalar double-precision float" (SSE2)
-#endif
-#if sparc_TARGET_ARCH
- II8 -> sLit "ub"
- II16 -> sLit "uh"
- II32 -> sLit ""
- II64 -> sLit "d"
- FF32 -> sLit ""
- FF64 -> sLit "d"
- )
-
--- suffix to store/ ST instruction
-pprStSize :: Size -> Doc
-pprStSize x = ptext (case x of
- II8 -> sLit "b"
- II16 -> sLit "h"
- II32 -> sLit ""
- II64 -> sLit "x"
- FF32 -> sLit ""
- FF64 -> sLit "d"
-#endif
-#if powerpc_TARGET_ARCH
- II8 -> sLit "b"
- II16 -> sLit "h"
- II32 -> sLit "w"
- FF32 -> sLit "fs"
- FF64 -> sLit "fd"
-#endif
- )
-
--- -----------------------------------------------------------------------------
--- pprCond: print a 'Cond'
-
-pprCond :: Cond -> Doc
-
-pprCond c = ptext (case c of {
-#if alpha_TARGET_ARCH
- EQQ -> sLit "eq";
- LTT -> sLit "lt";
- LE -> sLit "le";
- ULT -> sLit "ult";
- ULE -> sLit "ule";
- NE -> sLit "ne";
- GTT -> sLit "gt";
- GE -> sLit "ge"
-#endif
-#if i386_TARGET_ARCH || x86_64_TARGET_ARCH
- GEU -> sLit "ae"; LU -> sLit "b";
- EQQ -> sLit "e"; GTT -> sLit "g";
- GE -> sLit "ge"; GU -> sLit "a";
- LTT -> sLit "l"; LE -> sLit "le";
- LEU -> sLit "be"; NE -> sLit "ne";
- NEG -> sLit "s"; POS -> sLit "ns";
- CARRY -> sLit "c"; OFLO -> sLit "o";
- PARITY -> sLit "p"; NOTPARITY -> sLit "np";
- ALWAYS -> sLit "mp" -- hack
-#endif
-#if sparc_TARGET_ARCH
- ALWAYS -> sLit ""; NEVER -> sLit "n";
- GEU -> sLit "geu"; LU -> sLit "lu";
- EQQ -> sLit "e"; GTT -> sLit "g";
- GE -> sLit "ge"; GU -> sLit "gu";
- LTT -> sLit "l"; LE -> sLit "le";
- LEU -> sLit "leu"; NE -> sLit "ne";
- NEG -> sLit "neg"; POS -> sLit "pos";
- VC -> sLit "vc"; VS -> sLit "vs"
-#endif
-#if powerpc_TARGET_ARCH
- ALWAYS -> sLit "";
- EQQ -> sLit "eq"; NE -> sLit "ne";
- LTT -> sLit "lt"; GE -> sLit "ge";
- GTT -> sLit "gt"; LE -> sLit "le";
- LU -> sLit "lt"; GEU -> sLit "ge";
- GU -> sLit "gt"; LEU -> sLit "le";
-#endif
- })
-
-
--- -----------------------------------------------------------------------------
--- pprImm: print an 'Imm'
-
-pprImm :: Imm -> Doc
-
-pprImm (ImmInt i) = int i
-pprImm (ImmInteger i) = integer i
-pprImm (ImmCLbl l) = pprCLabel_asm l
-pprImm (ImmIndex l i) = pprCLabel_asm l <> char '+' <> int i
-pprImm (ImmLit s) = s
-
-pprImm (ImmFloat _) = ptext (sLit "naughty float immediate")
-pprImm (ImmDouble _) = ptext (sLit "naughty double immediate")
-
-pprImm (ImmConstantSum a b) = pprImm a <> char '+' <> pprImm b
--- #if sparc_TARGET_ARCH
--- ToDo: This should really be fixed in the PIC support, but only
--- print a for now.
--- pprImm (ImmConstantDiff a b) = pprImm a
--- #else
-pprImm (ImmConstantDiff a b) = pprImm a <> char '-'
- <> lparen <> pprImm b <> rparen
--- #endif
-
-#if sparc_TARGET_ARCH
-pprImm (LO i)
- = hcat [ pp_lo, pprImm i, rparen ]
- where
- pp_lo = text "%lo("
-
-pprImm (HI i)
- = hcat [ pp_hi, pprImm i, rparen ]
- where
- pp_hi = text "%hi("
-#endif
-#if powerpc_TARGET_ARCH
-#if darwin_TARGET_OS
-pprImm (LO i)
- = hcat [ pp_lo, pprImm i, rparen ]
- where
- pp_lo = text "lo16("
-
-pprImm (HI i)
- = hcat [ pp_hi, pprImm i, rparen ]
- where
- pp_hi = text "hi16("
-
-pprImm (HA i)
- = hcat [ pp_ha, pprImm i, rparen ]
- where
- pp_ha = text "ha16("
-
-#else
-pprImm (LO i)
- = pprImm i <> text "@l"
-
-pprImm (HI i)
- = pprImm i <> text "@h"
-
-pprImm (HA i)
- = pprImm i <> text "@ha"
-#endif
-#endif
-
-
--- -----------------------------------------------------------------------------
--- @pprAddr: print an 'AddrMode'
-
-pprAddr :: AddrMode -> Doc
-
-#if alpha_TARGET_ARCH
-pprAddr (AddrReg r) = parens (pprReg r)
-pprAddr (AddrImm i) = pprImm i
-pprAddr (AddrRegImm r1 i)
- = (<>) (pprImm i) (parens (pprReg r1))
-#endif
-
--------------------
-
-#if i386_TARGET_ARCH || x86_64_TARGET_ARCH
-pprAddr (ImmAddr imm off)
- = let pp_imm = pprImm imm
- in
- if (off == 0) then
- pp_imm
- else if (off < 0) then
- pp_imm <> int off
- else
- pp_imm <> char '+' <> int off
-
-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
- in
- case (base,index) of
- (EABaseNone, EAIndexNone) -> pp_disp
- (EABaseReg b, EAIndexNone) -> pp_off (pp_reg b)
- (EABaseRip, EAIndexNone) -> pp_off (ptext (sLit "%rip"))
- (EABaseNone, EAIndex r i) -> pp_off (comma <> pp_reg r <> comma <> int i)
- (EABaseReg b, EAIndex r i) -> pp_off (pp_reg b <> comma <> pp_reg r
- <> comma <> int i)
- where
- ppr_disp (ImmInt 0) = empty
- ppr_disp imm = pprImm imm
-#endif
-
--------------------
-
-#if sparc_TARGET_ARCH
-pprAddr (AddrRegReg r1 (RealReg 0)) = pprReg r1
-
-pprAddr (AddrRegReg r1 r2)
- = hcat [ pprReg r1, char '+', pprReg r2 ]
-
-pprAddr (AddrRegImm r1 (ImmInt i))
- | i == 0 = pprReg r1
- | not (fits13Bits i) = largeOffsetError i
- | otherwise = hcat [ pprReg r1, pp_sign, int i ]
- where
- pp_sign = if i > 0 then char '+' else empty
-
-pprAddr (AddrRegImm r1 (ImmInteger i))
- | i == 0 = pprReg r1
- | not (fits13Bits i) = largeOffsetError i
- | otherwise = hcat [ pprReg r1, pp_sign, integer i ]
- where
- pp_sign = if i > 0 then char '+' else empty
-
-pprAddr (AddrRegImm r1 imm)
- = hcat [ pprReg r1, char '+', pprImm imm ]
-#endif
-
--------------------
-
-#if powerpc_TARGET_ARCH
-pprAddr (AddrRegReg r1 r2)
- = pprReg r1 <+> ptext (sLit ", ") <+> pprReg r2
-
-pprAddr (AddrRegImm r1 (ImmInt i)) = hcat [ int i, char '(', pprReg r1, char ')' ]
-pprAddr (AddrRegImm r1 (ImmInteger i)) = hcat [ integer i, char '(', pprReg r1, char ')' ]
-pprAddr (AddrRegImm r1 imm) = hcat [ pprImm imm, char '(', pprReg r1, char ')' ]
-#endif
-
-
--- -----------------------------------------------------------------------------
--- pprData: print a 'CmmStatic'
-
-pprSectionHeader Text
- = ptext
- (IF_ARCH_alpha(sLit "\t.text\n\t.align 3" {-word boundary-}
- ,IF_ARCH_sparc(sLit ".text\n\t.align 4" {-word boundary-}
- ,IF_ARCH_i386(IF_OS_darwin(sLit ".text\n\t.align 2",
- sLit ".text\n\t.align 4,0x90")
- {-needs per-OS variation!-}
- ,IF_ARCH_x86_64(IF_OS_darwin(sLit ".text\n.align 3",
- sLit ".text\n\t.align 8")
- ,IF_ARCH_powerpc(sLit ".text\n.align 2"
- ,))))))
-pprSectionHeader Data
- = ptext
- (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 ".data\n\t.align 2",
- sLit ".data\n\t.align 4")
- ,IF_ARCH_x86_64(IF_OS_darwin(sLit ".data\n.align 3",
- sLit ".data\n\t.align 8")
- ,IF_ARCH_powerpc(sLit ".data\n.align 2"
- ,))))))
-pprSectionHeader ReadOnlyData
- = ptext
- (IF_ARCH_alpha(sLit "\t.data\n\t.align 3"
- ,IF_ARCH_sparc(sLit ".text\n\t.align 8" {-<8 will break double constants -}
- ,IF_ARCH_i386(IF_OS_darwin(sLit ".const\n.align 2",
- sLit ".section .rodata\n\t.align 4")
- ,IF_ARCH_x86_64(IF_OS_darwin(sLit ".const\n.align 3",
- sLit ".section .rodata\n\t.align 8")
- ,IF_ARCH_powerpc(IF_OS_darwin(sLit ".const\n.align 2",
- sLit ".section .rodata\n\t.align 2")
- ,))))))
-pprSectionHeader RelocatableReadOnlyData
- = ptext
- (IF_ARCH_alpha(sLit "\t.data\n\t.align 3"
- ,IF_ARCH_sparc(sLit ".text\n\t.align 8" {-<8 will break double constants -}
- ,IF_ARCH_i386(IF_OS_darwin(sLit ".const_data\n.align 2",
- sLit ".section .data\n\t.align 4")
- ,IF_ARCH_x86_64(IF_OS_darwin(sLit ".const_data\n.align 3",
- 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")
- ,))))))
-pprSectionHeader UninitialisedData
- = ptext
- (IF_ARCH_alpha(sLit "\t.bss\n\t.align 3"
- ,IF_ARCH_sparc(sLit ".bss\n\t.align 8" {-<8 will break double constants -}
- ,IF_ARCH_i386(IF_OS_darwin(sLit ".data\n\t.align 2",
- sLit ".section .bss\n\t.align 4")
- ,IF_ARCH_x86_64(IF_OS_darwin(sLit ".data\n\t.align 3",
- sLit ".section .bss\n\t.align 8")
- ,IF_ARCH_powerpc(IF_OS_darwin(sLit ".const_data\n.align 2",
- sLit ".section .bss\n\t.align 2")
- ,))))))
-pprSectionHeader ReadOnlyData16
- = ptext
- (IF_ARCH_alpha(sLit "\t.data\n\t.align 4"
- ,IF_ARCH_sparc(sLit ".data\n\t.align 16"
- ,IF_ARCH_i386(IF_OS_darwin(sLit ".const\n.align 4",
- sLit ".section .rodata\n\t.align 16")
- ,IF_ARCH_x86_64(IF_OS_darwin(sLit ".const\n.align 4",
- sLit ".section .rodata.cst16\n\t.align 16")
- ,IF_ARCH_powerpc(IF_OS_darwin(sLit ".const\n.align 4",
- sLit ".section .rodata\n\t.align 4")
- ,))))))
-
-pprSectionHeader (OtherSection sec)
- = panic "PprMach.pprSectionHeader: unknown section"
pprData :: CmmStatic -> Doc
pprData (CmmAlign bytes) = pprAlign bytes
log2 n = 1 + log2 (n `quot` 2)
-pprDataItem :: CmmLit -> Doc
-pprDataItem lit
- = vcat (ppr_item (cmmTypeSize $ cmmLitType lit) lit)
- where
- imm = litToImm lit
-
- -- These seem to be common:
- ppr_item II8 x = [ptext (sLit "\t.byte\t") <> pprImm imm]
- ppr_item II32 x = [ptext (sLit "\t.long\t") <> pprImm imm]
- ppr_item FF32 (CmmFloat r _)
- = let bs = floatToBytes (fromRational r)
- in map (\b -> ptext (sLit "\t.byte\t") <> pprImm (ImmInt b)) bs
- ppr_item FF64 (CmmFloat r _)
- = let bs = doubleToBytes (fromRational r)
- in map (\b -> ptext (sLit "\t.byte\t") <> pprImm (ImmInt b)) bs
-
-#if sparc_TARGET_ARCH
- -- copy n paste of x86 version
- ppr_item II16 x = [ptext (sLit "\t.short\t") <> pprImm imm]
- ppr_item II64 x = [ptext (sLit "\t.quad\t") <> pprImm imm]
-#endif
-#if i386_TARGET_ARCH || x86_64_TARGET_ARCH
- ppr_item II16 x = [ptext (sLit "\t.word\t") <> pprImm imm]
-#endif
-#if i386_TARGET_ARCH && darwin_TARGET_OS
- ppr_item II64 (CmmInt x _) =
- [ptext (sLit "\t.long\t")
- <> int (fromIntegral (fromIntegral x :: Word32)),
- ptext (sLit "\t.long\t")
- <> int (fromIntegral
- (fromIntegral (x `shiftR` 32) :: Word32))]
-#endif
-#if i386_TARGET_ARCH || (darwin_TARGET_OS && x86_64_TARGET_ARCH)
- ppr_item II64 x = [ptext (sLit "\t.quad\t") <> pprImm imm]
-#endif
-#if x86_64_TARGET_ARCH && !darwin_TARGET_OS
- -- x86_64: binutils can't handle the R_X86_64_PC64 relocation
- -- type, which means we can't do pc-relative 64-bit addresses.
- -- 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 Note [x86-64-relative] in includes/InfoTables.h
- --
- ppr_item II64 x
- | isRelativeReloc x =
- [ptext (sLit "\t.long\t") <> pprImm imm,
- ptext (sLit "\t.long\t0")]
- | otherwise =
- [ptext (sLit "\t.quad\t") <> pprImm imm]
- where
- isRelativeReloc (CmmLabelDiffOff _ _ _) = True
- isRelativeReloc _ = False
-#endif
-#if powerpc_TARGET_ARCH
- ppr_item II16 x = [ptext (sLit "\t.short\t") <> pprImm imm]
- ppr_item II64 (CmmInt x _) =
- [ptext (sLit "\t.long\t")
- <> int (fromIntegral
- (fromIntegral (x `shiftR` 32) :: Word32)),
- ptext (sLit "\t.long\t")
- <> int (fromIntegral (fromIntegral x :: Word32))]
-#endif
-
--- fall through to rest of (machine-specific) pprInstr...
-
-- -----------------------------------------------------------------------------
-- pprInstr: print an 'Instr'
instance Outputable Instr where
ppr instr = Outputable.docToSDoc $ pprInstr instr
-pprInstr :: Instr -> Doc
-
-pprInstr (COMMENT s) = 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(
- ((<>) (ptext (sLit "# ")) (ftext s)),
- ((<>) (ptext (sLit "; ")) (ftext s)))
- ,)))))
--}
-pprInstr (DELTA d)
- = pprInstr (COMMENT (mkFastString ("\tdelta = " ++ show d)))
-
-pprInstr (NEWBLOCK _)
- = panic "PprMach.pprInstr: NEWBLOCK"
-
-pprInstr (LDATA _ _)
- = panic "PprMach.pprInstr: LDATA"
-
--- -----------------------------------------------------------------------------
--- pprInstr for an Alpha
-
-#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"),
- pprSize size,
- char '\t',
- pprReg reg,
- comma,
- pprAddr addr
- ]
-
-pprInstr (LDA reg addr)
- = hcat [
- ptext (sLit "\tlda\t"),
- pprReg reg,
- comma,
- pprAddr addr
- ]
-
-pprInstr (LDAH reg addr)
- = hcat [
- ptext (sLit "\tldah\t"),
- pprReg reg,
- comma,
- pprAddr addr
- ]
-
-pprInstr (LDGP reg addr)
- = hcat [
- ptext (sLit "\tldgp\t"),
- pprReg reg,
- comma,
- pprAddr addr
- ]
-
-pprInstr (LDI size reg imm)
- = hcat [
- ptext (sLit "\tldi"),
- pprSize size,
- char '\t',
- pprReg reg,
- comma,
- pprImm imm
- ]
-
-pprInstr (ST size reg addr)
- = hcat [
- ptext (sLit "\tst"),
- pprSize size,
- char '\t',
- pprReg reg,
- comma,
- pprAddr addr
- ]
-
-pprInstr (CLR reg)
- = hcat [
- ptext (sLit "\tclr\t"),
- pprReg reg
- ]
-
-pprInstr (ABS size ri reg)
- = hcat [
- ptext (sLit "\tabs"),
- pprSize size,
- char '\t',
- pprRI ri,
- comma,
- pprReg reg
- ]
-
-pprInstr (NEG size ov ri reg)
- = hcat [
- ptext (sLit "\tneg"),
- pprSize size,
- if ov then ptext (sLit "v\t") else char '\t',
- pprRI ri,
- comma,
- pprReg reg
- ]
-
-pprInstr (ADD size ov reg1 ri reg2)
- = hcat [
- ptext (sLit "\tadd"),
- pprSize size,
- if ov then ptext (sLit "v\t") else char '\t',
- pprReg reg1,
- comma,
- pprRI ri,
- comma,
- pprReg reg2
- ]
-
-pprInstr (SADD size scale reg1 ri reg2)
- = hcat [
- ptext (case scale of {{-UNUSED:L -> (sLit "\ts4");-} Q -> (sLit "\ts8")}),
- ptext (sLit "add"),
- pprSize size,
- char '\t',
- pprReg reg1,
- comma,
- pprRI ri,
- comma,
- pprReg reg2
- ]
-
-pprInstr (SUB size ov reg1 ri reg2)
- = hcat [
- ptext (sLit "\tsub"),
- pprSize size,
- if ov then ptext (sLit "v\t") else char '\t',
- pprReg reg1,
- comma,
- pprRI ri,
- comma,
- pprReg reg2
- ]
-
-pprInstr (SSUB size scale reg1 ri reg2)
- = hcat [
- ptext (case scale of {{-UNUSED:L -> (sLit "\ts4");-} Q -> (sLit "\ts8")}),
- ptext (sLit "sub"),
- pprSize size,
- char '\t',
- pprReg reg1,
- comma,
- pprRI ri,
- comma,
- pprReg reg2
- ]
-
-pprInstr (MUL size ov reg1 ri reg2)
- = hcat [
- ptext (sLit "\tmul"),
- pprSize size,
- if ov then ptext (sLit "v\t") else char '\t',
- pprReg reg1,
- comma,
- pprRI ri,
- comma,
- pprReg reg2
- ]
-
-pprInstr (DIV size uns reg1 ri reg2)
- = hcat [
- ptext (sLit "\tdiv"),
- pprSize size,
- if uns then ptext (sLit "u\t") else char '\t',
- pprReg reg1,
- comma,
- pprRI ri,
- comma,
- pprReg reg2
- ]
-
-pprInstr (REM size uns reg1 ri reg2)
- = hcat [
- ptext (sLit "\trem"),
- pprSize size,
- if uns then ptext (sLit "u\t") else char '\t',
- pprReg reg1,
- comma,
- pprRI ri,
- comma,
- pprReg reg2
- ]
-
-pprInstr (NOT ri reg)
- = hcat [
- ptext (sLit "\tnot"),
- char '\t',
- pprRI ri,
- comma,
- pprReg reg
- ]
-
-pprInstr (AND reg1 ri reg2) = pprRegRIReg (sLit "and") reg1 ri reg2
-pprInstr (ANDNOT reg1 ri reg2) = pprRegRIReg (sLit "andnot") reg1 ri reg2
-pprInstr (OR reg1 ri reg2) = pprRegRIReg (sLit "or") reg1 ri reg2
-pprInstr (ORNOT reg1 ri reg2) = pprRegRIReg (sLit "ornot") reg1 ri reg2
-pprInstr (XOR reg1 ri reg2) = pprRegRIReg (sLit "xor") reg1 ri reg2
-pprInstr (XORNOT reg1 ri reg2) = pprRegRIReg (sLit "xornot") reg1 ri reg2
-
-pprInstr (SLL reg1 ri reg2) = pprRegRIReg (sLit "sll") reg1 ri reg2
-pprInstr (SRL reg1 ri reg2) = pprRegRIReg (sLit "srl") reg1 ri reg2
-pprInstr (SRA reg1 ri reg2) = pprRegRIReg (sLit "sra") reg1 ri reg2
-
-pprInstr (ZAP reg1 ri reg2) = pprRegRIReg (sLit "zap") reg1 ri reg2
-pprInstr (ZAPNOT reg1 ri reg2) = pprRegRIReg (sLit "zapnot") reg1 ri reg2
-
-pprInstr (NOP) = ptext (sLit "\tnop")
-
-pprInstr (CMP cond reg1 ri reg2)
- = hcat [
- ptext (sLit "\tcmp"),
- pprCond cond,
- char '\t',
- pprReg reg1,
- comma,
- pprRI ri,
- comma,
- pprReg reg2
- ]
-
-pprInstr (FCLR reg)
- = hcat [
- ptext (sLit "\tfclr\t"),
- pprReg reg
- ]
-
-pprInstr (FABS reg1 reg2)
- = hcat [
- ptext (sLit "\tfabs\t"),
- pprReg reg1,
- comma,
- pprReg reg2
- ]
-
-pprInstr (FNEG size reg1 reg2)
- = hcat [
- ptext (sLit "\tneg"),
- pprSize size,
- char '\t',
- pprReg reg1,
- comma,
- pprReg reg2
- ]
-
-pprInstr (FADD size reg1 reg2 reg3) = pprSizeRegRegReg (sLit "add") size reg1 reg2 reg3
-pprInstr (FDIV size reg1 reg2 reg3) = pprSizeRegRegReg (sLit "div") size reg1 reg2 reg3
-pprInstr (FMUL size reg1 reg2 reg3) = pprSizeRegRegReg (sLit "mul") size reg1 reg2 reg3
-pprInstr (FSUB size reg1 reg2 reg3) = pprSizeRegRegReg (sLit "sub") size reg1 reg2 reg3
-
-pprInstr (CVTxy size1 size2 reg1 reg2)
- = hcat [
- ptext (sLit "\tcvt"),
- pprSize size1,
- case size2 of {Q -> ptext (sLit "qc"); _ -> pprSize size2},
- char '\t',
- pprReg reg1,
- comma,
- pprReg reg2
- ]
-
-pprInstr (FCMP size cond reg1 reg2 reg3)
- = hcat [
- ptext (sLit "\tcmp"),
- pprSize size,
- pprCond cond,
- char '\t',
- pprReg reg1,
- comma,
- pprReg reg2,
- comma,
- pprReg reg3
- ]
-
-pprInstr (FMOV reg1 reg2)
- = hcat [
- ptext (sLit "\tfmov\t"),
- pprReg reg1,
- comma,
- pprReg reg2
- ]
-
-pprInstr (BI ALWAYS reg lab) = pprInstr (BR lab)
-
-pprInstr (BI NEVER reg lab) = empty
-
-pprInstr (BI cond reg lab)
- = hcat [
- ptext (sLit "\tb"),
- pprCond cond,
- char '\t',
- pprReg reg,
- comma,
- pprImm lab
- ]
-
-pprInstr (BF cond reg lab)
- = hcat [
- ptext (sLit "\tfb"),
- pprCond cond,
- char '\t',
- pprReg reg,
- comma,
- pprImm lab
- ]
-
-pprInstr (BR lab)
- = (<>) (ptext (sLit "\tbr\t")) (pprImm lab)
-
-pprInstr (JMP reg addr hint)
- = hcat [
- ptext (sLit "\tjmp\t"),
- pprReg reg,
- comma,
- pprAddr addr,
- comma,
- int hint
- ]
-
-pprInstr (BSR imm n)
- = (<>) (ptext (sLit "\tbsr\t")) (pprImm imm)
-
-pprInstr (JSR reg addr n)
- = hcat [
- ptext (sLit "\tjsr\t"),
- pprReg reg,
- comma,
- pprAddr addr
- ]
-
-pprInstr (FUNBEGIN clab)
- = hcat [
- if (externallyVisibleCLabel clab) then
- hcat [ptext (sLit "\t.globl\t"), pp_lab, char '\n']
- else
- empty,
- ptext (sLit "\t.ent "),
- pp_lab,
- char '\n',
- pp_lab,
- pp_ldgp,
- pp_lab,
- pp_frame
- ]
- where
- pp_lab = pprCLabel_asm clab
-
- -- NEVER use commas within those string literals, cpp will ruin your day
- pp_ldgp = hcat [ ptext (sLit ":\n\tldgp $29"), char ',', ptext (sLit "0($27)\n") ]
- pp_frame = hcat [ ptext (sLit "..ng:\n\t.frame $30"), char ',',
- ptext (sLit "4240"), char ',',
- ptext (sLit "$26"), char ',',
- ptext (sLit "0\n\t.prologue 1") ]
-
-pprInstr (FUNEND clab)
- = (<>) (ptext (sLit "\t.align 4\n\t.end ")) (pprCLabel_asm clab)
-\end{code}
-
-Continue with Alpha-only printing bits and bobs:
-\begin{code}
-pprRI :: RI -> Doc
-
-pprRI (RIReg r) = pprReg r
-pprRI (RIImm r) = pprImm r
-
-pprRegRIReg :: LitString -> Reg -> RI -> Reg -> Doc
-pprRegRIReg name reg1 ri reg2
- = hcat [
- char '\t',
- ptext name,
- char '\t',
- pprReg reg1,
- comma,
- pprRI ri,
- comma,
- pprReg reg2
- ]
-
-pprSizeRegRegReg :: LitString -> Size -> Reg -> Reg -> Reg -> Doc
-pprSizeRegRegReg name size reg1 reg2 reg3
- = hcat [
- char '\t',
- ptext name,
- pprSize size,
- char '\t',
- pprReg reg1,
- comma,
- pprReg reg2,
- comma,
- pprReg reg3
- ]
-
-#endif /* alpha_TARGET_ARCH */
-
-
--- -----------------------------------------------------------------------------
--- pprInstr for an x86
-
-#if i386_TARGET_ARCH || x86_64_TARGET_ARCH
-
-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
-
-pprInstr (MOVZxL II32 src dst) = pprSizeOpOp (sLit "mov") II32 src dst
- -- 32-to-64 bit zero extension on x86_64 is accomplished by a simple
- -- movl. But we represent it as a MOVZxL instruction, because
- -- the reg alloc would tend to throw away a plain reg-to-reg
- -- move, and we still want it to do that.
-
-pprInstr (MOVZxL sizes src dst) = pprSizeOpOpCoerce (sLit "movz") sizes II32 src dst
- -- zero-extension only needs to extend to 32 bits: on x86_64,
- -- 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
-
--- here we do some patching, since the physical registers are only set late
--- in the code generation.
-pprInstr (LEA size (OpAddr (AddrBaseIndex src1@(EABaseReg reg1) (EAIndex reg2 1) (ImmInt 0))) dst@(OpReg reg3))
- | reg1 == reg3
- = pprSizeOpOp (sLit "add") size (OpReg reg2) dst
-pprInstr (LEA size (OpAddr (AddrBaseIndex src1@(EABaseReg reg1) (EAIndex reg2 1) (ImmInt 0))) dst@(OpReg reg3))
- | reg2 == reg3
- = pprSizeOpOp (sLit "add") size (OpReg reg1) dst
-pprInstr (LEA size (OpAddr (AddrBaseIndex src1@(EABaseReg reg1) EAIndexNone displ)) dst@(OpReg reg3))
- | reg1 == reg3
- = pprInstr (ADD size (OpImm displ) dst)
-pprInstr (LEA size src dst) = pprSizeOpOp (sLit "lea") size src dst
-
-pprInstr (ADD size (OpImm (ImmInt (-1))) dst)
- = pprSizeOp (sLit "dec") size dst
-pprInstr (ADD size (OpImm (ImmInt 1)) dst)
- = pprSizeOp (sLit "inc") size dst
-pprInstr (ADD size src dst)
- = pprSizeOpOp (sLit "add") size src dst
-pprInstr (ADC size src dst)
- = pprSizeOpOp (sLit "adc") size src dst
-pprInstr (SUB size src dst) = pprSizeOpOp (sLit "sub") size src dst
-pprInstr (IMUL size op1 op2) = pprSizeOpOp (sLit "imul") size op1 op2
-
-{- A hack. The Intel documentation says that "The two and three
- operand forms [of IMUL] may also be used with unsigned operands
- because the lower half of the product is the same regardless if
- (sic) the operands are signed or unsigned. The CF and OF flags,
- however, cannot be used to determine if the upper half of the
- result is non-zero." So there.
--}
-pprInstr (AND size src dst) = pprSizeOpOp (sLit "and") size src dst
-pprInstr (OR size src dst) = pprSizeOpOp (sLit "or") size src dst
-
-pprInstr (XOR FF32 src dst) = pprOpOp (sLit "xorps") FF32 src dst
-pprInstr (XOR FF64 src dst) = pprOpOp (sLit "xorpd") FF64 src dst
-pprInstr (XOR size src dst) = pprSizeOpOp (sLit "xor") size src dst
-
-pprInstr (NOT size op) = pprSizeOp (sLit "not") size op
-pprInstr (NEGI size op) = pprSizeOp (sLit "neg") size op
-
-pprInstr (SHL size src dst) = pprShift (sLit "shl") size src dst
-pprInstr (SAR size src dst) = pprShift (sLit "sar") size src dst
-pprInstr (SHR size src dst) = pprShift (sLit "shr") size src dst
-
-pprInstr (BT size imm src) = pprSizeImmOp (sLit "bt") size imm src
-
-pprInstr (CMP size src dst)
- | is_float size = pprSizeOpOp (sLit "ucomi") size src dst -- SSE2
- | otherwise = pprSizeOpOp (sLit "cmp") size src dst
- where
- -- This predicate is needed here and nowhere else
- is_float FF32 = True
- is_float FF64 = True
- is_float FF80 = True
- is_float other = False
-
-pprInstr (TEST size src dst) = pprSizeOpOp (sLit "test") size src dst
-pprInstr (PUSH size op) = pprSizeOp (sLit "push") size op
-pprInstr (POP size op) = pprSizeOp (sLit "pop") size op
-
--- both unused (SDM):
--- pprInstr PUSHA = ptext (sLit "\tpushal")
--- pprInstr POPA = ptext (sLit "\tpopal")
-
-pprInstr NOP = ptext (sLit "\tnop")
-pprInstr (CLTD II32) = ptext (sLit "\tcltd")
-pprInstr (CLTD II64) = ptext (sLit "\tcqto")
-
-pprInstr (SETCC cond op) = pprCondInstr (sLit "set") cond (pprOperand II8 op)
-
-pprInstr (JXX cond (BlockId id))
- = pprCondInstr (sLit "j") cond (pprCLabel_asm lab)
- where lab = mkAsmTempLabel 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_TBL op ids) = pprInstr (JMP op)
-pprInstr (CALL (Left imm) _) = (<>) (ptext (sLit "\tcall ")) (pprImm imm)
-pprInstr (CALL (Right reg) _) = (<>) (ptext (sLit "\tcall *")) (pprReg wordSize reg)
-
-pprInstr (IDIV sz op) = pprSizeOp (sLit "idiv") sz op
-pprInstr (DIV sz op) = pprSizeOp (sLit "div") sz op
-pprInstr (IMUL2 sz op) = pprSizeOp (sLit "imul") sz op
-
-#if x86_64_TARGET_ARCH
-pprInstr (MUL size op1 op2) = pprSizeOpOp (sLit "mul") size op1 op2
-
-pprInstr (FDIV size op1 op2) = pprSizeOpOp (sLit "div") size op1 op2
-
-pprInstr (CVTSS2SD from to) = pprRegReg (sLit "cvtss2sd") from to
-pprInstr (CVTSD2SS from to) = pprRegReg (sLit "cvtsd2ss") from to
-pprInstr (CVTTSS2SIQ from to) = pprOpReg (sLit "cvttss2siq") from to
-pprInstr (CVTTSD2SIQ from to) = pprOpReg (sLit "cvttsd2siq") from to
-pprInstr (CVTSI2SS from to) = pprOpReg (sLit "cvtsi2ssq") from to
-pprInstr (CVTSI2SD from to) = pprOpReg (sLit "cvtsi2sdq") from to
-#endif
-
- -- FETCHGOT for PIC on ELF platforms
-pprInstr (FETCHGOT reg)
- = vcat [ ptext (sLit "\tcall 1f"),
- hcat [ ptext (sLit "1:\tpopl\t"), pprReg II32 reg ],
- hcat [ ptext (sLit "\taddl\t$_GLOBAL_OFFSET_TABLE_+(.-1b), "),
- pprReg II32 reg ]
- ]
-
- -- FETCHPC for PIC on Darwin/x86
- -- get the instruction pointer into a register
- -- (Terminology note: the IP is called Program Counter on PPC,
- -- and it's a good thing to use the same name on both platforms)
-pprInstr (FETCHPC reg)
- = vcat [ ptext (sLit "\tcall 1f"),
- hcat [ ptext (sLit "1:\tpopl\t"), pprReg II32 reg ]
- ]
-
-
-
-#endif
-
--- -----------------------------------------------------------------------------
--- i386 floating-point
-
-#if i386_TARGET_ARCH
--- Simulating a flat register set on the x86 FP stack is tricky.
--- you have to free %st(7) before pushing anything on the FP reg stack
--- so as to preclude the possibility of a FP stack overflow exception.
-pprInstr g@(GMOV src dst)
- | src == dst
- = empty
- | otherwise
- = pprG g (hcat [gtab, gpush src 0, gsemi, gpop dst 1])
-
--- GLD sz addr dst ==> FFREE %st(7) ; FLDsz addr ; FSTP (dst+1)
-pprInstr g@(GLD sz addr dst)
- = pprG g (hcat [gtab, text "ffree %st(7) ; fld", pprSize sz, gsp,
- pprAddr addr, gsemi, gpop dst 1])
-
--- GST sz src addr ==> FFREE %st(7) ; FLD dst ; FSTPsz addr
-pprInstr g@(GST sz src addr)
- = pprG g (hcat [gtab, gpush src 0, gsemi,
- text "fstp", pprSize sz, gsp, pprAddr addr])
-
-pprInstr g@(GLDZ dst)
- = pprG g (hcat [gtab, text "ffree %st(7) ; fldz ; ", gpop dst 1])
-pprInstr g@(GLD1 dst)
- = pprG g (hcat [gtab, text "ffree %st(7) ; fld1 ; ", gpop dst 1])
-
-pprInstr g@(GFTOI src dst)
- = pprInstr (GDTOI src dst)
-pprInstr g@(GDTOI src dst)
- = pprG g (vcat [
- hcat [gtab, text "subl $8, %esp ; fnstcw 4(%esp)"],
- hcat [gtab, gpush src 0],
- hcat [gtab, text "movzwl 4(%esp), ", reg,
- text " ; orl $0xC00, ", reg],
- hcat [gtab, text "movl ", reg, text ", 0(%esp) ; fldcw 0(%esp)"],
- hcat [gtab, text "fistpl 0(%esp)"],
- hcat [gtab, text "fldcw 4(%esp) ; movl 0(%esp), ", reg],
- hcat [gtab, text "addl $8, %esp"]
- ])
- where
- reg = pprReg II32 dst
-
-pprInstr g@(GITOF src dst)
- = pprInstr (GITOD src dst)
-pprInstr g@(GITOD src dst)
- = pprG g (hcat [gtab, text "pushl ", pprReg II32 src,
- text " ; ffree %st(7); fildl (%esp) ; ",
- gpop dst 1, text " ; addl $4,%esp"])
-
-{- Gruesome swamp follows. If you're unfortunate enough to have ventured
- this far into the jungle AND you give a Rat's Ass (tm) what's going
- on, here's the deal. Generate code to do a floating point comparison
- of src1 and src2, of kind cond, and set the Zero flag if true.
-
- The complications are to do with handling NaNs correctly. We want the
- property that if either argument is NaN, then the result of the
- comparison is False ... except if we're comparing for inequality,
- in which case the answer is True.
-
- Here's how the general (non-inequality) case works. As an
- example, consider generating the an equality test:
-
- pushl %eax -- we need to mess with this
- <get src1 to top of FPU stack>
- fcomp <src2 location in FPU stack> and pop pushed src1
- -- Result of comparison is in FPU Status Register bits
- -- C3 C2 and C0
- fstsw %ax -- Move FPU Status Reg to %ax
- sahf -- move C3 C2 C0 from %ax to integer flag reg
- -- now the serious magic begins
- setpo %ah -- %ah = if comparable(neither arg was NaN) then 1 else 0
- sete %al -- %al = if arg1 == arg2 then 1 else 0
- andb %ah,%al -- %al &= %ah
- -- so %al == 1 iff (comparable && same); else it holds 0
- decb %al -- %al == 0, ZeroFlag=1 iff (comparable && same);
- else %al == 0xFF, ZeroFlag=0
- -- the zero flag is now set as we desire.
- popl %eax
-
- The special case of inequality differs thusly:
-
- setpe %ah -- %ah = if incomparable(either arg was NaN) then 1 else 0
- setne %al -- %al = if arg1 /= arg2 then 1 else 0
- orb %ah,%al -- %al = if (incomparable || different) then 1 else 0
- decb %al -- if (incomparable || different) then (%al == 0, ZF=1)
- else (%al == 0xFF, ZF=0)
--}
-pprInstr g@(GCMP cond src1 src2)
- | case cond of { NE -> True; other -> False }
- = pprG g (vcat [
- hcat [gtab, text "pushl %eax ; ",gpush src1 0],
- hcat [gtab, text "fcomp ", greg src2 1,
- text "; fstsw %ax ; sahf ; setpe %ah"],
- hcat [gtab, text "setne %al ; ",
- text "orb %ah,%al ; decb %al ; popl %eax"]
- ])
- | otherwise
- = pprG g (vcat [
- hcat [gtab, text "pushl %eax ; ",gpush src1 0],
- hcat [gtab, text "fcomp ", greg src2 1,
- text "; fstsw %ax ; sahf ; setpo %ah"],
- hcat [gtab, text "set", pprCond (fix_FP_cond cond), text " %al ; ",
- text "andb %ah,%al ; decb %al ; popl %eax"]
- ])
- where
- {- On the 486, the flags set by FP compare are the unsigned ones!
- (This looks like a HACK to me. WDP 96/03)
- -}
- fix_FP_cond :: Cond -> Cond
- fix_FP_cond GE = GEU
- fix_FP_cond GTT = GU
- fix_FP_cond LTT = LU
- fix_FP_cond LE = LEU
- fix_FP_cond EQQ = EQQ
- fix_FP_cond NE = NE
- -- there should be no others
-
-
-pprInstr g@(GABS sz src dst)
- = pprG g (hcat [gtab, gpush src 0, text " ; fabs ; ", gpop dst 1])
-pprInstr g@(GNEG sz src dst)
- = pprG g (hcat [gtab, gpush src 0, text " ; fchs ; ", gpop dst 1])
-
-pprInstr g@(GSQRT sz src dst)
- = pprG g (hcat [gtab, gpush src 0, text " ; fsqrt"] $$
- hcat [gtab, gcoerceto sz, gpop dst 1])
-pprInstr g@(GSIN sz l1 l2 src dst)
- = pprG g (pprTrigOp "fsin" False l1 l2 src dst sz)
-pprInstr g@(GCOS sz l1 l2 src dst)
- = pprG g (pprTrigOp "fcos" False l1 l2 src dst sz)
-pprInstr g@(GTAN sz l1 l2 src dst)
- = pprG g (pprTrigOp "fptan" True l1 l2 src dst sz)
-
--- In the translations for GADD, GMUL, GSUB and GDIV,
--- the first two cases are mere optimisations. The otherwise clause
--- generates correct code under all circumstances.
-
-pprInstr g@(GADD sz src1 src2 dst)
- | src1 == dst
- = pprG g (text "\t#GADD-xxxcase1" $$
- hcat [gtab, gpush src2 0,
- text " ; faddp %st(0),", greg src1 1])
- | src2 == dst
- = pprG g (text "\t#GADD-xxxcase2" $$
- hcat [gtab, gpush src1 0,
- text " ; faddp %st(0),", greg src2 1])
- | otherwise
- = pprG g (hcat [gtab, gpush src1 0,
- text " ; fadd ", greg src2 1, text ",%st(0)",
- gsemi, gpop dst 1])
-
-
-pprInstr g@(GMUL sz src1 src2 dst)
- | src1 == dst
- = pprG g (text "\t#GMUL-xxxcase1" $$
- hcat [gtab, gpush src2 0,
- text " ; fmulp %st(0),", greg src1 1])
- | src2 == dst
- = pprG g (text "\t#GMUL-xxxcase2" $$
- hcat [gtab, gpush src1 0,
- text " ; fmulp %st(0),", greg src2 1])
- | otherwise
- = pprG g (hcat [gtab, gpush src1 0,
- text " ; fmul ", greg src2 1, text ",%st(0)",
- gsemi, gpop dst 1])
-
-
-pprInstr g@(GSUB sz src1 src2 dst)
- | src1 == dst
- = pprG g (text "\t#GSUB-xxxcase1" $$
- hcat [gtab, gpush src2 0,
- text " ; fsubrp %st(0),", greg src1 1])
- | src2 == dst
- = pprG g (text "\t#GSUB-xxxcase2" $$
- hcat [gtab, gpush src1 0,
- text " ; fsubp %st(0),", greg src2 1])
- | otherwise
- = pprG g (hcat [gtab, gpush src1 0,
- text " ; fsub ", greg src2 1, text ",%st(0)",
- gsemi, gpop dst 1])
-
-
-pprInstr g@(GDIV sz src1 src2 dst)
- | src1 == dst
- = pprG g (text "\t#GDIV-xxxcase1" $$
- hcat [gtab, gpush src2 0,
- text " ; fdivrp %st(0),", greg src1 1])
- | src2 == dst
- = pprG g (text "\t#GDIV-xxxcase2" $$
- hcat [gtab, gpush src1 0,
- text " ; fdivp %st(0),", greg src2 1])
- | otherwise
- = pprG g (hcat [gtab, gpush src1 0,
- text " ; fdiv ", greg src2 1, text ",%st(0)",
- gsemi, gpop dst 1])
-
-
-pprInstr GFREE
- = vcat [ ptext (sLit "\tffree %st(0) ;ffree %st(1) ;ffree %st(2) ;ffree %st(3)"),
- ptext (sLit "\tffree %st(4) ;ffree %st(5) ;ffree %st(6) ;ffree %st(7)")
- ]
-
-pprTrigOp :: String -> Bool -> CLabel -> CLabel -> Reg -> Reg -> Size -> Doc
-pprTrigOp op -- fsin, fcos or fptan
- isTan -- we need a couple of extra steps if we're doing tan
- l1 l2 -- internal labels for us to use
- src dst sz
- = -- We'll be needing %eax later on
- hcat [gtab, text "pushl %eax;"] $$
- -- tan is going to use an extra space on the FP stack
- (if isTan then hcat [gtab, text "ffree %st(6)"] else empty) $$
- -- First put the value in %st(0) and try to apply the op to it
- hcat [gpush src 0, text ("; " ++ op)] $$
- -- Now look to see if C2 was set (overflow, |value| >= 2^63)
- hcat [gtab, text "fnstsw %ax"] $$
- hcat [gtab, text "test $0x400,%eax"] $$
- -- If we were in bounds then jump to the end
- hcat [gtab, text "je " <> pprCLabel_asm l1] $$
- -- Otherwise we need to shrink the value. Start by
- -- loading pi, doubleing it (by adding it to itself),
- -- and then swapping pi with the value, so the value we
- -- want to apply op to is in %st(0) again
- hcat [gtab, text "ffree %st(7); fldpi"] $$
- hcat [gtab, text "fadd %st(0),%st"] $$
- hcat [gtab, text "fxch %st(1)"] $$
- -- Now we have a loop in which we make the value smaller,
- -- see if it's small enough, and loop if not
- (pprCLabel_asm l2 <> char ':') $$
- hcat [gtab, text "fprem1"] $$
- -- My Debian libc uses fstsw here for the tan code, but I can't
- -- see any reason why it should need to be different for tan.
- hcat [gtab, text "fnstsw %ax"] $$
- hcat [gtab, text "test $0x400,%eax"] $$
- hcat [gtab, text "jne " <> pprCLabel_asm l2] $$
- hcat [gtab, text "fstp %st(1)"] $$
- hcat [gtab, text op] $$
- (pprCLabel_asm l1 <> char ':') $$
- -- Pop the 1.0 tan gave us
- (if isTan then hcat [gtab, text "fstp %st(0)"] else empty) $$
- -- Restore %eax
- hcat [gtab, text "popl %eax;"] $$
- -- And finally make the result the right size
- hcat [gtab, gcoerceto sz, gpop dst 1]
-
---------------------------
-
--- coerce %st(0) to the specified size
-gcoerceto FF64 = empty
-gcoerceto FF32 = empty --text "subl $4,%esp ; fstps (%esp) ; flds (%esp) ; addl $4,%esp ; "
-
-gpush reg offset
- = hcat [text "ffree %st(7) ; fld ", greg reg offset]
-gpop reg offset
- = hcat [text "fstp ", greg reg offset]
-
-greg reg offset = text "%st(" <> int (gregno reg - 8+offset) <> char ')'
-gsemi = text " ; "
-gtab = char '\t'
-gsp = char ' '
-
-gregno (RealReg i) = i
-gregno other = --pprPanic "gregno" (ppr other)
- 999 -- bogus; only needed for debug printing
-
-pprG :: Instr -> Doc -> Doc
-pprG fake actual
- = (char '#' <> pprGInstr fake) $$ actual
-
-pprGInstr (GMOV src dst) = pprSizeRegReg (sLit "gmov") FF64 src dst
-pprGInstr (GLD sz src dst) = pprSizeAddrReg (sLit "gld") sz src dst
-pprGInstr (GST sz src dst) = pprSizeRegAddr (sLit "gst") sz src dst
-
-pprGInstr (GLDZ dst) = pprSizeReg (sLit "gldz") FF64 dst
-pprGInstr (GLD1 dst) = pprSizeReg (sLit "gld1") FF64 dst
-
-pprGInstr (GFTOI src dst) = pprSizeSizeRegReg (sLit "gftoi") FF32 II32 src dst
-pprGInstr (GDTOI src dst) = pprSizeSizeRegReg (sLit "gdtoi") FF64 II32 src dst
-
-pprGInstr (GITOF src dst) = pprSizeSizeRegReg (sLit "gitof") II32 FF32 src dst
-pprGInstr (GITOD src dst) = pprSizeSizeRegReg (sLit "gitod") II32 FF64 src dst
-
-pprGInstr (GCMP co src dst) = pprCondRegReg (sLit "gcmp_") FF64 co src dst
-pprGInstr (GABS sz src dst) = pprSizeRegReg (sLit "gabs") sz src dst
-pprGInstr (GNEG sz src dst) = pprSizeRegReg (sLit "gneg") sz src dst
-pprGInstr (GSQRT sz src dst) = pprSizeRegReg (sLit "gsqrt") sz src dst
-pprGInstr (GSIN sz _ _ src dst) = pprSizeRegReg (sLit "gsin") sz src dst
-pprGInstr (GCOS sz _ _ src dst) = pprSizeRegReg (sLit "gcos") sz src dst
-pprGInstr (GTAN sz _ _ src dst) = pprSizeRegReg (sLit "gtan") sz src dst
-
-pprGInstr (GADD sz src1 src2 dst) = pprSizeRegRegReg (sLit "gadd") sz src1 src2 dst
-pprGInstr (GSUB sz src1 src2 dst) = pprSizeRegRegReg (sLit "gsub") sz src1 src2 dst
-pprGInstr (GMUL sz src1 src2 dst) = pprSizeRegRegReg (sLit "gmul") sz src1 src2 dst
-pprGInstr (GDIV sz src1 src2 dst) = pprSizeRegRegReg (sLit "gdiv") sz src1 src2 dst
-#endif
-
-#if i386_TARGET_ARCH || x86_64_TARGET_ARCH
-
--- Continue with I386-only printing bits and bobs:
-
-pprDollImm :: Imm -> Doc
-
-pprDollImm i = ptext (sLit "$") <> pprImm i
-
-pprOperand :: Size -> Operand -> Doc
-pprOperand s (OpReg r) = pprReg s r
-pprOperand s (OpImm i) = pprDollImm i
-pprOperand s (OpAddr ea) = pprAddr ea
-
-pprMnemonic_ :: LitString -> Doc
-pprMnemonic_ name =
- char '\t' <> ptext name <> space
-
-pprMnemonic :: LitString -> Size -> Doc
-pprMnemonic name size =
- char '\t' <> ptext name <> pprSize size <> space
-
-pprSizeImmOp :: LitString -> Size -> Imm -> Operand -> Doc
-pprSizeImmOp name size imm op1
- = hcat [
- pprMnemonic name size,
- char '$',
- pprImm imm,
- comma,
- pprOperand size op1
- ]
-
-pprSizeOp :: LitString -> Size -> Operand -> Doc
-pprSizeOp name size op1
- = hcat [
- pprMnemonic name size,
- pprOperand size op1
- ]
-
-pprSizeOpOp :: LitString -> Size -> Operand -> Operand -> Doc
-pprSizeOpOp name size op1 op2
- = hcat [
- pprMnemonic name size,
- pprOperand size op1,
- comma,
- pprOperand size op2
- ]
-
-pprOpOp :: LitString -> Size -> Operand -> Operand -> Doc
-pprOpOp name size op1 op2
- = hcat [
- pprMnemonic_ name,
- pprOperand size op1,
- comma,
- pprOperand size op2
- ]
-
-pprSizeReg :: LitString -> Size -> Reg -> Doc
-pprSizeReg name size reg1
- = hcat [
- pprMnemonic name size,
- pprReg size reg1
- ]
-
-pprSizeRegReg :: LitString -> Size -> Reg -> Reg -> Doc
-pprSizeRegReg name size reg1 reg2
- = hcat [
- pprMnemonic name size,
- pprReg size reg1,
- comma,
- pprReg size reg2
- ]
-
-pprRegReg :: LitString -> Reg -> Reg -> Doc
-pprRegReg name reg1 reg2
- = hcat [
- pprMnemonic_ name,
- pprReg wordSize reg1,
- comma,
- pprReg wordSize reg2
- ]
-
-pprOpReg :: LitString -> Operand -> Reg -> Doc
-pprOpReg name op1 reg2
- = hcat [
- pprMnemonic_ name,
- pprOperand wordSize op1,
- comma,
- pprReg wordSize reg2
- ]
-
-pprCondRegReg :: LitString -> Size -> Cond -> Reg -> Reg -> Doc
-pprCondRegReg name size cond reg1 reg2
- = hcat [
- char '\t',
- ptext name,
- pprCond cond,
- space,
- pprReg size reg1,
- comma,
- pprReg size reg2
- ]
-
-pprSizeSizeRegReg :: LitString -> Size -> Size -> Reg -> Reg -> Doc
-pprSizeSizeRegReg name size1 size2 reg1 reg2
- = hcat [
- char '\t',
- ptext name,
- pprSize size1,
- pprSize size2,
- space,
- pprReg size1 reg1,
-
- comma,
- pprReg size2 reg2
- ]
-
-pprSizeRegRegReg :: LitString -> Size -> Reg -> Reg -> Reg -> Doc
-pprSizeRegRegReg name size reg1 reg2 reg3
- = hcat [
- pprMnemonic name size,
- pprReg size reg1,
- comma,
- pprReg size reg2,
- comma,
- pprReg size reg3
- ]
-
-pprSizeAddrReg :: LitString -> Size -> AddrMode -> Reg -> Doc
-pprSizeAddrReg name size op dst
- = hcat [
- pprMnemonic name size,
- pprAddr op,
- comma,
- pprReg size dst
- ]
-
-pprSizeRegAddr :: LitString -> Size -> Reg -> AddrMode -> Doc
-pprSizeRegAddr name size src op
- = hcat [
- pprMnemonic name size,
- pprReg size src,
- comma,
- pprAddr op
- ]
-
-pprShift :: LitString -> Size -> Operand -> Operand -> Doc
-pprShift name size src dest
- = hcat [
- pprMnemonic name size,
- pprOperand II8 src, -- src is 8-bit sized
- comma,
- pprOperand size dest
- ]
-
-pprSizeOpOpCoerce :: LitString -> Size -> Size -> Operand -> Operand -> Doc
-pprSizeOpOpCoerce name size1 size2 op1 op2
- = hcat [ char '\t', ptext name, pprSize size1, pprSize size2, space,
- pprOperand size1 op1,
- comma,
- pprOperand size2 op2
- ]
-
-pprCondInstr :: LitString -> Cond -> Doc -> Doc
-pprCondInstr name cond arg
- = hcat [ char '\t', ptext name, pprCond cond, space, arg]
-
-#endif /* i386_TARGET_ARCH */
-
-
--- ------------------------------------------------------------------------------- pprInstr for a SPARC
-
-#if sparc_TARGET_ARCH
-
--- 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).
---
-
-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
--- 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]
- ]
-
-
-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 instr@(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]
- ]
-
-
-
--- 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
- ]
-
-pprInstr (ADD x cc reg1 ri reg2)
- | not x && not cc && riZero ri
- = hcat [ ptext (sLit "\tmov\t"), pprReg reg1, comma, pprReg reg2 ]
-
- | otherwise
- = pprRegRIReg (if x then sLit "addx" else sLit "add") cc reg1 ri reg2
-
-pprInstr (SUB x cc reg1 ri reg2)
- | not x && cc && reg2 == g0
- = hcat [ ptext (sLit "\tcmp\t"), pprReg reg1, comma, pprRI ri ]
- | not x && not cc && riZero ri
- = hcat [ ptext (sLit "\tmov\t"), pprReg reg1, comma, pprReg reg2 ]
- | otherwise
- = pprRegRIReg (if x then sLit "subx" else sLit "sub") cc reg1 ri reg2
-
-pprInstr (AND b reg1 ri reg2) = pprRegRIReg (sLit "and") b reg1 ri reg2
-pprInstr (ANDN b reg1 ri reg2) = pprRegRIReg (sLit "andn") b reg1 ri reg2
-
-pprInstr (OR b reg1 ri reg2)
- | not b && reg1 == g0
- = let doit = hcat [ ptext (sLit "\tmov\t"), pprRI ri, comma, pprReg reg2 ]
- in case ri of
- RIReg rrr | rrr == reg2 -> empty
- other -> doit
-
- | otherwise
- = pprRegRIReg (sLit "or") b reg1 ri reg2
-
-pprInstr (ORN b reg1 ri reg2) = pprRegRIReg (sLit "orn") b reg1 ri reg2
-
-pprInstr (XOR b reg1 ri reg2) = pprRegRIReg (sLit "xor") b reg1 ri reg2
-pprInstr (XNOR b reg1 ri reg2) = pprRegRIReg (sLit "xnor") b reg1 ri reg2
-
-pprInstr (SLL reg1 ri reg2) = pprRegRIReg (sLit "sll") False reg1 ri reg2
-pprInstr (SRL reg1 ri reg2) = pprRegRIReg (sLit "srl") False reg1 ri reg2
-pprInstr (SRA reg1 ri reg2) = pprRegRIReg (sLit "sra") False reg1 ri reg2
-
-pprInstr (RDY rd) = ptext (sLit "\trd\t%y,") <> pprReg rd
-pprInstr (WRY reg1 reg2)
- = ptext (sLit "\twr\t")
- <> pprReg reg1
- <> char ','
- <> pprReg reg2
- <> char ','
- <> ptext (sLit "%y")
-
-pprInstr (SMUL b reg1 ri reg2) = pprRegRIReg (sLit "smul") b reg1 ri reg2
-pprInstr (UMUL b reg1 ri reg2) = pprRegRIReg (sLit "umul") b reg1 ri reg2
-pprInstr (SDIV b reg1 ri reg2) = pprRegRIReg (sLit "sdiv") b reg1 ri reg2
-pprInstr (UDIV b reg1 ri reg2) = pprRegRIReg (sLit "udiv") b reg1 ri reg2
-
-pprInstr (SETHI imm reg)
- = hcat [
- ptext (sLit "\tsethi\t"),
- pprImm imm,
- comma,
- pprReg reg
- ]
-
-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 (FADD size reg1 reg2 reg3)
- = pprSizeRegRegReg (sLit "fadd") size reg1 reg2 reg3
-pprInstr (FCMP e size reg1 reg2)
- = pprSizeRegReg (if e then sLit "fcmpe" else sLit "fcmp") 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 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 (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 (FSQRT size reg1 reg2) = pprSizeRegReg (sLit "fsqrt") size reg1 reg2
-pprInstr (FSUB size reg1 reg2 reg3) = pprSizeRegRegReg (sLit "fsub") size reg1 reg2 reg3
-pprInstr (FxTOy size1 size2 reg1 reg2)
- = hcat [
- ptext (sLit "\tf"),
- ptext
- (case size1 of
- II32 -> sLit "ito"
- FF32 -> sLit "sto"
- FF64 -> sLit "dto"),
- ptext
- (case size2 of
- II32 -> sLit "i\t"
- II64 -> sLit "x\t"
- FF32 -> sLit "s\t"
- FF64 -> sLit "d\t"),
- pprReg reg1, comma, pprReg reg2
- ]
-
-
-pprInstr (BI cond b (BlockId id))
- = hcat [
- ptext (sLit "\tb"), pprCond cond,
- if b then pp_comma_a else empty,
- char '\t',
- pprCLabel_asm (mkAsmTempLabel id)
- ]
-
-pprInstr (BF cond b (BlockId id))
- = hcat [
- ptext (sLit "\tfb"), pprCond cond,
- if b then pp_comma_a else empty,
- char '\t',
- pprCLabel_asm (mkAsmTempLabel id)
- ]
-
-pprInstr (JMP addr) = (<>) (ptext (sLit "\tjmp\t")) (pprAddr addr)
-pprInstr (JMP_TBL op ids) = 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 ]
-
-pprRI :: RI -> Doc
-pprRI (RIReg r) = pprReg r
-pprRI (RIImm r) = pprImm r
-
-pprSizeRegReg :: LitString -> Size -> Reg -> Reg -> Doc
-pprSizeRegReg name size reg1 reg2
- = hcat [
- char '\t',
- ptext name,
- (case size of
- FF32 -> ptext (sLit "s\t")
- FF64 -> ptext (sLit "d\t")),
- pprReg reg1,
- comma,
- pprReg reg2
- ]
-
-pprSizeRegRegReg :: LitString -> Size -> Reg -> Reg -> Reg -> Doc
-pprSizeRegRegReg name size reg1 reg2 reg3
- = hcat [
- char '\t',
- ptext name,
- (case size of
- FF32 -> ptext (sLit "s\t")
- FF64 -> ptext (sLit "d\t")),
- pprReg reg1,
- comma,
- pprReg reg2,
- comma,
- pprReg reg3
- ]
-
-pprRegRIReg :: LitString -> Bool -> Reg -> RI -> Reg -> Doc
-pprRegRIReg name b reg1 ri reg2
- = hcat [
- char '\t',
- ptext name,
- if b then ptext (sLit "cc\t") else char '\t',
- pprReg reg1,
- comma,
- pprRI ri,
- comma,
- pprReg reg2
- ]
-
-pprRIReg :: LitString -> Bool -> RI -> Reg -> Doc
-pprRIReg name b ri reg1
- = hcat [
- char '\t',
- ptext name,
- if b then ptext (sLit "cc\t") else char '\t',
- pprRI ri,
- comma,
- pprReg reg1
- ]
-
-pp_ld_lbracket = ptext (sLit "\tld\t[")
-pp_rbracket_comma = text "],"
-pp_comma_lbracket = text ",["
-pp_comma_a = text ",a"
-
-#endif /* sparc_TARGET_ARCH */
-
-
--- -----------------------------------------------------------------------------
--- 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"),
- ptext (case sz of
- II8 -> sLit "bz"
- II16 -> sLit "hz"
- II32 -> sLit "wz"
- FF32 -> sLit "fs"
- FF64 -> sLit "fd"),
- case addr of AddrRegImm _ _ -> empty
- AddrRegReg _ _ -> char 'x',
- char '\t',
- pprReg reg,
- ptext (sLit ", "),
- pprAddr addr
- ]
-pprInstr (LA sz reg addr) = hcat [
- char '\t',
- ptext (sLit "l"),
- ptext (case sz of
- II8 -> sLit "ba"
- II16 -> sLit "ha"
- II32 -> sLit "wa"
- FF32 -> sLit "fs"
- FF64 -> sLit "fd"),
- case addr of AddrRegImm _ _ -> empty
- AddrRegReg _ _ -> char 'x',
- char '\t',
- pprReg reg,
- ptext (sLit ", "),
- pprAddr addr
- ]
-pprInstr (ST sz reg addr) = hcat [
- char '\t',
- ptext (sLit "st"),
- pprSize sz,
- case addr of AddrRegImm _ _ -> empty
- AddrRegReg _ _ -> char 'x',
- char '\t',
- pprReg reg,
- ptext (sLit ", "),
- pprAddr addr
- ]
-pprInstr (STU sz reg addr) = hcat [
- char '\t',
- ptext (sLit "st"),
- pprSize sz,
- ptext (sLit "u\t"),
- case addr of AddrRegImm _ _ -> empty
- AddrRegReg _ _ -> char 'x',
- pprReg reg,
- ptext (sLit ", "),
- pprAddr addr
- ]
-pprInstr (LIS reg imm) = hcat [
- char '\t',
- ptext (sLit "lis"),
- char '\t',
- pprReg reg,
- ptext (sLit ", "),
- pprImm imm
- ]
-pprInstr (LI reg imm) = hcat [
- char '\t',
- ptext (sLit "li"),
- char '\t',
- pprReg reg,
- ptext (sLit ", "),
- pprImm imm
- ]
-pprInstr (MR reg1 reg2)
- | reg1 == reg2 = empty
- | otherwise = hcat [
- char '\t',
- case regClass reg1 of
- RcInteger -> ptext (sLit "mr")
- _ -> ptext (sLit "fmr"),
- char '\t',
- pprReg reg1,
- ptext (sLit ", "),
- pprReg reg2
- ]
-pprInstr (CMP sz reg ri) = hcat [
- char '\t',
- op,
- char '\t',
- pprReg reg,
- ptext (sLit ", "),
- pprRI ri
- ]
- where
- op = hcat [
- ptext (sLit "cmp"),
- pprSize sz,
- case ri of
- RIReg _ -> empty
- RIImm _ -> char 'i'
- ]
-pprInstr (CMPL sz reg ri) = hcat [
- char '\t',
- op,
- char '\t',
- pprReg reg,
- ptext (sLit ", "),
- pprRI ri
- ]
- where
- op = hcat [
- ptext (sLit "cmpl"),
- pprSize sz,
- case ri of
- RIReg _ -> empty
- RIImm _ -> char 'i'
- ]
-pprInstr (BCC cond (BlockId id)) = hcat [
- char '\t',
- ptext (sLit "b"),
- pprCond cond,
- char '\t',
- pprCLabel_asm lbl
- ]
- where lbl = mkAsmTempLabel id
-
-pprInstr (BCCFAR cond (BlockId id)) = vcat [
- hcat [
- ptext (sLit "\tb"),
- pprCond (condNegate cond),
- ptext (sLit "\t$+8")
- ],
- hcat [
- ptext (sLit "\tb\t"),
- pprCLabel_asm lbl
- ]
- ]
- where lbl = mkAsmTempLabel id
-
-pprInstr (JMP lbl) = hcat [ -- an alias for b that takes a CLabel
- char '\t',
- ptext (sLit "b"),
- char '\t',
- pprCLabel_asm lbl
- ]
-
-pprInstr (MTCTR reg) = hcat [
- char '\t',
- ptext (sLit "mtctr"),
- char '\t',
- pprReg reg
- ]
-pprInstr (BCTR _) = hcat [
- char '\t',
- ptext (sLit "bctr")
- ]
-pprInstr (BL lbl _) = hcat [
- ptext (sLit "\tbl\t"),
- pprCLabel_asm lbl
- ]
-pprInstr (BCTRL _) = hcat [
- char '\t',
- ptext (sLit "bctrl")
- ]
-pprInstr (ADD reg1 reg2 ri) = pprLogic (sLit "add") reg1 reg2 ri
-pprInstr (ADDIS reg1 reg2 imm) = hcat [
- char '\t',
- ptext (sLit "addis"),
- char '\t',
- pprReg reg1,
- ptext (sLit ", "),
- pprReg reg2,
- ptext (sLit ", "),
- pprImm imm
- ]
-
-pprInstr (ADDC reg1 reg2 reg3) = pprLogic (sLit "addc") reg1 reg2 (RIReg reg3)
-pprInstr (ADDE reg1 reg2 reg3) = pprLogic (sLit "adde") reg1 reg2 (RIReg reg3)
-pprInstr (SUBF reg1 reg2 reg3) = pprLogic (sLit "subf") reg1 reg2 (RIReg reg3)
-pprInstr (MULLW reg1 reg2 ri@(RIReg _)) = pprLogic (sLit "mullw") reg1 reg2 ri
-pprInstr (MULLW reg1 reg2 ri@(RIImm _)) = pprLogic (sLit "mull") reg1 reg2 ri
-pprInstr (DIVW reg1 reg2 reg3) = pprLogic (sLit "divw") reg1 reg2 (RIReg reg3)
-pprInstr (DIVWU reg1 reg2 reg3) = pprLogic (sLit "divwu") reg1 reg2 (RIReg reg3)
-
-pprInstr (MULLW_MayOflo reg1 reg2 reg3) = vcat [
- hcat [ ptext (sLit "\tmullwo\t"), pprReg reg1, ptext (sLit ", "),
- pprReg reg2, ptext (sLit ", "),
- pprReg reg3 ],
- hcat [ ptext (sLit "\tmfxer\t"), pprReg reg1 ],
- hcat [ ptext (sLit "\trlwinm\t"), pprReg reg1, ptext (sLit ", "),
- pprReg reg1, ptext (sLit ", "),
- ptext (sLit "2, 31, 31") ]
- ]
-
- -- for some reason, "andi" doesn't exist.
- -- we'll use "andi." instead.
-pprInstr (AND reg1 reg2 (RIImm imm)) = hcat [
- char '\t',
- ptext (sLit "andi."),
- char '\t',
- pprReg reg1,
- ptext (sLit ", "),
- pprReg reg2,
- ptext (sLit ", "),
- pprImm imm
- ]
-pprInstr (AND reg1 reg2 ri) = pprLogic (sLit "and") reg1 reg2 ri
-
-pprInstr (OR reg1 reg2 ri) = pprLogic (sLit "or") reg1 reg2 ri
-pprInstr (XOR reg1 reg2 ri) = pprLogic (sLit "xor") reg1 reg2 ri
-
-pprInstr (XORIS reg1 reg2 imm) = hcat [
- char '\t',
- ptext (sLit "xoris"),
- char '\t',
- pprReg reg1,
- ptext (sLit ", "),
- pprReg reg2,
- ptext (sLit ", "),
- pprImm imm
- ]
-
-pprInstr (EXTS sz reg1 reg2) = hcat [
- char '\t',
- ptext (sLit "exts"),
- pprSize sz,
- char '\t',
- pprReg reg1,
- ptext (sLit ", "),
- pprReg reg2
- ]
-
-pprInstr (NEG reg1 reg2) = pprUnary (sLit "neg") reg1 reg2
-pprInstr (NOT reg1 reg2) = pprUnary (sLit "not") reg1 reg2
-
-pprInstr (SLW reg1 reg2 ri) = pprLogic (sLit "slw") reg1 reg2 (limitShiftRI ri)
-pprInstr (SRW reg1 reg2 ri) = pprLogic (sLit "srw") reg1 reg2 (limitShiftRI ri)
-pprInstr (SRAW reg1 reg2 ri) = pprLogic (sLit "sraw") reg1 reg2 (limitShiftRI ri)
-pprInstr (RLWINM reg1 reg2 sh mb me) = hcat [
- ptext (sLit "\trlwinm\t"),
- pprReg reg1,
- ptext (sLit ", "),
- pprReg reg2,
- ptext (sLit ", "),
- int sh,
- ptext (sLit ", "),
- int mb,
- ptext (sLit ", "),
- int me
- ]
-
-pprInstr (FADD sz reg1 reg2 reg3) = pprBinaryF (sLit "fadd") sz reg1 reg2 reg3
-pprInstr (FSUB sz reg1 reg2 reg3) = pprBinaryF (sLit "fsub") sz reg1 reg2 reg3
-pprInstr (FMUL sz reg1 reg2 reg3) = pprBinaryF (sLit "fmul") sz reg1 reg2 reg3
-pprInstr (FDIV sz reg1 reg2 reg3) = pprBinaryF (sLit "fdiv") sz reg1 reg2 reg3
-pprInstr (FNEG reg1 reg2) = pprUnary (sLit "fneg") reg1 reg2
-
-pprInstr (FCMP reg1 reg2) = hcat [
- char '\t',
- ptext (sLit "fcmpu\tcr0, "),
- -- Note: we're using fcmpu, not fcmpo
- -- The difference is with fcmpo, compare with NaN is an invalid operation.
- -- We don't handle invalid fp ops, so we don't care
- pprReg reg1,
- ptext (sLit ", "),
- pprReg reg2
- ]
-
-pprInstr (FCTIWZ reg1 reg2) = pprUnary (sLit "fctiwz") reg1 reg2
-pprInstr (FRSP reg1 reg2) = pprUnary (sLit "frsp") reg1 reg2
-
-pprInstr (CRNOR dst src1 src2) = hcat [
- ptext (sLit "\tcrnor\t"),
- int dst,
- ptext (sLit ", "),
- int src1,
- ptext (sLit ", "),
- int src2
- ]
-
-pprInstr (MFCR reg) = hcat [
- char '\t',
- ptext (sLit "mfcr"),
- char '\t',
- pprReg reg
- ]
-
-pprInstr (MFLR reg) = hcat [
- char '\t',
- ptext (sLit "mflr"),
- char '\t',
- pprReg reg
- ]
-
-pprInstr (FETCHPC reg) = vcat [
- ptext (sLit "\tbcl\t20,31,1f"),
- hcat [ ptext (sLit "1:\tmflr\t"), pprReg reg ]
- ]
-
-pprInstr LWSYNC = ptext (sLit "\tlwsync")
-
-pprInstr _ = panic "pprInstr (ppc)"
-
-pprLogic op reg1 reg2 ri = hcat [
- char '\t',
- ptext op,
- case ri of
- RIReg _ -> empty
- RIImm _ -> char 'i',
- char '\t',
- pprReg reg1,
- ptext (sLit ", "),
- pprReg reg2,
- ptext (sLit ", "),
- pprRI ri
- ]
-
-pprUnary op reg1 reg2 = hcat [
- char '\t',
- ptext op,
- char '\t',
- pprReg reg1,
- ptext (sLit ", "),
- pprReg reg2
- ]
-
-pprBinaryF op sz reg1 reg2 reg3 = hcat [
- char '\t',
- ptext op,
- pprFSize sz,
- char '\t',
- pprReg reg1,
- ptext (sLit ", "),
- pprReg reg2,
- ptext (sLit ", "),
- pprReg reg3
- ]
-
-pprRI :: RI -> Doc
-pprRI (RIReg r) = pprReg r
-pprRI (RIImm r) = pprImm r
-
-pprFSize FF64 = empty
-pprFSize FF32 = char 's'
-
- -- limit immediate argument for shift instruction to range 0..32
- -- (yes, the maximum is really 32, not 31)
-limitShiftRI :: RI -> RI
-limitShiftRI (RIImm (ImmInt i)) | i > 32 || i < 0 = RIImm (ImmInt 32)
-limitShiftRI x = x
-
-#endif /* powerpc_TARGET_ARCH */
-
-
--- -----------------------------------------------------------------------------
--- Converting floating-point literals to integrals for printing
-
-castFloatToWord8Array :: STUArray s Int Float -> ST s (STUArray s Int Word8)
-castFloatToWord8Array = castSTUArray
-
-castDoubleToWord8Array :: STUArray s Int Double -> ST s (STUArray s Int Word8)
-castDoubleToWord8Array = castSTUArray
-
--- floatToBytes and doubleToBytes convert to the host's byte
--- order. Providing that we're not cross-compiling for a
--- target with the opposite endianness, this should work ok
--- on all targets.
--- ToDo: this stuff is very similar to the shenanigans in PprAbs,
--- could they be merged?
-floatToBytes :: Float -> [Int]
-floatToBytes f
- = runST (do
- arr <- newArray_ ((0::Int),3)
- writeArray arr 0 f
- arr <- castFloatToWord8Array arr
- i0 <- readArray arr 0
- i1 <- readArray arr 1
- i2 <- readArray arr 2
- i3 <- readArray arr 3
- return (map fromIntegral [i0,i1,i2,i3])
- )
-doubleToBytes :: Double -> [Int]
-doubleToBytes d
- = runST (do
- arr <- newArray_ ((0::Int),7)
- writeArray arr 0 d
- arr <- castDoubleToWord8Array arr
- i0 <- readArray arr 0
- i1 <- readArray arr 1
- i2 <- readArray arr 2
- i3 <- readArray arr 3
- i4 <- readArray arr 4
- i5 <- readArray arr 5
- i6 <- readArray arr 6
- i7 <- readArray arr 7
- return (map fromIntegral [i0,i1,i2,i3,i4,i5,i6,i7])
- )
import GHC.Exts
+-- | Branch condition codes.
data Cond
= ALWAYS
| EQQ
| VS
deriving Eq
--- -----------------------------------------------------------------------------
--- Machine's assembly language
--- We have a few common "instructions" (nearly all the pseudo-ops) but
--- mostly all of 'Instr' is machine-specific.
-
--- Register or immediate
+-- | Register or immediate
data RI
= RIReg Reg
| RIImm Imm
+
+-- | SPARC isntruction set.
data Instr
+
+ -- meta ops --------------------------------------------------
-- comment pseudo-op
= COMMENT FastString
- -- some static data spat out during code
- -- generation. Will be extracted before
- -- pretty-printing.
+ -- some static data spat out during code generation.
+ -- Will be extracted before pretty-printing.
| LDATA Section [CmmStatic]
- -- start a new basic block. Useful during
- -- codegen, removed later. Preceding
- -- instruction should be a jump, as per the
- -- invariants for a BasicBlock (see Cmm).
+ -- Start a new basic block. Useful during codegen, removed later.
+ -- Preceding instruction should be a jump, as per the invariants
+ -- for a BasicBlock (see Cmm).
| NEWBLOCK BlockId
- -- specify current stack offset for
- -- benefit of subsequent passes
+ -- specify current stack offset for benefit of subsequent passes.
| DELTA Int
-- | spill this reg to a stack slot
-- | reload this reg from a stack slot
| RELOAD Int Reg
-
+ -- real instrs -----------------------------------------------
-- Loads and stores.
| LD Size AddrMode Reg -- size, src, dst
| ST Size Reg AddrMode -- size, src, dst
| RDY Reg -- move contents of Y register to reg
| WRY Reg Reg -- Y <- src1 `xor` src2
- -- Simple bit-twiddling.
+ -- Logic operations.
| AND Bool Reg RI Reg -- cc?, src1, src2, dst
| ANDN Bool Reg RI Reg -- cc?, src1, src2, dst
| OR Bool Reg RI Reg -- cc?, src1, src2, dst
| SLL Reg RI Reg -- src1, src2, dst
| SRL Reg RI Reg -- src1, src2, dst
| SRA Reg RI Reg -- src1, src2, dst
+
+ -- Load immediates.
| SETHI Imm Reg -- src, dst
- | NOP -- Really SETHI 0, %g0, but worth an alias
+
+ -- Do nothing.
+ -- Implemented by the assembler as SETHI 0, %g0, but worth an alias
+ | NOP
-- Float Arithmetic.
-- Note that we cheat by treating F{ABS,MOV,NEG} of doubles as single
-- instructions right up until we spit them out.
+ --
| FABS Size Reg Reg -- src dst
| FADD Size Reg Reg Reg -- src1, src2, dst
| FCMP Bool Size Reg Reg -- exception?, src1, src2, dst
| JMP AddrMode -- target
- -- With a tabled jump we know all the possible destinations. Tabled
- -- jump includes its list of destinations so we can work out what regs
- -- are live across the jump.
+ -- With a tabled jump we know all the possible destinations.
+ -- We also need this info so we can work out what regs are live across the jump.
--
| JMP_TBL AddrMode [BlockId]
| CALL (Either Imm Reg) Int Bool -- target, args, terminal
+-- | Check if a RI represents a zero value.
+-- - a literal zero
+-- - register %g0, which is always zero.
+--
riZero :: RI -> Bool
riZero (RIImm (ImmInt 0)) = True
riZero (RIImm (ImmInteger 0)) = True
--- /dev/null
+-----------------------------------------------------------------------------
+--
+-- Pretty-printing assembly language
+--
+-- (c) The University of Glasgow 1993-2005
+--
+-----------------------------------------------------------------------------
+
+module SPARC.Ppr (
+ pprUserReg,
+ pprSize,
+ pprImm,
+ pprSectionHeader,
+ pprDataItem,
+ pprInstr
+)
+
+where
+
+#include "HsVersions.h"
+#include "nativeGen/NCG.h"
+
+import PprBase
+import RegsBase
+import SPARC.Regs
+import SPARC.Instr
+
+import BlockId
+import Cmm
+
+import CLabel
+
+import Panic ( panic )
+import Unique ( pprUnique )
+import Pretty
+import FastString
+
+
+-- | Pretty print a register.
+-- This is an alias of pprReg for legacy reasons, should remove it.
+pprUserReg :: Reg -> Doc
+pprUserReg = pprReg
+
+
+-- | 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)
+
+
+-- | Pretty print a register name, based on this register number.
+-- The definition has been unfolded so we get a jump-table in the
+-- object code. This function is called quite a lot when emitting the asm file..
+--
+pprReg_ofRegNo :: Int -> Doc
+pprReg_ofRegNo i
+ = ptext
+ (case i of {
+ 0 -> sLit "%g0"; 1 -> sLit "%g1";
+ 2 -> sLit "%g2"; 3 -> sLit "%g3";
+ 4 -> sLit "%g4"; 5 -> sLit "%g5";
+ 6 -> sLit "%g6"; 7 -> sLit "%g7";
+ 8 -> sLit "%o0"; 9 -> sLit "%o1";
+ 10 -> sLit "%o2"; 11 -> sLit "%o3";
+ 12 -> sLit "%o4"; 13 -> sLit "%o5";
+ 14 -> sLit "%o6"; 15 -> sLit "%o7";
+ 16 -> sLit "%l0"; 17 -> sLit "%l1";
+ 18 -> sLit "%l2"; 19 -> sLit "%l3";
+ 20 -> sLit "%l4"; 21 -> sLit "%l5";
+ 22 -> sLit "%l6"; 23 -> sLit "%l7";
+ 24 -> sLit "%i0"; 25 -> sLit "%i1";
+ 26 -> sLit "%i2"; 27 -> sLit "%i3";
+ 28 -> sLit "%i4"; 29 -> sLit "%i5";
+ 30 -> sLit "%i6"; 31 -> sLit "%i7";
+ 32 -> sLit "%f0"; 33 -> sLit "%f1";
+ 34 -> sLit "%f2"; 35 -> sLit "%f3";
+ 36 -> sLit "%f4"; 37 -> sLit "%f5";
+ 38 -> sLit "%f6"; 39 -> sLit "%f7";
+ 40 -> sLit "%f8"; 41 -> sLit "%f9";
+ 42 -> sLit "%f10"; 43 -> sLit "%f11";
+ 44 -> sLit "%f12"; 45 -> sLit "%f13";
+ 46 -> sLit "%f14"; 47 -> sLit "%f15";
+ 48 -> sLit "%f16"; 49 -> sLit "%f17";
+ 50 -> sLit "%f18"; 51 -> sLit "%f19";
+ 52 -> sLit "%f20"; 53 -> sLit "%f21";
+ 54 -> sLit "%f22"; 55 -> sLit "%f23";
+ 56 -> sLit "%f24"; 57 -> sLit "%f25";
+ 58 -> sLit "%f26"; 59 -> sLit "%f27";
+ 60 -> sLit "%f28"; 61 -> sLit "%f29";
+ 62 -> sLit "%f30"; 63 -> sLit "%f31";
+ _ -> sLit "very naughty sparc register" })
+
+
+-- | Pretty print a size for an instruction suffix.
+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")
+
+
+-- | Pretty print a size for an instruction suffix.
+-- eg LD is 32bit on sparc, but LDD is 64 bit.
+pprStSize :: Size -> Doc
+pprStSize x
+ = ptext
+ (case x of
+ II8 -> sLit "b"
+ II16 -> sLit "h"
+ II32 -> sLit ""
+ II64 -> sLit "x"
+ FF32 -> sLit ""
+ FF64 -> sLit "d")
+
+
+-- | Pretty print a condition code.
+pprCond :: Cond -> Doc
+pprCond c
+ = ptext
+ (case c of
+ ALWAYS -> sLit ""
+ NEVER -> sLit "n"
+ GEU -> sLit "geu"
+ LU -> sLit "lu"
+ EQQ -> sLit "e"
+ GTT -> sLit "g"
+ GE -> sLit "ge"
+ GU -> sLit "gu"
+ LTT -> sLit "l"
+ LE -> sLit "le"
+ LEU -> sLit "leu"
+ NE -> sLit "ne"
+ NEG -> sLit "neg"
+ POS -> sLit "pos"
+ VC -> sLit "vc"
+ VS -> sLit "vs")
+
+
+-- | Pretty print an address mode.
+pprAddr :: AddrMode -> Doc
+pprAddr am
+ = case am of
+ AddrRegReg r1 (RealReg 0)
+ -> pprReg r1
+
+ AddrRegReg r1 r2
+ -> hcat [ pprReg r1, char '+', pprReg r2 ]
+
+ AddrRegImm r1 (ImmInt i)
+ | i == 0 -> pprReg r1
+ | not (fits13Bits i) -> largeOffsetError i
+ | otherwise -> hcat [ pprReg r1, pp_sign, int i ]
+ where
+ pp_sign = if i > 0 then char '+' else empty
+
+ AddrRegImm r1 (ImmInteger i)
+ | i == 0 -> pprReg r1
+ | not (fits13Bits i) -> largeOffsetError i
+ | otherwise -> hcat [ pprReg r1, pp_sign, integer i ]
+ where
+ pp_sign = if i > 0 then char '+' else empty
+
+ AddrRegImm r1 imm
+ -> hcat [ pprReg r1, char '+', pprImm imm ]
+
+
+-- | Pretty print an immediate value.
+pprImm :: Imm -> Doc
+pprImm imm
+ = case imm of
+ ImmInt i -> int i
+ ImmInteger i -> integer i
+ ImmCLbl l -> pprCLabel_asm l
+ ImmIndex l i -> pprCLabel_asm l <> char '+' <> int i
+ ImmLit s -> s
+
+ ImmConstantSum a b
+ -> pprImm a <> char '+' <> pprImm b
+
+ ImmConstantDiff a b
+ -> pprImm a <> char '-' <> lparen <> pprImm b <> rparen
+
+ LO i
+ -> hcat [ text "%lo(", pprImm i, rparen ]
+
+ HI i
+ -> hcat [ text "%hi(", pprImm i, rparen ]
+
+ -- these should have been converted to bytes and placed
+ -- in the data section.
+ ImmFloat _ -> ptext (sLit "naughty float immediate")
+ ImmDouble _ -> ptext (sLit "naughty double immediate")
+
+
+-- | Pretty print a section \/ segment header.
+-- On SPARC all the data sections must be at least 8 byte aligned
+-- incase we store doubles in them.
+--
+pprSectionHeader :: Section -> Doc
+pprSectionHeader seg
+ = case seg of
+ Text -> ptext (sLit ".text\n\t.align 4")
+ Data -> ptext (sLit ".data\n\t.align 8")
+ ReadOnlyData -> ptext (sLit ".text\n\t.align 8")
+ RelocatableReadOnlyData -> ptext (sLit ".text\n\t.align 8")
+ UninitialisedData -> ptext (sLit ".bss\n\t.align 8")
+ ReadOnlyData16 -> ptext (sLit ".data\n\t.align 16")
+ OtherSection _ -> panic "PprMach.pprSectionHeader: unknown section"
+
+
+-- | Pretty print a data item.
+pprDataItem :: CmmLit -> Doc
+pprDataItem lit
+ = vcat (ppr_item (cmmTypeSize $ cmmLitType lit) lit)
+ where
+ imm = litToImm lit
+
+ ppr_item II8 _ = [ptext (sLit "\t.byte\t") <> pprImm imm]
+ ppr_item II32 _ = [ptext (sLit "\t.long\t") <> pprImm imm]
+
+ ppr_item FF32 (CmmFloat r _)
+ = let bs = floatToBytes (fromRational r)
+ in map (\b -> ptext (sLit "\t.byte\t") <> pprImm (ImmInt b)) bs
+
+ ppr_item FF64 (CmmFloat r _)
+ = let bs = doubleToBytes (fromRational r)
+ in map (\b -> ptext (sLit "\t.byte\t") <> pprImm (ImmInt b)) bs
+
+ ppr_item II16 _ = [ptext (sLit "\t.short\t") <> pprImm imm]
+ ppr_item II64 _ = [ptext (sLit "\t.quad\t") <> pprImm imm]
+ ppr_item _ _ = panic "SPARC.Ppr.pprDataItem: no match"
+
+
+-- | Pretty print an instruction.
+pprInstr :: Instr -> Doc
+
+-- nuke comments.
+pprInstr (COMMENT _)
+ = empty
+
+pprInstr (DELTA d)
+ = pprInstr (COMMENT (mkFastString ("\tdelta = " ++ show d)))
+
+-- Newblocks and LData should have been slurped out before producing the .s file.
+pprInstr (NEWBLOCK _)
+ = panic "X86.Ppr.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]
+ ]
+
+
+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]
+ ]
+
+
+-- 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
+ ]
+
+
+pprInstr (ADD x cc reg1 ri reg2)
+ | not x && not cc && riZero ri
+ = hcat [ ptext (sLit "\tmov\t"), pprReg reg1, comma, pprReg reg2 ]
+
+ | otherwise
+ = pprRegRIReg (if x then sLit "addx" else sLit "add") cc reg1 ri reg2
+
+
+pprInstr (SUB x cc reg1 ri reg2)
+ | not x && cc && reg2 == g0
+ = hcat [ ptext (sLit "\tcmp\t"), pprReg reg1, comma, pprRI ri ]
+
+ | not x && not cc && riZero ri
+ = hcat [ ptext (sLit "\tmov\t"), pprReg reg1, comma, pprReg reg2 ]
+
+ | otherwise
+ = pprRegRIReg (if x then sLit "subx" else sLit "sub") cc reg1 ri reg2
+
+pprInstr (AND b reg1 ri reg2) = pprRegRIReg (sLit "and") b reg1 ri reg2
+
+pprInstr (ANDN b reg1 ri reg2) = pprRegRIReg (sLit "andn") b reg1 ri reg2
+
+pprInstr (OR b reg1 ri reg2)
+ | not b && reg1 == g0
+ = let doit = hcat [ ptext (sLit "\tmov\t"), pprRI ri, comma, pprReg reg2 ]
+ in case ri of
+ RIReg rrr | rrr == reg2 -> empty
+ _ -> doit
+
+ | otherwise
+ = pprRegRIReg (sLit "or") b reg1 ri reg2
+
+pprInstr (ORN b reg1 ri reg2) = pprRegRIReg (sLit "orn") b reg1 ri reg2
+
+pprInstr (XOR b reg1 ri reg2) = pprRegRIReg (sLit "xor") b reg1 ri reg2
+pprInstr (XNOR b reg1 ri reg2) = pprRegRIReg (sLit "xnor") b reg1 ri reg2
+
+pprInstr (SLL reg1 ri reg2) = pprRegRIReg (sLit "sll") False reg1 ri reg2
+pprInstr (SRL reg1 ri reg2) = pprRegRIReg (sLit "srl") False reg1 ri reg2
+pprInstr (SRA reg1 ri reg2) = pprRegRIReg (sLit "sra") False reg1 ri reg2
+
+pprInstr (RDY rd) = ptext (sLit "\trd\t%y,") <> pprReg rd
+pprInstr (WRY reg1 reg2)
+ = ptext (sLit "\twr\t")
+ <> pprReg reg1
+ <> char ','
+ <> pprReg reg2
+ <> char ','
+ <> ptext (sLit "%y")
+
+pprInstr (SMUL b reg1 ri reg2) = pprRegRIReg (sLit "smul") b reg1 ri reg2
+pprInstr (UMUL b reg1 ri reg2) = pprRegRIReg (sLit "umul") b reg1 ri reg2
+pprInstr (SDIV b reg1 ri reg2) = pprRegRIReg (sLit "sdiv") b reg1 ri reg2
+pprInstr (UDIV b reg1 ri reg2) = pprRegRIReg (sLit "udiv") b reg1 ri reg2
+
+pprInstr (SETHI imm reg)
+ = hcat [
+ ptext (sLit "\tsethi\t"),
+ pprImm imm,
+ comma,
+ pprReg reg
+ ]
+
+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 (FADD size reg1 reg2 reg3)
+ = pprSizeRegRegReg (sLit "fadd") size reg1 reg2 reg3
+
+pprInstr (FCMP e size reg1 reg2)
+ = pprSizeRegReg (if e then sLit "fcmpe" else sLit "fcmp") 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 (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 (FSQRT size reg1 reg2)
+ = pprSizeRegReg (sLit "fsqrt") size reg1 reg2
+
+pprInstr (FSUB size reg1 reg2 reg3)
+ = pprSizeRegRegReg (sLit "fsub") size reg1 reg2 reg3
+
+pprInstr (FxTOy size1 size2 reg1 reg2)
+ = hcat [
+ ptext (sLit "\tf"),
+ ptext
+ (case size1 of
+ II32 -> sLit "ito"
+ FF32 -> sLit "sto"
+ FF64 -> sLit "dto"
+ _ -> panic "SPARC.Ppr.pprInstr.FxToY: no match"),
+ ptext
+ (case size2 of
+ II32 -> sLit "i\t"
+ II64 -> sLit "x\t"
+ FF32 -> sLit "s\t"
+ FF64 -> sLit "d\t"
+ _ -> panic "SPARC.Ppr.pprInstr.FxToY: no match"),
+ pprReg reg1, comma, pprReg reg2
+ ]
+
+
+pprInstr (BI cond b (BlockId id))
+ = hcat [
+ ptext (sLit "\tb"), pprCond cond,
+ if b then pp_comma_a else empty,
+ char '\t',
+ pprCLabel_asm (mkAsmTempLabel id)
+ ]
+
+pprInstr (BF cond b (BlockId id))
+ = hcat [
+ ptext (sLit "\tfb"), pprCond cond,
+ if b then pp_comma_a else empty,
+ char '\t',
+ pprCLabel_asm (mkAsmTempLabel id)
+ ]
+
+pprInstr (JMP addr) = (<>) (ptext (sLit "\tjmp\t")) (pprAddr addr)
+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 ]
+
+
+-- | Pretty print a RI
+pprRI :: RI -> Doc
+pprRI (RIReg r) = pprReg r
+pprRI (RIImm r) = pprImm r
+
+
+-- | Pretty print a two reg instruction.
+pprSizeRegReg :: LitString -> Size -> Reg -> Reg -> Doc
+pprSizeRegReg name size reg1 reg2
+ = hcat [
+ char '\t',
+ ptext name,
+ (case size of
+ FF32 -> ptext (sLit "s\t")
+ FF64 -> ptext (sLit "d\t")
+ _ -> panic "SPARC.Ppr.pprSizeRegReg: no match"),
+
+ pprReg reg1,
+ comma,
+ pprReg reg2
+ ]
+
+
+-- | Pretty print a three reg instruction.
+pprSizeRegRegReg :: LitString -> Size -> Reg -> Reg -> Reg -> Doc
+pprSizeRegRegReg name size reg1 reg2 reg3
+ = hcat [
+ char '\t',
+ ptext name,
+ (case size of
+ FF32 -> ptext (sLit "s\t")
+ FF64 -> ptext (sLit "d\t")
+ _ -> panic "SPARC.Ppr.pprSizeRegReg: no match"),
+ pprReg reg1,
+ comma,
+ pprReg reg2,
+ comma,
+ pprReg reg3
+ ]
+
+
+-- | Pretty print an instruction of two regs and a ri.
+pprRegRIReg :: LitString -> Bool -> Reg -> RI -> Reg -> Doc
+pprRegRIReg name b reg1 ri reg2
+ = hcat [
+ char '\t',
+ ptext name,
+ if b then ptext (sLit "cc\t") else char '\t',
+ pprReg reg1,
+ comma,
+ pprRI ri,
+ comma,
+ pprReg reg2
+ ]
+
+{-
+pprRIReg :: LitString -> Bool -> RI -> Reg -> Doc
+pprRIReg name b ri reg1
+ = hcat [
+ char '\t',
+ ptext name,
+ if b then ptext (sLit "cc\t") else char '\t',
+ pprRI ri,
+ comma,
+ pprReg reg1
+ ]
+-}
+
+
+pp_ld_lbracket :: Doc
+pp_ld_lbracket = ptext (sLit "\tld\t[")
+
+
+pp_rbracket_comma :: Doc
+pp_rbracket_comma = text "],"
+
+
+pp_comma_lbracket :: Doc
+pp_comma_lbracket = text ",["
+
+
+pp_comma_a :: Doc
+pp_comma_a = text ",a"
+
where
-
#include "nativeGen/NCG.h"
#include "HsVersions.h"
import FastBool
--- -----------------------------------------------------------------------------
--- RegUsage type
-
--- @regUsage@ returns the sets of src and destination registers used
--- by a particular instruction. Machine registers that are
--- pre-allocated to stgRegs are filtered out, because they are
--- uninteresting from a register allocation standpoint. (We wouldn't
--- want them to end up on the free list!) As far as we are concerned,
--- the fixed registers simply don't exist (for allocation purposes,
--- anyway).
-
--- regUsage doesn't need to do any trickery for jumps and such. Just
--- state precisely the regs read and written by that insn. The
--- consequences of control flow transfers, as far as register
--- allocation goes, are taken care of by the register allocator.
+-- | Represents what regs are read and written to in an instruction.
+--
+data RegUsage
+ = RU [Reg] -- regs read from
+ [Reg] -- regs written to
-data RegUsage = RU [Reg] [Reg]
+-- | No regs read or written to.
noUsage :: RegUsage
noUsage = RU [] []
+
+-- | regUsage returns the sets of src and destination registers used
+-- by a particular instruction. Machine registers that are
+-- pre-allocated to stgRegs are filtered out, because they are
+-- uninteresting from a register allocation standpoint. (We wouldn't
+-- want them to end up on the free list!) As far as we are concerned,
+-- the fixed registers simply don't exist (for allocation purposes,
+-- anyway).
+
+-- regUsage doesn't need to do any trickery for jumps and such. Just
+-- state precisely the regs read and written by that insn. The
+-- consequences of control flow transfers, as far as register
+-- allocation goes, are taken care of by the register allocator.
+--
regUsage :: Instr -> RegUsage
+regUsage instr
+ = case instr of
+ SPILL reg _ -> usage ([reg], [])
+ RELOAD _ reg -> usage ([], [reg])
+
+ LD _ addr reg -> usage (regAddr addr, [reg])
+ ST _ reg addr -> usage (reg : regAddr addr, [])
+ ADD _ _ r1 ar r2 -> usage (r1 : regRI ar, [r2])
+ SUB _ _ r1 ar r2 -> usage (r1 : regRI ar, [r2])
+ UMUL _ r1 ar r2 -> usage (r1 : regRI ar, [r2])
+ SMUL _ r1 ar r2 -> usage (r1 : regRI ar, [r2])
+ UDIV _ r1 ar r2 -> usage (r1 : regRI ar, [r2])
+ SDIV _ r1 ar r2 -> usage (r1 : regRI ar, [r2])
+ RDY rd -> usage ([], [rd])
+ WRY r1 r2 -> usage ([r1, r2], [])
+ AND _ r1 ar r2 -> usage (r1 : regRI ar, [r2])
+ ANDN _ r1 ar r2 -> usage (r1 : regRI ar, [r2])
+ OR _ r1 ar r2 -> usage (r1 : regRI ar, [r2])
+ ORN _ r1 ar r2 -> usage (r1 : regRI ar, [r2])
+ XOR _ r1 ar r2 -> usage (r1 : regRI ar, [r2])
+ XNOR _ r1 ar r2 -> usage (r1 : regRI ar, [r2])
+ SLL r1 ar r2 -> usage (r1 : regRI ar, [r2])
+ SRL r1 ar r2 -> usage (r1 : regRI ar, [r2])
+ SRA r1 ar r2 -> usage (r1 : regRI ar, [r2])
+ SETHI _ reg -> usage ([], [reg])
+ FABS _ r1 r2 -> usage ([r1], [r2])
+ FADD _ r1 r2 r3 -> usage ([r1, r2], [r3])
+ FCMP _ _ r1 r2 -> usage ([r1, r2], [])
+ FDIV _ r1 r2 r3 -> usage ([r1, r2], [r3])
+ FMOV _ r1 r2 -> usage ([r1], [r2])
+ FMUL _ r1 r2 r3 -> usage ([r1, r2], [r3])
+ FNEG _ r1 r2 -> usage ([r1], [r2])
+ FSQRT _ r1 r2 -> usage ([r1], [r2])
+ FSUB _ r1 r2 r3 -> usage ([r1, r2], [r3])
+ FxTOy _ _ r1 r2 -> usage ([r1], [r2])
+
+ JMP addr -> usage (regAddr addr, [])
+ JMP_TBL addr _ -> usage (regAddr addr, [])
+
+ CALL (Left _ ) _ True -> noUsage
+ CALL (Left _ ) n False -> usage (argRegs n, callClobberedRegs)
+ CALL (Right reg) _ True -> usage ([reg], [])
+ CALL (Right reg) n False -> usage (reg : (argRegs n), callClobberedRegs)
+ _ -> noUsage
-regUsage instr = case instr of
- SPILL reg _ -> usage ([reg], [])
- RELOAD _ reg -> usage ([], [reg])
-
- LD _ addr reg -> usage (regAddr addr, [reg])
- ST _ reg addr -> usage (reg : regAddr addr, [])
- ADD _ _ r1 ar r2 -> usage (r1 : regRI ar, [r2])
- SUB _ _ r1 ar r2 -> usage (r1 : regRI ar, [r2])
- UMUL _ r1 ar r2 -> usage (r1 : regRI ar, [r2])
- SMUL _ r1 ar r2 -> usage (r1 : regRI ar, [r2])
- UDIV _ r1 ar r2 -> usage (r1 : regRI ar, [r2])
- SDIV _ r1 ar r2 -> usage (r1 : regRI ar, [r2])
- RDY rd -> usage ([], [rd])
- WRY r1 r2 -> usage ([r1, r2], [])
- AND _ r1 ar r2 -> usage (r1 : regRI ar, [r2])
- ANDN _ r1 ar r2 -> usage (r1 : regRI ar, [r2])
- OR _ r1 ar r2 -> usage (r1 : regRI ar, [r2])
- ORN _ r1 ar r2 -> usage (r1 : regRI ar, [r2])
- XOR _ r1 ar r2 -> usage (r1 : regRI ar, [r2])
- XNOR _ r1 ar r2 -> usage (r1 : regRI ar, [r2])
- SLL r1 ar r2 -> usage (r1 : regRI ar, [r2])
- SRL r1 ar r2 -> usage (r1 : regRI ar, [r2])
- SRA r1 ar r2 -> usage (r1 : regRI ar, [r2])
- SETHI _ reg -> usage ([], [reg])
- FABS _ r1 r2 -> usage ([r1], [r2])
- FADD _ r1 r2 r3 -> usage ([r1, r2], [r3])
- FCMP _ _ r1 r2 -> usage ([r1, r2], [])
- FDIV _ r1 r2 r3 -> usage ([r1, r2], [r3])
- FMOV _ r1 r2 -> usage ([r1], [r2])
- FMUL _ r1 r2 r3 -> usage ([r1, r2], [r3])
- FNEG _ r1 r2 -> usage ([r1], [r2])
- FSQRT _ r1 r2 -> usage ([r1], [r2])
- FSUB _ r1 r2 r3 -> usage ([r1, r2], [r3])
- FxTOy _ _ r1 r2 -> usage ([r1], [r2])
-
- JMP addr -> usage (regAddr addr, [])
- JMP_TBL addr _ -> usage (regAddr addr, [])
-
- CALL (Left _ ) _ True -> noUsage
- CALL (Left _ ) n False -> usage (argRegs n, callClobberedRegs)
- CALL (Right reg) _ True -> usage ([reg], [])
- CALL (Right reg) n False -> usage (reg : (argRegs n), callClobberedRegs)
-
- _ -> noUsage
where
- usage (src, dst) = RU (filter interesting src)
- (filter interesting dst)
+ usage (src, dst)
+ = RU (filter interesting src) (filter interesting dst)
- regAddr (AddrRegReg r1 r2) = [r1, r2]
- regAddr (AddrRegImm r1 _) = [r1]
+ regAddr (AddrRegReg r1 r2) = [r1, r2]
+ regAddr (AddrRegImm r1 _) = [r1]
- regRI (RIReg r) = [r]
- regRI _ = []
+ regRI (RIReg r) = [r]
+ regRI _ = []
+-- | Interesting regs are virtuals, or ones that are allocatable
+-- by the register allocator.
interesting :: Reg -> Bool
-interesting (VirtualRegI _) = True
-interesting (VirtualRegHi _) = True
-interesting (VirtualRegF _) = True
-interesting (VirtualRegD _) = True
-interesting (RealReg i) = isFastTrue (freeReg i)
+interesting reg
+ = case reg of
+ VirtualRegI _ -> True
+ VirtualRegHi _ -> True
+ VirtualRegF _ -> True
+ VirtualRegD _ -> True
+ RealReg i -> isFastTrue (freeReg i)
--- -----------------------------------------------------------------------------
--- 'patchRegs' function
--- 'patchRegs' takes an instruction and applies the given mapping to
--- all the register references.
+-- | Apply a given mapping to tall the register references in this instruction.
patchRegs :: Instr -> (Reg -> Reg) -> Instr
-
patchRegs instr env = case instr of
- SPILL reg slot -> SPILL (env reg) slot
- RELOAD slot reg -> RELOAD slot (env reg)
- LD sz addr reg -> LD sz (fixAddr addr) (env reg)
- ST sz reg addr -> ST sz (env reg) (fixAddr addr)
- ADD x cc r1 ar r2 -> ADD x cc (env r1) (fixRI ar) (env r2)
- SUB x cc r1 ar r2 -> SUB x cc (env r1) (fixRI ar) (env r2)
- UMUL cc r1 ar r2 -> UMUL cc (env r1) (fixRI ar) (env r2)
- SMUL cc r1 ar r2 -> SMUL cc (env r1) (fixRI ar) (env r2)
- UDIV cc r1 ar r2 -> UDIV cc (env r1) (fixRI ar) (env r2)
- SDIV cc r1 ar r2 -> SDIV cc (env r1) (fixRI ar) (env r2)
- RDY rd -> RDY (env rd)
- WRY r1 r2 -> WRY (env r1) (env r2)
- AND b r1 ar r2 -> AND b (env r1) (fixRI ar) (env r2)
- ANDN b r1 ar r2 -> ANDN b (env r1) (fixRI ar) (env r2)
- OR b r1 ar r2 -> OR b (env r1) (fixRI ar) (env r2)
- ORN b r1 ar r2 -> ORN b (env r1) (fixRI ar) (env r2)
- XOR b r1 ar r2 -> XOR b (env r1) (fixRI ar) (env r2)
- XNOR b r1 ar r2 -> XNOR b (env r1) (fixRI ar) (env r2)
- SLL r1 ar r2 -> SLL (env r1) (fixRI ar) (env r2)
- SRL r1 ar r2 -> SRL (env r1) (fixRI ar) (env r2)
- SRA r1 ar r2 -> SRA (env r1) (fixRI ar) (env r2)
- SETHI imm reg -> SETHI imm (env reg)
- FABS s r1 r2 -> FABS s (env r1) (env r2)
- FADD s r1 r2 r3 -> FADD s (env r1) (env r2) (env r3)
- FCMP e s r1 r2 -> FCMP e s (env r1) (env r2)
- FDIV s r1 r2 r3 -> FDIV s (env r1) (env r2) (env r3)
- FMOV s r1 r2 -> FMOV s (env r1) (env r2)
- FMUL s r1 r2 r3 -> FMUL s (env r1) (env r2) (env r3)
- FNEG s r1 r2 -> FNEG s (env r1) (env r2)
- FSQRT s r1 r2 -> FSQRT s (env r1) (env r2)
- FSUB s r1 r2 r3 -> FSUB s (env r1) (env r2) (env r3)
- FxTOy s1 s2 r1 r2 -> FxTOy s1 s2 (env r1) (env r2)
-
- JMP addr -> JMP (fixAddr addr)
- JMP_TBL addr ids -> JMP_TBL (fixAddr addr) ids
-
- CALL (Left i) n t -> CALL (Left i) n t
- CALL (Right r) n t -> CALL (Right (env r)) n t
- _ -> instr
+ SPILL reg slot -> SPILL (env reg) slot
+ RELOAD slot reg -> RELOAD slot (env reg)
+
+ LD sz addr reg -> LD sz (fixAddr addr) (env reg)
+ ST sz reg addr -> ST sz (env reg) (fixAddr addr)
+
+ ADD x cc r1 ar r2 -> ADD x cc (env r1) (fixRI ar) (env r2)
+ SUB x cc r1 ar r2 -> SUB x cc (env r1) (fixRI ar) (env r2)
+ UMUL cc r1 ar r2 -> UMUL cc (env r1) (fixRI ar) (env r2)
+ SMUL cc r1 ar r2 -> SMUL cc (env r1) (fixRI ar) (env r2)
+ UDIV cc r1 ar r2 -> UDIV cc (env r1) (fixRI ar) (env r2)
+ SDIV cc r1 ar r2 -> SDIV cc (env r1) (fixRI ar) (env r2)
+ RDY rd -> RDY (env rd)
+ WRY r1 r2 -> WRY (env r1) (env r2)
+ AND b r1 ar r2 -> AND b (env r1) (fixRI ar) (env r2)
+ ANDN b r1 ar r2 -> ANDN b (env r1) (fixRI ar) (env r2)
+ OR b r1 ar r2 -> OR b (env r1) (fixRI ar) (env r2)
+ ORN b r1 ar r2 -> ORN b (env r1) (fixRI ar) (env r2)
+ XOR b r1 ar r2 -> XOR b (env r1) (fixRI ar) (env r2)
+ XNOR b r1 ar r2 -> XNOR b (env r1) (fixRI ar) (env r2)
+ SLL r1 ar r2 -> SLL (env r1) (fixRI ar) (env r2)
+ SRL r1 ar r2 -> SRL (env r1) (fixRI ar) (env r2)
+ SRA r1 ar r2 -> SRA (env r1) (fixRI ar) (env r2)
+
+ SETHI imm reg -> SETHI imm (env reg)
+
+ FABS s r1 r2 -> FABS s (env r1) (env r2)
+ FADD s r1 r2 r3 -> FADD s (env r1) (env r2) (env r3)
+ FCMP e s r1 r2 -> FCMP e s (env r1) (env r2)
+ FDIV s r1 r2 r3 -> FDIV s (env r1) (env r2) (env r3)
+ FMOV s r1 r2 -> FMOV s (env r1) (env r2)
+ FMUL s r1 r2 r3 -> FMUL s (env r1) (env r2) (env r3)
+ FNEG s r1 r2 -> FNEG s (env r1) (env r2)
+ FSQRT s r1 r2 -> FSQRT s (env r1) (env r2)
+ FSUB s r1 r2 r3 -> FSUB s (env r1) (env r2) (env r3)
+ FxTOy s1 s2 r1 r2 -> FxTOy s1 s2 (env r1) (env r2)
+
+ JMP addr -> JMP (fixAddr addr)
+ JMP_TBL addr ids -> JMP_TBL (fixAddr addr) ids
+
+ CALL (Left i) n t -> CALL (Left i) n t
+ CALL (Right r) n t -> CALL (Right (env r)) n t
+ _ -> instr
+
where
- fixAddr (AddrRegReg r1 r2) = AddrRegReg (env r1) (env r2)
- fixAddr (AddrRegImm r1 i) = AddrRegImm (env r1) i
+ fixAddr (AddrRegReg r1 r2) = AddrRegReg (env r1) (env r2)
+ fixAddr (AddrRegImm r1 i) = AddrRegImm (env r1) i
- fixRI (RIReg r) = RIReg (env r)
- fixRI other = other
+ fixRI (RIReg r) = RIReg (env r)
+ fixRI other = other
-- -----------------------------------------------------------------------------
_other -> insn
--- -----------------------------------------------------------------------------
--- Detecting reg->reg moves
-
--- The register allocator attempts to eliminate reg->reg moves whenever it can,
--- by assigning the src and dest temporaries to the same real register.
-
-isRegRegMove :: Instr -> Maybe (Reg,Reg)
-isRegRegMove instr
- = case instr of
- ADD False False src (RIReg src2) dst
- | g0 == src2 -> Just (src, dst)
-
- FMOV FF64 src dst -> Just (src, dst)
- FMOV FF32 src dst -> Just (src, dst)
- _ -> Nothing
data JumpDest = DestBlockId BlockId | DestImm Imm
-
--- -----------------------------------------------------------------------------
--- Generating spill instructions
-
--- SPARC: spill below frame pointer leaving 2 words/spill
+-- | Make a spill instruction.
+-- On SPARC we spill below frame pointer leaving 2 words/spill
mkSpillInstr
- :: Reg -- register to spill
- -> Int -- current stack delta
- -> Int -- spill slot to use
- -> Instr
+ :: Reg -- ^ register to spill
+ -> Int -- ^ current stack delta
+ -> Int -- ^ spill slot to use
+ -> Instr
mkSpillInstr reg _ slot
- = let off = spillSlotToOffset slot
+ = let off = spillSlotToOffset slot
off_w = 1 + (off `div` 4)
sz = case regClass reg of
RcInteger -> II32
in ST sz reg (fpRel (negate off_w))
+-- | Make a spill reload instruction.
mkLoadInstr
- :: Reg -- register to load
- -> Int -- current stack delta
- -> Int -- spill slot to use
- -> Instr
+ :: Reg -- ^ register to load
+ -> Int -- ^ current stack delta
+ -> Int -- ^ spill slot to use
+ -> Instr
mkLoadInstr reg _ slot
= let off = spillSlotToOffset slot
- in let{off_w = 1 + (off `div` 4);
- sz = case regClass reg of {
- RcInteger -> II32;
- RcFloat -> FF32;
- RcDouble -> FF64}}
+ off_w = 1 + (off `div` 4)
+ sz = case regClass reg of
+ RcInteger -> II32
+ RcFloat -> FF32
+ RcDouble -> FF64
+
in LD sz (fpRel (- off_w)) reg
+-- | Make a reg-reg move instruction.
+-- On SPARC v8 there are no instructions to move directly between
+-- floating point and integer regs. If we need to do that then we
+-- have to go via memory.
+--
mkRegRegMoveInstr
- :: Reg
- -> Reg
- -> Instr
+ :: Reg
+ -> Reg
+ -> Instr
+
mkRegRegMoveInstr src dst
- = case regClass src of
- RcInteger -> ADD False False src (RIReg g0) dst
+ = case regClass src of
+ RcInteger -> ADD False False src (RIReg g0) dst
RcDouble -> FMOV FF64 src dst
- RcFloat -> FMOV FF32 src dst
+ RcFloat -> FMOV FF32 src dst
+-- | Check whether an instruction represents a reg-reg move.
+-- The register allocator attempts to eliminate reg->reg moves whenever it can,
+-- by assigning the src and dest temporaries to the same real register.
+--
+isRegRegMove :: Instr -> Maybe (Reg,Reg)
+isRegRegMove instr
+ = case instr of
+ ADD False False src (RIReg src2) dst
+ | g0 == src2 -> Just (src, dst)
+
+ FMOV FF64 src dst -> Just (src, dst)
+ FMOV FF32 src dst -> Just (src, dst)
+ _ -> Nothing
+
+
+-- | Make an unconditional branch instruction.
mkBranchInstr
- :: BlockId
- -> [Instr]
+ :: BlockId
+ -> [Instr]
-mkBranchInstr id = [BI ALWAYS False id, NOP]
+mkBranchInstr id
+ = [BI ALWAYS False id
+ , NOP] -- fill the branch delay slot.
+-- | TODO: Why do we need 8 bytes per slot?? -BL 2009/02
spillSlotSize :: Int
spillSlotSize = 8
+
+-- | The maximum number of spill slots available on the C stack.
+-- If we use up all of the slots, then we're screwed.
maxSpillSlots :: Int
maxSpillSlots = ((rESERVED_C_STACK_BYTES - 64) `div` spillSlotSize) - 1
--- convert a spill slot number to a *byte* offset, with no sign:
--- decide on a per arch basis whether you are spilling above or below
--- the C stack pointer.
+-- | Convert a spill slot number to a *byte* offset, with no sign.
+--
spillSlotToOffset :: Int -> Int
spillSlotToOffset slot
- | slot >= 0 && slot < maxSpillSlots
- = 64 + spillSlotSize * slot
+ | slot >= 0 && slot < maxSpillSlots
+ = 64 + spillSlotSize * slot
- | otherwise
- = pprPanic "spillSlotToOffset:"
- ( text "invalid spill location: " <> int slot
- $$ text "maxSpillSlots: " <> int maxSpillSlots)
+ | otherwise
+ = pprPanic "spillSlotToOffset:"
+ ( text "invalid spill location: " <> int slot
+ $$ text "maxSpillSlots: " <> int maxSpillSlots)
import Cmm
import FastString
-#if i386_TARGET_ARCH
import CLabel
import Panic
-#endif
data Cond
= ALWAYS -- What's really used? ToDo
| BT Size Imm Operand
| NOP
-#if i386_TARGET_ARCH
- -- Float Arithmetic.
-
+ -- x86 Float Arithmetic.
-- Note that we cheat by treating G{ABS,MOV,NEG} of doubles
-- as single instructions right up until we spit them out.
-- all the 3-operand fake fp insns are src1 src2 dst
| GTAN Size CLabel CLabel Reg Reg -- src, dst
| GFREE -- do ffree on all x86 regs; an ugly hack
-#endif
-#if x86_64_TARGET_ARCH
--- SSE2 floating point: we use a restricted set of the available SSE2
--- instructions for floating-point.
+ -- SSE2 floating point: we use a restricted set of the available SSE2
+ -- instructions for floating-point.
-- use MOV for moving (either movss or movsd (movlpd better?))
-
| CVTSS2SD Reg Reg -- F32 to F64
| CVTSD2SS Reg Reg -- F64 to F32
| CVTTSS2SIQ Operand Reg -- F32 to I32/I64 (with truncation)
-- compare single/double prec floating point respectively.
| SQRT Size Operand Reg -- src, dst
-#endif
+
-- Comparison
| TEST Size Operand Operand
| OpAddr AddrMode -- memory reference
-#if i386_TARGET_ARCH
+
i386_insert_ffrees :: [GenBasicBlock Instr] -> [GenBasicBlock Instr]
i386_insert_ffrees blocks
| or (map (any is_G_instr) [ instrs | BasicBlock _ instrs <- blocks ])
GTAN{} -> True
GFREE -> panic "is_G_instr: GFREE (!)"
_ -> False
-#endif /* i386_TARGET_ARCH */
--- /dev/null
+-----------------------------------------------------------------------------
+--
+-- Pretty-printing assembly language
+--
+-- (c) The University of Glasgow 1993-2005
+--
+-----------------------------------------------------------------------------
+
+module X86.Ppr (
+ pprUserReg,
+ pprSize,
+ pprImm,
+ pprSectionHeader,
+ pprDataItem,
+ pprInstr
+)
+
+where
+
+#include "HsVersions.h"
+#include "nativeGen/NCG.h"
+
+import PprBase
+import RegsBase
+import X86.Regs
+import X86.Instr
+
+import BlockId
+import Cmm
+
+import CLabel ( CLabel, mkAsmTempLabel )
+#if HAVE_SUBSECTIONS_VIA_SYMBOLS
+import CLabel ( mkDeadStripPreventer )
+#endif
+
+import Unique ( pprUnique )
+import Pretty
+import FastString
+import qualified Outputable
+import Outputable (panic)
+
+#if i386_TARGET_ARCH || x86_64_TARGET_ARCH
+pprUserReg :: Reg -> Doc
+pprUserReg = pprReg IF_ARCH_i386(II32,) IF_ARCH_x86_64(II64,)
+
+#else
+pprUserReg :: Reg -> Doc
+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)
+ where
+#if i386_TARGET_ARCH
+ ppr_reg_no :: Size -> Int -> Doc
+ ppr_reg_no II8 = ppr_reg_byte
+ ppr_reg_no II16 = ppr_reg_word
+ ppr_reg_no _ = ppr_reg_long
+
+ ppr_reg_byte i = ptext
+ (case i of {
+ 0 -> sLit "%al"; 1 -> sLit "%bl";
+ 2 -> sLit "%cl"; 3 -> sLit "%dl";
+ _ -> sLit "very naughty I386 byte register"
+ })
+
+ ppr_reg_word i = ptext
+ (case i of {
+ 0 -> sLit "%ax"; 1 -> sLit "%bx";
+ 2 -> sLit "%cx"; 3 -> sLit "%dx";
+ 4 -> sLit "%si"; 5 -> sLit "%di";
+ 6 -> sLit "%bp"; 7 -> sLit "%sp";
+ _ -> sLit "very naughty I386 word register"
+ })
+
+ ppr_reg_long i = ptext
+ (case i of {
+ 0 -> sLit "%eax"; 1 -> sLit "%ebx";
+ 2 -> sLit "%ecx"; 3 -> sLit "%edx";
+ 4 -> sLit "%esi"; 5 -> sLit "%edi";
+ 6 -> sLit "%ebp"; 7 -> sLit "%esp";
+ 8 -> sLit "%fake0"; 9 -> sLit "%fake1";
+ 10 -> sLit "%fake2"; 11 -> sLit "%fake3";
+ 12 -> sLit "%fake4"; 13 -> sLit "%fake5";
+ _ -> sLit "very naughty I386 register"
+ })
+#elif x86_64_TARGET_ARCH
+ ppr_reg_no :: Size -> Int -> Doc
+ ppr_reg_no II8 = ppr_reg_byte
+ ppr_reg_no II16 = ppr_reg_word
+ ppr_reg_no II32 = ppr_reg_long
+ ppr_reg_no _ = ppr_reg_quad
+
+ ppr_reg_byte i = ptext
+ (case i of {
+ 0 -> sLit "%al"; 1 -> sLit "%bl";
+ 2 -> sLit "%cl"; 3 -> sLit "%dl";
+ 4 -> sLit "%sil"; 5 -> sLit "%dil"; -- new 8-bit regs!
+ 6 -> sLit "%bpl"; 7 -> sLit "%spl";
+ 8 -> sLit "%r8b"; 9 -> sLit "%r9b";
+ 10 -> sLit "%r10b"; 11 -> sLit "%r11b";
+ 12 -> sLit "%r12b"; 13 -> sLit "%r13b";
+ 14 -> sLit "%r14b"; 15 -> sLit "%r15b";
+ _ -> sLit "very naughty x86_64 byte register"
+ })
+
+ ppr_reg_word i = ptext
+ (case i of {
+ 0 -> sLit "%ax"; 1 -> sLit "%bx";
+ 2 -> sLit "%cx"; 3 -> sLit "%dx";
+ 4 -> sLit "%si"; 5 -> sLit "%di";
+ 6 -> sLit "%bp"; 7 -> sLit "%sp";
+ 8 -> sLit "%r8w"; 9 -> sLit "%r9w";
+ 10 -> sLit "%r10w"; 11 -> sLit "%r11w";
+ 12 -> sLit "%r12w"; 13 -> sLit "%r13w";
+ 14 -> sLit "%r14w"; 15 -> sLit "%r15w";
+ _ -> sLit "very naughty x86_64 word register"
+ })
+
+ ppr_reg_long i = ptext
+ (case i of {
+ 0 -> sLit "%eax"; 1 -> sLit "%ebx";
+ 2 -> sLit "%ecx"; 3 -> sLit "%edx";
+ 4 -> sLit "%esi"; 5 -> sLit "%edi";
+ 6 -> sLit "%ebp"; 7 -> sLit "%esp";
+ 8 -> sLit "%r8d"; 9 -> sLit "%r9d";
+ 10 -> sLit "%r10d"; 11 -> sLit "%r11d";
+ 12 -> sLit "%r12d"; 13 -> sLit "%r13d";
+ 14 -> sLit "%r14d"; 15 -> sLit "%r15d";
+ _ -> sLit "very naughty x86_64 register"
+ })
+
+ ppr_reg_quad i = ptext
+ (case i of {
+ 0 -> sLit "%rax"; 1 -> sLit "%rbx";
+ 2 -> sLit "%rcx"; 3 -> sLit "%rdx";
+ 4 -> sLit "%rsi"; 5 -> sLit "%rdi";
+ 6 -> sLit "%rbp"; 7 -> sLit "%rsp";
+ 8 -> sLit "%r8"; 9 -> sLit "%r9";
+ 10 -> sLit "%r10"; 11 -> sLit "%r11";
+ 12 -> sLit "%r12"; 13 -> sLit "%r13";
+ 14 -> sLit "%r14"; 15 -> sLit "%r15";
+ 16 -> sLit "%xmm0"; 17 -> sLit "%xmm1";
+ 18 -> sLit "%xmm2"; 19 -> sLit "%xmm3";
+ 20 -> sLit "%xmm4"; 21 -> sLit "%xmm5";
+ 22 -> sLit "%xmm6"; 23 -> sLit "%xmm7";
+ 24 -> sLit "%xmm8"; 25 -> sLit "%xmm9";
+ 26 -> sLit "%xmm10"; 27 -> sLit "%xmm11";
+ 28 -> sLit "%xmm12"; 29 -> sLit "%xmm13";
+ 30 -> sLit "%xmm14"; 31 -> sLit "%xmm15";
+ _ -> sLit "very naughty x86_64 register"
+ })
+#else
+ ppr_reg_no _ = panic "X86.Ppr.ppr_reg_no: no match"
+#endif
+
+
+pprSize :: Size -> Doc
+pprSize x
+ = ptext (case x of
+ II8 -> sLit "b"
+ II16 -> sLit "w"
+ II32 -> sLit "l"
+ II64 -> sLit "q"
+#if i386_TARGET_ARCH
+ FF32 -> sLit "s"
+ FF64 -> sLit "l"
+ FF80 -> sLit "t"
+#elif x86_64_TARGET_ARCH
+ FF32 -> sLit "ss" -- "scalar single-precision float" (SSE2)
+ FF64 -> sLit "sd" -- "scalar double-precision float" (SSE2)
+#else
+ _ -> panic "X86.Ppr.pprSize: no match"
+#endif
+ )
+
+pprCond :: Cond -> Doc
+pprCond c
+ = ptext (case c of {
+ GEU -> sLit "ae"; LU -> sLit "b";
+ EQQ -> sLit "e"; GTT -> sLit "g";
+ GE -> sLit "ge"; GU -> sLit "a";
+ LTT -> sLit "l"; LE -> sLit "le";
+ LEU -> sLit "be"; NE -> sLit "ne";
+ NEG -> sLit "s"; POS -> sLit "ns";
+ CARRY -> sLit "c"; OFLO -> sLit "o";
+ PARITY -> sLit "p"; NOTPARITY -> sLit "np";
+ ALWAYS -> sLit "mp"})
+
+
+pprImm :: Imm -> Doc
+pprImm (ImmInt i) = int i
+pprImm (ImmInteger i) = integer i
+pprImm (ImmCLbl l) = pprCLabel_asm l
+pprImm (ImmIndex l i) = pprCLabel_asm l <> char '+' <> int i
+pprImm (ImmLit s) = s
+
+pprImm (ImmFloat _) = ptext (sLit "naughty float immediate")
+pprImm (ImmDouble _) = ptext (sLit "naughty double immediate")
+
+pprImm (ImmConstantSum a b) = pprImm a <> char '+' <> pprImm b
+pprImm (ImmConstantDiff a b) = pprImm a <> char '-'
+ <> lparen <> pprImm b <> rparen
+
+
+
+pprAddr :: AddrMode -> Doc
+pprAddr (ImmAddr imm off)
+ = let pp_imm = pprImm imm
+ in
+ if (off == 0) then
+ pp_imm
+ else if (off < 0) then
+ pp_imm <> int off
+ else
+ pp_imm <> char '+' <> int off
+
+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
+ in
+ case (base, index) of
+ (EABaseNone, EAIndexNone) -> pp_disp
+ (EABaseReg b, EAIndexNone) -> pp_off (pp_reg b)
+ (EABaseRip, EAIndexNone) -> pp_off (ptext (sLit "%rip"))
+ (EABaseNone, EAIndex r i) -> pp_off (comma <> pp_reg r <> comma <> int i)
+ (EABaseReg b, EAIndex r i) -> pp_off (pp_reg b <> comma <> pp_reg r
+ <> comma <> int i)
+ _ -> panic "X86.Ppr.pprAddr: no match"
+
+ where
+ ppr_disp (ImmInt 0) = empty
+ ppr_disp imm = pprImm imm
+
+
+pprSectionHeader :: Section -> Doc
+#if i386_TARGET_ARCH
+
+# if darwin_TARGET_OS
+pprSectionHeader seg
+ = case seg of
+ Text -> ptext (sLit ".text\n\t.align 2")
+ Data -> ptext (sLit ".data\n\t.align 2")
+ ReadOnlyData -> ptext (sLit ".const\n.align 2")
+ 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"
+
+# else
+pprSectionHeader seg
+ = case seg of
+ Text -> ptext (sLit ".text\n\t.align 4,0x90")
+ Data -> ptext (sLit ".data\n\t.align 4")
+ ReadOnlyData -> ptext (sLit ".section .rodata\n\t.align 4")
+ 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"
+
+# endif
+
+#elif x86_64_TARGET_ARCH
+# if darwin_TARGET_OS
+pprSectionHeader seg
+ = case seg of
+ Text -> ptext (sLit ".text\n.align 3")
+ Data -> ptext (sLit ".data\n.align 3")
+ ReadOnlyData -> ptext (sLit ".const\n.align 3")
+ 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"
+
+# else
+pprSectionHeader seg
+ = case seg of
+ Text -> ptext (sLit ".text\n\t.align 8")
+ Data -> ptext (sLit ".data\n\t.align 8")
+ ReadOnlyData -> ptext (sLit ".section .rodata\n\t.align 8")
+ 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"
+
+# endif
+
+#else
+pprSectionHeader _ = panic "X86.Ppr.pprSectionHeader: not defined for this architecture"
+
+#endif
+
+
+
+
+pprDataItem :: CmmLit -> Doc
+pprDataItem lit
+ = vcat (ppr_item (cmmTypeSize $ cmmLitType lit) lit)
+ where
+ imm = litToImm lit
+
+ -- These seem to be common:
+ ppr_item II8 _ = [ptext (sLit "\t.byte\t") <> pprImm imm]
+ ppr_item II32 _ = [ptext (sLit "\t.long\t") <> pprImm imm]
+
+ ppr_item FF32 (CmmFloat r _)
+ = let bs = floatToBytes (fromRational r)
+ in map (\b -> ptext (sLit "\t.byte\t") <> pprImm (ImmInt b)) bs
+
+ ppr_item FF64 (CmmFloat r _)
+ = let bs = doubleToBytes (fromRational r)
+ in map (\b -> ptext (sLit "\t.byte\t") <> pprImm (ImmInt b)) bs
+
+#if i386_TARGET_ARCH || x86_64_TARGET_ARCH
+ ppr_item II16 _ = [ptext (sLit "\t.word\t") <> pprImm imm]
+#endif
+#if i386_TARGET_ARCH && darwin_TARGET_OS
+ ppr_item II64 (CmmInt x _) =
+ [ptext (sLit "\t.long\t")
+ <> int (fromIntegral (fromIntegral x :: Word32)),
+ ptext (sLit "\t.long\t")
+ <> int (fromIntegral
+ (fromIntegral (x `shiftR` 32) :: Word32))]
+#endif
+#if i386_TARGET_ARCH || (darwin_TARGET_OS && x86_64_TARGET_ARCH)
+ ppr_item II64 _ = [ptext (sLit "\t.quad\t") <> pprImm imm]
+#endif
+#if x86_64_TARGET_ARCH && !darwin_TARGET_OS
+ -- x86_64: binutils can't handle the R_X86_64_PC64 relocation
+ -- type, which means we can't do pc-relative 64-bit addresses.
+ -- 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 Note [x86-64-relative] in includes/InfoTables.h
+ --
+ ppr_item II64 x
+ | isRelativeReloc x =
+ [ptext (sLit "\t.long\t") <> pprImm imm,
+ ptext (sLit "\t.long\t0")]
+ | otherwise =
+ [ptext (sLit "\t.quad\t") <> pprImm imm]
+ where
+ isRelativeReloc (CmmLabelDiffOff _ _ _) = True
+ isRelativeReloc _ = False
+#endif
+
+ ppr_item _ _
+ = panic "X86.Ppr.ppr_item: no match"
+
+
+
+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(
+ ((<>) (ptext (sLit "# ")) (ftext s)),
+ ((<>) (ptext (sLit "; ")) (ftext s)))
+ ,)))))
+-}
+pprInstr (DELTA d)
+ = pprInstr (COMMENT (mkFastString ("\tdelta = " ++ show d)))
+
+pprInstr (NEWBLOCK _)
+ = panic "PprMach.pprInstr: NEWBLOCK"
+
+pprInstr (LDATA _ _)
+ = panic "PprMach.pprInstr: LDATA"
+
+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
+
+pprInstr (MOVZxL II32 src dst) = pprSizeOpOp (sLit "mov") II32 src dst
+ -- 32-to-64 bit zero extension on x86_64 is accomplished by a simple
+ -- movl. But we represent it as a MOVZxL instruction, because
+ -- the reg alloc would tend to throw away a plain reg-to-reg
+ -- move, and we still want it to do that.
+
+pprInstr (MOVZxL sizes src dst) = pprSizeOpOpCoerce (sLit "movz") sizes II32 src dst
+ -- zero-extension only needs to extend to 32 bits: on x86_64,
+ -- 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
+
+-- here we do some patching, since the physical registers are only set late
+-- in the code generation.
+pprInstr (LEA size (OpAddr (AddrBaseIndex (EABaseReg reg1) (EAIndex reg2 1) (ImmInt 0))) dst@(OpReg reg3))
+ | reg1 == reg3
+ = pprSizeOpOp (sLit "add") size (OpReg reg2) dst
+
+pprInstr (LEA size (OpAddr (AddrBaseIndex (EABaseReg reg1) (EAIndex reg2 1) (ImmInt 0))) dst@(OpReg reg3))
+ | reg2 == reg3
+ = pprSizeOpOp (sLit "add") size (OpReg reg1) dst
+
+pprInstr (LEA size (OpAddr (AddrBaseIndex (EABaseReg reg1) EAIndexNone displ)) dst@(OpReg reg3))
+ | reg1 == reg3
+ = pprInstr (ADD size (OpImm displ) dst)
+
+pprInstr (LEA size src dst) = pprSizeOpOp (sLit "lea") size src dst
+
+pprInstr (ADD size (OpImm (ImmInt (-1))) dst)
+ = pprSizeOp (sLit "dec") size dst
+pprInstr (ADD size (OpImm (ImmInt 1)) dst)
+ = pprSizeOp (sLit "inc") size dst
+pprInstr (ADD size src dst)
+ = pprSizeOpOp (sLit "add") size src dst
+pprInstr (ADC size src dst)
+ = pprSizeOpOp (sLit "adc") size src dst
+pprInstr (SUB size src dst) = pprSizeOpOp (sLit "sub") size src dst
+pprInstr (IMUL size op1 op2) = pprSizeOpOp (sLit "imul") size op1 op2
+
+{- A hack. The Intel documentation says that "The two and three
+ operand forms [of IMUL] may also be used with unsigned operands
+ because the lower half of the product is the same regardless if
+ (sic) the operands are signed or unsigned. The CF and OF flags,
+ however, cannot be used to determine if the upper half of the
+ result is non-zero." So there.
+-}
+pprInstr (AND size src dst) = pprSizeOpOp (sLit "and") size src dst
+pprInstr (OR size src dst) = pprSizeOpOp (sLit "or") size src dst
+
+pprInstr (XOR FF32 src dst) = pprOpOp (sLit "xorps") FF32 src dst
+pprInstr (XOR FF64 src dst) = pprOpOp (sLit "xorpd") FF64 src dst
+pprInstr (XOR size src dst) = pprSizeOpOp (sLit "xor") size src dst
+
+pprInstr (NOT size op) = pprSizeOp (sLit "not") size op
+pprInstr (NEGI size op) = pprSizeOp (sLit "neg") size op
+
+pprInstr (SHL size src dst) = pprShift (sLit "shl") size src dst
+pprInstr (SAR size src dst) = pprShift (sLit "sar") size src dst
+pprInstr (SHR size src dst) = pprShift (sLit "shr") size src dst
+
+pprInstr (BT size imm src) = pprSizeImmOp (sLit "bt") size imm src
+
+pprInstr (CMP size src dst)
+ | is_float size = pprSizeOpOp (sLit "ucomi") size src dst -- SSE2
+ | otherwise = pprSizeOpOp (sLit "cmp") size src dst
+ where
+ -- This predicate is needed here and nowhere else
+ is_float FF32 = True
+ is_float FF64 = True
+ is_float FF80 = True
+ is_float _ = False
+
+pprInstr (TEST size src dst) = pprSizeOpOp (sLit "test") size src dst
+pprInstr (PUSH size op) = pprSizeOp (sLit "push") size op
+pprInstr (POP size op) = pprSizeOp (sLit "pop") size op
+
+-- both unused (SDM):
+-- pprInstr PUSHA = ptext (sLit "\tpushal")
+-- pprInstr POPA = ptext (sLit "\tpopal")
+
+pprInstr NOP = ptext (sLit "\tnop")
+pprInstr (CLTD II32) = ptext (sLit "\tcltd")
+pprInstr (CLTD II64) = ptext (sLit "\tcqto")
+
+pprInstr (SETCC cond op) = pprCondInstr (sLit "set") cond (pprOperand II8 op)
+
+pprInstr (JXX cond (BlockId id))
+ = pprCondInstr (sLit "j") cond (pprCLabel_asm lab)
+ where lab = mkAsmTempLabel 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_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 (IDIV sz op) = pprSizeOp (sLit "idiv") sz op
+pprInstr (DIV sz op) = pprSizeOp (sLit "div") sz op
+pprInstr (IMUL2 sz op) = pprSizeOp (sLit "imul") sz op
+
+-- x86_64 only
+pprInstr (MUL size op1 op2) = pprSizeOpOp (sLit "mul") size op1 op2
+
+pprInstr (FDIV size op1 op2) = pprSizeOpOp (sLit "div") size op1 op2
+
+pprInstr (CVTSS2SD from to) = pprRegReg (sLit "cvtss2sd") from to
+pprInstr (CVTSD2SS from to) = pprRegReg (sLit "cvtsd2ss") from to
+pprInstr (CVTTSS2SIQ from to) = pprOpReg (sLit "cvttss2siq") from to
+pprInstr (CVTTSD2SIQ from to) = pprOpReg (sLit "cvttsd2siq") from to
+pprInstr (CVTSI2SS from to) = pprOpReg (sLit "cvtsi2ssq") from to
+pprInstr (CVTSI2SD from to) = pprOpReg (sLit "cvtsi2sdq") from to
+
+ -- FETCHGOT for PIC on ELF platforms
+pprInstr (FETCHGOT reg)
+ = vcat [ ptext (sLit "\tcall 1f"),
+ hcat [ ptext (sLit "1:\tpopl\t"), pprReg II32 reg ],
+ hcat [ ptext (sLit "\taddl\t$_GLOBAL_OFFSET_TABLE_+(.-1b), "),
+ pprReg II32 reg ]
+ ]
+
+ -- FETCHPC for PIC on Darwin/x86
+ -- get the instruction pointer into a register
+ -- (Terminology note: the IP is called Program Counter on PPC,
+ -- and it's a good thing to use the same name on both platforms)
+pprInstr (FETCHPC reg)
+ = vcat [ ptext (sLit "\tcall 1f"),
+ hcat [ ptext (sLit "1:\tpopl\t"), pprReg II32 reg ]
+ ]
+
+
+-- -----------------------------------------------------------------------------
+-- i386 floating-point
+
+-- Simulating a flat register set on the x86 FP stack is tricky.
+-- you have to free %st(7) before pushing anything on the FP reg stack
+-- so as to preclude the possibility of a FP stack overflow exception.
+pprInstr g@(GMOV src dst)
+ | src == dst
+ = empty
+ | otherwise
+ = pprG g (hcat [gtab, gpush src 0, gsemi, gpop dst 1])
+
+-- GLD sz addr dst ==> FFREE %st(7) ; FLDsz addr ; FSTP (dst+1)
+pprInstr g@(GLD sz addr dst)
+ = pprG g (hcat [gtab, text "ffree %st(7) ; fld", pprSize sz, gsp,
+ pprAddr addr, gsemi, gpop dst 1])
+
+-- GST sz src addr ==> FFREE %st(7) ; FLD dst ; FSTPsz addr
+pprInstr g@(GST sz src addr)
+ = pprG g (hcat [gtab, gpush src 0, gsemi,
+ text "fstp", pprSize sz, gsp, pprAddr addr])
+
+pprInstr g@(GLDZ dst)
+ = pprG g (hcat [gtab, text "ffree %st(7) ; fldz ; ", gpop dst 1])
+pprInstr g@(GLD1 dst)
+ = pprG g (hcat [gtab, text "ffree %st(7) ; fld1 ; ", gpop dst 1])
+
+pprInstr (GFTOI src dst)
+ = pprInstr (GDTOI src dst)
+
+pprInstr g@(GDTOI src dst)
+ = pprG g (vcat [
+ hcat [gtab, text "subl $8, %esp ; fnstcw 4(%esp)"],
+ hcat [gtab, gpush src 0],
+ hcat [gtab, text "movzwl 4(%esp), ", reg,
+ text " ; orl $0xC00, ", reg],
+ hcat [gtab, text "movl ", reg, text ", 0(%esp) ; fldcw 0(%esp)"],
+ hcat [gtab, text "fistpl 0(%esp)"],
+ hcat [gtab, text "fldcw 4(%esp) ; movl 0(%esp), ", reg],
+ hcat [gtab, text "addl $8, %esp"]
+ ])
+ where
+ reg = pprReg II32 dst
+
+pprInstr (GITOF src dst)
+ = pprInstr (GITOD src dst)
+
+pprInstr g@(GITOD src dst)
+ = pprG g (hcat [gtab, text "pushl ", pprReg II32 src,
+ text " ; ffree %st(7); fildl (%esp) ; ",
+ gpop dst 1, text " ; addl $4,%esp"])
+
+{- Gruesome swamp follows. If you're unfortunate enough to have ventured
+ this far into the jungle AND you give a Rat's Ass (tm) what's going
+ on, here's the deal. Generate code to do a floating point comparison
+ of src1 and src2, of kind cond, and set the Zero flag if true.
+
+ The complications are to do with handling NaNs correctly. We want the
+ property that if either argument is NaN, then the result of the
+ comparison is False ... except if we're comparing for inequality,
+ in which case the answer is True.
+
+ Here's how the general (non-inequality) case works. As an
+ example, consider generating the an equality test:
+
+ pushl %eax -- we need to mess with this
+ <get src1 to top of FPU stack>
+ fcomp <src2 location in FPU stack> and pop pushed src1
+ -- Result of comparison is in FPU Status Register bits
+ -- C3 C2 and C0
+ fstsw %ax -- Move FPU Status Reg to %ax
+ sahf -- move C3 C2 C0 from %ax to integer flag reg
+ -- now the serious magic begins
+ setpo %ah -- %ah = if comparable(neither arg was NaN) then 1 else 0
+ sete %al -- %al = if arg1 == arg2 then 1 else 0
+ andb %ah,%al -- %al &= %ah
+ -- so %al == 1 iff (comparable && same); else it holds 0
+ decb %al -- %al == 0, ZeroFlag=1 iff (comparable && same);
+ else %al == 0xFF, ZeroFlag=0
+ -- the zero flag is now set as we desire.
+ popl %eax
+
+ The special case of inequality differs thusly:
+
+ setpe %ah -- %ah = if incomparable(either arg was NaN) then 1 else 0
+ setne %al -- %al = if arg1 /= arg2 then 1 else 0
+ orb %ah,%al -- %al = if (incomparable || different) then 1 else 0
+ decb %al -- if (incomparable || different) then (%al == 0, ZF=1)
+ else (%al == 0xFF, ZF=0)
+-}
+pprInstr g@(GCMP cond src1 src2)
+ | case cond of { NE -> True; _ -> False }
+ = pprG g (vcat [
+ hcat [gtab, text "pushl %eax ; ",gpush src1 0],
+ hcat [gtab, text "fcomp ", greg src2 1,
+ text "; fstsw %ax ; sahf ; setpe %ah"],
+ hcat [gtab, text "setne %al ; ",
+ text "orb %ah,%al ; decb %al ; popl %eax"]
+ ])
+ | otherwise
+ = pprG g (vcat [
+ hcat [gtab, text "pushl %eax ; ",gpush src1 0],
+ hcat [gtab, text "fcomp ", greg src2 1,
+ text "; fstsw %ax ; sahf ; setpo %ah"],
+ hcat [gtab, text "set", pprCond (fix_FP_cond cond), text " %al ; ",
+ text "andb %ah,%al ; decb %al ; popl %eax"]
+ ])
+ where
+ {- On the 486, the flags set by FP compare are the unsigned ones!
+ (This looks like a HACK to me. WDP 96/03)
+ -}
+ fix_FP_cond :: Cond -> Cond
+ fix_FP_cond GE = GEU
+ fix_FP_cond GTT = GU
+ fix_FP_cond LTT = LU
+ fix_FP_cond LE = LEU
+ fix_FP_cond EQQ = EQQ
+ fix_FP_cond NE = NE
+ fix_FP_cond _ = panic "X86.Ppr.fix_FP_cond: no match"
+ -- there should be no others
+
+
+pprInstr g@(GABS _ src dst)
+ = pprG g (hcat [gtab, gpush src 0, text " ; fabs ; ", gpop dst 1])
+
+pprInstr g@(GNEG _ src dst)
+ = pprG g (hcat [gtab, gpush src 0, text " ; fchs ; ", gpop dst 1])
+
+pprInstr g@(GSQRT sz src dst)
+ = pprG g (hcat [gtab, gpush src 0, text " ; fsqrt"] $$
+ hcat [gtab, gcoerceto sz, gpop dst 1])
+
+pprInstr g@(GSIN sz l1 l2 src dst)
+ = pprG g (pprTrigOp "fsin" False l1 l2 src dst sz)
+
+pprInstr g@(GCOS sz l1 l2 src dst)
+ = pprG g (pprTrigOp "fcos" False l1 l2 src dst sz)
+
+pprInstr g@(GTAN sz l1 l2 src dst)
+ = pprG g (pprTrigOp "fptan" True l1 l2 src dst sz)
+
+-- In the translations for GADD, GMUL, GSUB and GDIV,
+-- the first two cases are mere optimisations. The otherwise clause
+-- generates correct code under all circumstances.
+
+pprInstr g@(GADD _ src1 src2 dst)
+ | src1 == dst
+ = pprG g (text "\t#GADD-xxxcase1" $$
+ hcat [gtab, gpush src2 0,
+ text " ; faddp %st(0),", greg src1 1])
+ | src2 == dst
+ = pprG g (text "\t#GADD-xxxcase2" $$
+ hcat [gtab, gpush src1 0,
+ text " ; faddp %st(0),", greg src2 1])
+ | otherwise
+ = pprG g (hcat [gtab, gpush src1 0,
+ text " ; fadd ", greg src2 1, text ",%st(0)",
+ gsemi, gpop dst 1])
+
+
+pprInstr g@(GMUL _ src1 src2 dst)
+ | src1 == dst
+ = pprG g (text "\t#GMUL-xxxcase1" $$
+ hcat [gtab, gpush src2 0,
+ text " ; fmulp %st(0),", greg src1 1])
+ | src2 == dst
+ = pprG g (text "\t#GMUL-xxxcase2" $$
+ hcat [gtab, gpush src1 0,
+ text " ; fmulp %st(0),", greg src2 1])
+ | otherwise
+ = pprG g (hcat [gtab, gpush src1 0,
+ text " ; fmul ", greg src2 1, text ",%st(0)",
+ gsemi, gpop dst 1])
+
+
+pprInstr g@(GSUB _ src1 src2 dst)
+ | src1 == dst
+ = pprG g (text "\t#GSUB-xxxcase1" $$
+ hcat [gtab, gpush src2 0,
+ text " ; fsubrp %st(0),", greg src1 1])
+ | src2 == dst
+ = pprG g (text "\t#GSUB-xxxcase2" $$
+ hcat [gtab, gpush src1 0,
+ text " ; fsubp %st(0),", greg src2 1])
+ | otherwise
+ = pprG g (hcat [gtab, gpush src1 0,
+ text " ; fsub ", greg src2 1, text ",%st(0)",
+ gsemi, gpop dst 1])
+
+
+pprInstr g@(GDIV _ src1 src2 dst)
+ | src1 == dst
+ = pprG g (text "\t#GDIV-xxxcase1" $$
+ hcat [gtab, gpush src2 0,
+ text " ; fdivrp %st(0),", greg src1 1])
+ | src2 == dst
+ = pprG g (text "\t#GDIV-xxxcase2" $$
+ hcat [gtab, gpush src1 0,
+ text " ; fdivp %st(0),", greg src2 1])
+ | otherwise
+ = pprG g (hcat [gtab, gpush src1 0,
+ text " ; fdiv ", greg src2 1, text ",%st(0)",
+ gsemi, gpop dst 1])
+
+
+pprInstr GFREE
+ = vcat [ ptext (sLit "\tffree %st(0) ;ffree %st(1) ;ffree %st(2) ;ffree %st(3)"),
+ ptext (sLit "\tffree %st(4) ;ffree %st(5) ;ffree %st(6) ;ffree %st(7)")
+ ]
+
+pprInstr _
+ = panic "X86.Ppr.pprInstr: no match"
+
+
+pprTrigOp :: String -> Bool -> CLabel -> CLabel -> Reg -> Reg -> Size -> Doc
+pprTrigOp op -- fsin, fcos or fptan
+ isTan -- we need a couple of extra steps if we're doing tan
+ l1 l2 -- internal labels for us to use
+ src dst sz
+ = -- We'll be needing %eax later on
+ hcat [gtab, text "pushl %eax;"] $$
+ -- tan is going to use an extra space on the FP stack
+ (if isTan then hcat [gtab, text "ffree %st(6)"] else empty) $$
+ -- First put the value in %st(0) and try to apply the op to it
+ hcat [gpush src 0, text ("; " ++ op)] $$
+ -- Now look to see if C2 was set (overflow, |value| >= 2^63)
+ hcat [gtab, text "fnstsw %ax"] $$
+ hcat [gtab, text "test $0x400,%eax"] $$
+ -- If we were in bounds then jump to the end
+ hcat [gtab, text "je " <> pprCLabel_asm l1] $$
+ -- Otherwise we need to shrink the value. Start by
+ -- loading pi, doubleing it (by adding it to itself),
+ -- and then swapping pi with the value, so the value we
+ -- want to apply op to is in %st(0) again
+ hcat [gtab, text "ffree %st(7); fldpi"] $$
+ hcat [gtab, text "fadd %st(0),%st"] $$
+ hcat [gtab, text "fxch %st(1)"] $$
+ -- Now we have a loop in which we make the value smaller,
+ -- see if it's small enough, and loop if not
+ (pprCLabel_asm l2 <> char ':') $$
+ hcat [gtab, text "fprem1"] $$
+ -- My Debian libc uses fstsw here for the tan code, but I can't
+ -- see any reason why it should need to be different for tan.
+ hcat [gtab, text "fnstsw %ax"] $$
+ hcat [gtab, text "test $0x400,%eax"] $$
+ hcat [gtab, text "jne " <> pprCLabel_asm l2] $$
+ hcat [gtab, text "fstp %st(1)"] $$
+ hcat [gtab, text op] $$
+ (pprCLabel_asm l1 <> char ':') $$
+ -- Pop the 1.0 tan gave us
+ (if isTan then hcat [gtab, text "fstp %st(0)"] else empty) $$
+ -- Restore %eax
+ hcat [gtab, text "popl %eax;"] $$
+ -- And finally make the result the right size
+ hcat [gtab, gcoerceto sz, gpop dst 1]
+
+--------------------------
+
+-- coerce %st(0) to the specified size
+gcoerceto :: Size -> Doc
+gcoerceto FF64 = empty
+gcoerceto FF32 = empty --text "subl $4,%esp ; fstps (%esp) ; flds (%esp) ; addl $4,%esp ; "
+gcoerceto _ = panic "X86.Ppr.gcoerceto: no match"
+
+gpush :: Reg -> RegNo -> Doc
+gpush reg offset
+ = hcat [text "ffree %st(7) ; fld ", greg reg offset]
+
+
+gpop :: Reg -> RegNo -> Doc
+gpop reg offset
+ = hcat [text "fstp ", greg reg offset]
+
+greg :: Reg -> RegNo -> Doc
+greg reg offset = text "%st(" <> int (gregno reg - 8+offset) <> char ')'
+
+gsemi :: Doc
+gsemi = text " ; "
+
+gtab :: Doc
+gtab = char '\t'
+
+gsp :: Doc
+gsp = char ' '
+
+gregno :: Reg -> RegNo
+gregno (RealReg i) = i
+gregno _ = --pprPanic "gregno" (ppr other)
+ 999 -- bogus; only needed for debug printing
+
+pprG :: Instr -> Doc -> Doc
+pprG fake actual
+ = (char '#' <> pprGInstr fake) $$ actual
+
+
+pprGInstr :: Instr -> Doc
+pprGInstr (GMOV src dst) = pprSizeRegReg (sLit "gmov") FF64 src dst
+pprGInstr (GLD sz src dst) = pprSizeAddrReg (sLit "gld") sz src dst
+pprGInstr (GST sz src dst) = pprSizeRegAddr (sLit "gst") sz src dst
+
+pprGInstr (GLDZ dst) = pprSizeReg (sLit "gldz") FF64 dst
+pprGInstr (GLD1 dst) = pprSizeReg (sLit "gld1") FF64 dst
+
+pprGInstr (GFTOI src dst) = pprSizeSizeRegReg (sLit "gftoi") FF32 II32 src dst
+pprGInstr (GDTOI src dst) = pprSizeSizeRegReg (sLit "gdtoi") FF64 II32 src dst
+
+pprGInstr (GITOF src dst) = pprSizeSizeRegReg (sLit "gitof") II32 FF32 src dst
+pprGInstr (GITOD src dst) = pprSizeSizeRegReg (sLit "gitod") II32 FF64 src dst
+
+pprGInstr (GCMP co src dst) = pprCondRegReg (sLit "gcmp_") FF64 co src dst
+pprGInstr (GABS sz src dst) = pprSizeRegReg (sLit "gabs") sz src dst
+pprGInstr (GNEG sz src dst) = pprSizeRegReg (sLit "gneg") sz src dst
+pprGInstr (GSQRT sz src dst) = pprSizeRegReg (sLit "gsqrt") sz src dst
+pprGInstr (GSIN sz _ _ src dst) = pprSizeRegReg (sLit "gsin") sz src dst
+pprGInstr (GCOS sz _ _ src dst) = pprSizeRegReg (sLit "gcos") sz src dst
+pprGInstr (GTAN sz _ _ src dst) = pprSizeRegReg (sLit "gtan") sz src dst
+
+pprGInstr (GADD sz src1 src2 dst) = pprSizeRegRegReg (sLit "gadd") sz src1 src2 dst
+pprGInstr (GSUB sz src1 src2 dst) = pprSizeRegRegReg (sLit "gsub") sz src1 src2 dst
+pprGInstr (GMUL sz src1 src2 dst) = pprSizeRegRegReg (sLit "gmul") sz src1 src2 dst
+pprGInstr (GDIV sz src1 src2 dst) = pprSizeRegRegReg (sLit "gdiv") sz src1 src2 dst
+
+pprGInstr _ = panic "X86.Ppr.pprGInstr: no match"
+
+pprDollImm :: Imm -> Doc
+pprDollImm i = ptext (sLit "$") <> pprImm i
+
+
+pprOperand :: Size -> Operand -> Doc
+pprOperand s (OpReg r) = pprReg s r
+pprOperand _ (OpImm i) = pprDollImm i
+pprOperand _ (OpAddr ea) = pprAddr ea
+
+
+pprMnemonic_ :: LitString -> Doc
+pprMnemonic_ name =
+ char '\t' <> ptext name <> space
+
+
+pprMnemonic :: LitString -> Size -> Doc
+pprMnemonic name size =
+ char '\t' <> ptext name <> pprSize size <> space
+
+
+pprSizeImmOp :: LitString -> Size -> Imm -> Operand -> Doc
+pprSizeImmOp name size imm op1
+ = hcat [
+ pprMnemonic name size,
+ char '$',
+ pprImm imm,
+ comma,
+ pprOperand size op1
+ ]
+
+
+pprSizeOp :: LitString -> Size -> Operand -> Doc
+pprSizeOp name size op1
+ = hcat [
+ pprMnemonic name size,
+ pprOperand size op1
+ ]
+
+
+pprSizeOpOp :: LitString -> Size -> Operand -> Operand -> Doc
+pprSizeOpOp name size op1 op2
+ = hcat [
+ pprMnemonic name size,
+ pprOperand size op1,
+ comma,
+ pprOperand size op2
+ ]
+
+
+pprOpOp :: LitString -> Size -> Operand -> Operand -> Doc
+pprOpOp name size op1 op2
+ = hcat [
+ pprMnemonic_ name,
+ pprOperand size op1,
+ comma,
+ pprOperand size op2
+ ]
+
+
+pprSizeReg :: LitString -> Size -> Reg -> Doc
+pprSizeReg name size reg1
+ = hcat [
+ pprMnemonic name size,
+ pprReg size reg1
+ ]
+
+
+pprSizeRegReg :: LitString -> Size -> Reg -> Reg -> Doc
+pprSizeRegReg name size reg1 reg2
+ = hcat [
+ pprMnemonic name size,
+ pprReg size reg1,
+ comma,
+ pprReg size reg2
+ ]
+
+
+pprRegReg :: LitString -> Reg -> Reg -> Doc
+pprRegReg name reg1 reg2
+ = hcat [
+ pprMnemonic_ name,
+ pprReg wordSize reg1,
+ comma,
+ pprReg wordSize reg2
+ ]
+
+
+pprOpReg :: LitString -> Operand -> Reg -> Doc
+pprOpReg name op1 reg2
+ = hcat [
+ pprMnemonic_ name,
+ pprOperand wordSize op1,
+ comma,
+ pprReg wordSize reg2
+ ]
+
+
+pprCondRegReg :: LitString -> Size -> Cond -> Reg -> Reg -> Doc
+pprCondRegReg name size cond reg1 reg2
+ = hcat [
+ char '\t',
+ ptext name,
+ pprCond cond,
+ space,
+ pprReg size reg1,
+ comma,
+ pprReg size reg2
+ ]
+
+pprSizeSizeRegReg :: LitString -> Size -> Size -> Reg -> Reg -> Doc
+pprSizeSizeRegReg name size1 size2 reg1 reg2
+ = hcat [
+ char '\t',
+ ptext name,
+ pprSize size1,
+ pprSize size2,
+ space,
+ pprReg size1 reg1,
+
+ comma,
+ pprReg size2 reg2
+ ]
+
+
+pprSizeRegRegReg :: LitString -> Size -> Reg -> Reg -> Reg -> Doc
+pprSizeRegRegReg name size reg1 reg2 reg3
+ = hcat [
+ pprMnemonic name size,
+ pprReg size reg1,
+ comma,
+ pprReg size reg2,
+ comma,
+ pprReg size reg3
+ ]
+
+
+pprSizeAddrReg :: LitString -> Size -> AddrMode -> Reg -> Doc
+pprSizeAddrReg name size op dst
+ = hcat [
+ pprMnemonic name size,
+ pprAddr op,
+ comma,
+ pprReg size dst
+ ]
+
+
+pprSizeRegAddr :: LitString -> Size -> Reg -> AddrMode -> Doc
+pprSizeRegAddr name size src op
+ = hcat [
+ pprMnemonic name size,
+ pprReg size src,
+ comma,
+ pprAddr op
+ ]
+
+
+pprShift :: LitString -> Size -> Operand -> Operand -> Doc
+pprShift name size src dest
+ = hcat [
+ pprMnemonic name size,
+ pprOperand II8 src, -- src is 8-bit sized
+ comma,
+ pprOperand size dest
+ ]
+
+
+pprSizeOpOpCoerce :: LitString -> Size -> Size -> Operand -> Operand -> Doc
+pprSizeOpOpCoerce name size1 size2 op1 op2
+ = hcat [ char '\t', ptext name, pprSize size1, pprSize size2, space,
+ pprOperand size1 op1,
+ comma,
+ pprOperand size2 op2
+ ]
+
+
+pprCondInstr :: LitString -> Cond -> Doc -> Doc
+pprCondInstr name cond arg
+ = hcat [ char '\t', ptext name, pprCond cond, space, arg]
+
projects / ghc-hetmet.git / commitdiff