From: Ben.Lippmeier@anu.edu.au Date: Thu, 5 Feb 2009 08:12:42 +0000 (+0000) Subject: NCG: Split PprMach into arch specific modules X-Git-Tag: 2009-03-13~80 X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=commitdiff_plain;h=efbf8ab4eabc1636417b3ea0ca3f5aa227491d9a NCG: Split PprMach into arch specific modules - There are still some #ifdefs for choosing between i386, x86_64, linux, darwin and other OS's. - Also reformat SPARC.RegInfo to remove some of the visual noise. --- diff --git a/compiler/ghc.cabal.in b/compiler/ghc.cabal.in index a59649e..2328eca6 100644 --- a/compiler/ghc.cabal.in +++ b/compiler/ghc.cabal.in @@ -459,21 +459,26 @@ Library 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 diff --git a/compiler/nativeGen/Alpha/Ppr.hs b/compiler/nativeGen/Alpha/Ppr.hs new file mode 100644 index 0000000..f48c83c --- /dev/null +++ b/compiler/nativeGen/Alpha/Ppr.hs @@ -0,0 +1,570 @@ + +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 + ] + +-} diff --git a/compiler/nativeGen/PPC/Ppr.hs b/compiler/nativeGen/PPC/Ppr.hs new file mode 100644 index 0000000..ac83600 --- /dev/null +++ b/compiler/nativeGen/PPC/Ppr.hs @@ -0,0 +1,635 @@ +----------------------------------------------------------------------------- +-- +-- 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 + diff --git a/compiler/nativeGen/PprBase.hs b/compiler/nativeGen/PprBase.hs new file mode 100644 index 0000000..5039ae7 --- /dev/null +++ b/compiler/nativeGen/PprBase.hs @@ -0,0 +1,86 @@ +----------------------------------------------------------------------------- +-- +-- 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]) + ) diff --git a/compiler/nativeGen/PprMach.hs b/compiler/nativeGen/PprMach.hs index 88a8f3f..532d852 100644 --- a/compiler/nativeGen/PprMach.hs +++ b/compiler/nativeGen/PprMach.hs @@ -26,6 +26,8 @@ module PprMach ( #include "HsVersions.h" +import PprBase + import BlockId import Cmm import Regs -- may differ per-platform @@ -51,18 +53,24 @@ import Control.Monad.ST 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) @@ -106,588 +114,6 @@ pprBasicBlock (BasicBlock (BlockId id) instrs) = 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 @@ -746,1863 +172,12 @@ 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 - - fcomp 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]) - ) diff --git a/compiler/nativeGen/SPARC/Instr.hs b/compiler/nativeGen/SPARC/Instr.hs index 12e5649..9c33231 100644 --- a/compiler/nativeGen/SPARC/Instr.hs +++ b/compiler/nativeGen/SPARC/Instr.hs @@ -32,6 +32,7 @@ import FastString import GHC.Exts +-- | Branch condition codes. data Cond = ALWAYS | EQQ @@ -51,34 +52,30 @@ data Cond | 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 @@ -87,7 +84,7 @@ data Instr -- | 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 @@ -113,7 +110,7 @@ data Instr | 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 @@ -123,12 +120,18 @@ data Instr | 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 @@ -146,15 +149,18 @@ data Instr | 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 diff --git a/compiler/nativeGen/SPARC/Ppr.hs b/compiler/nativeGen/SPARC/Ppr.hs new file mode 100644 index 0000000..7d64df1 --- /dev/null +++ b/compiler/nativeGen/SPARC/Ppr.hs @@ -0,0 +1,623 @@ +----------------------------------------------------------------------------- +-- +-- 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" + diff --git a/compiler/nativeGen/SPARC/RegInfo.hs b/compiler/nativeGen/SPARC/RegInfo.hs index b2ca93d..8f8a977 100644 --- a/compiler/nativeGen/SPARC/RegInfo.hs +++ b/compiler/nativeGen/SPARC/RegInfo.hs @@ -34,7 +34,6 @@ module SPARC.RegInfo ( where - #include "nativeGen/NCG.h" #include "HsVersions.h" @@ -48,146 +47,155 @@ import Constants ( rESERVED_C_STACK_BYTES ) 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 -- ----------------------------------------------------------------------------- @@ -236,21 +244,6 @@ patchJump insn old new _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 @@ -263,19 +256,16 @@ shortcutJump _ other = other - --- ----------------------------------------------------------------------------- --- 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 @@ -285,57 +275,86 @@ mkSpillInstr reg _ slot 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) diff --git a/compiler/nativeGen/X86/Instr.hs b/compiler/nativeGen/X86/Instr.hs index 23a6e06..0dea1dd 100644 --- a/compiler/nativeGen/X86/Instr.hs +++ b/compiler/nativeGen/X86/Instr.hs @@ -18,10 +18,8 @@ import RegsBase import Cmm import FastString -#if i386_TARGET_ARCH import CLabel import Panic -#endif data Cond = ALWAYS -- What's really used? ToDo @@ -201,9 +199,7 @@ data Instr | 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 @@ -241,14 +237,11 @@ data Instr | 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) @@ -266,7 +259,7 @@ data Instr -- compare single/double prec floating point respectively. | SQRT Size Operand Reg -- src, dst -#endif + -- Comparison | TEST Size Operand Operand @@ -307,7 +300,7 @@ data 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 ]) @@ -350,4 +343,3 @@ is_G_instr instr GTAN{} -> True GFREE -> panic "is_G_instr: GFREE (!)" _ -> False -#endif /* i386_TARGET_ARCH */ diff --git a/compiler/nativeGen/X86/Ppr.hs b/compiler/nativeGen/X86/Ppr.hs new file mode 100644 index 0000000..c0ad496 --- /dev/null +++ b/compiler/nativeGen/X86/Ppr.hs @@ -0,0 +1,1041 @@ +----------------------------------------------------------------------------- +-- +-- 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 + + fcomp 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] +