\begin{code}
#include "nativeGen/NCG.h"
-module PprMach ( pprInstr ) where
+module PprMach ( pprInstr, pprSize ) where
#include "HsVersions.h"
_ -> SLIT("very naughty I386 byte register")
})
- {- UNUSED:
+{- UNUSED:
ppr_reg_no HB i = ptext
(case i of {
ILIT( 0) -> SLIT("%ah"); ILIT( 1) -> SLIT("%bh");
ILIT( 2) -> SLIT("%ch"); ILIT( 3) -> SLIT("%dh");
_ -> SLIT("very naughty I386 high byte register")
})
- -}
+-}
{- UNUSED:
ppr_reg_no S i = ptext
ppr_reg_no F i = ptext
(case i of {
- --ToDo: rm these (???)
- ILIT( 8) -> SLIT("%st(0)"); ILIT( 9) -> SLIT("%st(1)");
- ILIT(10) -> SLIT("%st(2)"); ILIT(11) -> SLIT("%st(3)");
- ILIT(12) -> SLIT("%st(4)"); ILIT(13) -> SLIT("%st(5)");
- ILIT(14) -> SLIT("%st(6)"); ILIT(15) -> SLIT("%st(7)");
+ ILIT( 8) -> SLIT("%fake0"); ILIT( 9) -> SLIT("%fake1");
+ ILIT(10) -> SLIT("%fake2"); ILIT(11) -> SLIT("%fake3");
+ ILIT(12) -> SLIT("%fake4"); ILIT(13) -> SLIT("%fake5");
_ -> SLIT("very naughty I386 float register")
})
ppr_reg_no DF i = ptext
(case i of {
- --ToDo: rm these (???)
- ILIT( 8) -> SLIT("%st(0)"); ILIT( 9) -> SLIT("%st(1)");
- ILIT(10) -> SLIT("%st(2)"); ILIT(11) -> SLIT("%st(3)");
- ILIT(12) -> SLIT("%st(4)"); ILIT(13) -> SLIT("%st(5)");
- ILIT(14) -> SLIT("%st(6)"); ILIT(15) -> SLIT("%st(7)");
+ ILIT( 8) -> SLIT("%fake0"); ILIT( 9) -> SLIT("%fake1");
+ ILIT(10) -> SLIT("%fake2"); ILIT(11) -> SLIT("%fake3");
+ ILIT(12) -> SLIT("%fake4"); ILIT(13) -> SLIT("%fake5");
_ -> SLIT("very naughty I386 float register")
})
#endif
,)))
pprInstr (SEGMENT TextSegment)
- = ptext
- IF_ARCH_alpha(SLIT("\t.text\n\t.align 3") {-word boundary-}
- ,IF_ARCH_sparc(SLIT("\t.text\n\t.align 4") {-word boundary-}
- ,IF_ARCH_i386(SLIT(".text\n\t.align 4") {-needs per-OS variation!-}
- ,)))
+ = IF_ARCH_alpha(ptext SLIT("\t.text\n\t.align 3") {-word boundary-}
+ ,IF_ARCH_sparc(ptext SLIT("\t.text\n\t.align 4") {-word boundary-}
+ ,IF_ARCH_i386((text ".text\n\t.align 4,0x90") {-needs per-OS variation!-}
+ ,)))
pprInstr (SEGMENT DataSegment)
= ptext
= vcat (concatMap (ppr_item s) xs)
where
#if alpha_TARGET_ARCH
+ ppr_item = error "ppr_item on Alpha"
+#if 0
This needs to be fixed.
B -> SLIT("\t.byte\t")
BU -> SLIT("\t.byte\t")
Q -> SLIT("\t.quad\t")
TF -> SLIT("\t.t_floating\t")
#endif
+#endif
+#if sparc_TARGET_ARCH
+ ppr_item = error "ppr_item on Sparc"
+#if 0
+ This needs to be fixed.
+ B -> SLIT("\t.byte\t")
+ BU -> SLIT("\t.byte\t")
+ W -> SLIT("\t.word\t")
+ DF -> SLIT("\t.double\t")
+#endif
+#endif
#if i386_TARGET_ARCH
ppr_item B x = [text "\t.byte\t" <> pprImm x]
ppr_item L x = [text "\t.long\t" <> pprImm x]
)
#endif
-#if sparc_TARGET_ARCH
- This needs to be fixed.
- B -> SLIT("\t.byte\t")
- BU -> SLIT("\t.byte\t")
- W -> SLIT("\t.word\t")
- DF -> SLIT("\t.double\t")
-#endif
-- fall through to rest of (machine-specific) pprInstr...
\end{code}
#ifdef DEBUG
(<>) (ptext SLIT("# warning: ")) (pprSizeOpOp SLIT("mov") size s d)
#else
- (ptext SLIT(""))
+ empty
#endif
pprInstr (MOV size src dst)
= pprSizeOpOp SLIT("mov") size src dst
-pprInstr (MOVZX size src dst) = pprSizeOpOpCoerce SLIT("movzx") L size src dst
-pprInstr (MOVSX size src dst) = pprSizeOpOpCoerce SLIT("movxs") L size src dst
+pprInstr (MOVZxL sizes src dst) = pprSizeOpOpCoerce SLIT("movz") sizes L src dst
+pprInstr (MOVSxL sizes src dst) = pprSizeOpOpCoerce SLIT("movs") sizes L src dst
-- here we do some patching, since the physical registers are only set late
-- in the code generation.
pprInstr (NOT size op) = pprSizeOp SLIT("not") size op
pprInstr (NEGI size op) = pprSizeOp SLIT("neg") size op
-pprInstr (SHL size imm dst) = pprSizeByteOpOp SLIT("shl") size imm dst
-pprInstr (SAR size imm dst) = pprSizeByteOpOp SLIT("sar") size imm dst
-pprInstr (SHR size imm dst) = pprSizeByteOpOp SLIT("shr") size imm dst
+pprInstr (SHL size imm dst) = pprSizeImmOp SLIT("shl") size imm dst
+pprInstr (SAR size imm dst) = pprSizeImmOp SLIT("sar") size imm dst
+pprInstr (SHR size imm dst) = pprSizeImmOp SLIT("shr") size imm dst
+pprInstr (BT size imm src) = pprSizeImmOp SLIT("bt") size imm src
pprInstr (CMP size src dst) = pprSizeOpOp SLIT("cmp") size src dst
pprInstr (TEST size src dst) = pprSizeOpOp SLIT("test") size src dst
pprInstr (JMP (OpImm imm)) = (<>) (ptext SLIT("\tjmp ")) (pprImm imm)
pprInstr (JMP op) = (<>) (ptext SLIT("\tjmp *")) (pprOperand L op)
-
pprInstr (CALL imm)
- = hcat [ ptext SLIT("\tcall "), pprImm imm ]
-
-pprInstr SAHF = ptext SLIT("\tsahf")
-pprInstr FABS = ptext SLIT("\tfabs")
-
-pprInstr (FADD sz src@(OpAddr _))
- = hcat [ptext SLIT("\tfadd"), pprSize sz, space, pprOperand sz src]
-pprInstr (FADD sz src)
- = ptext SLIT("\tfadd")
-pprInstr FADDP
- = ptext SLIT("\tfaddp")
-pprInstr (FMUL sz src)
- = hcat [ptext SLIT("\tfmul"), pprSize sz, space, pprOperand sz src]
-pprInstr FMULP
- = ptext SLIT("\tfmulp")
-pprInstr (FIADD size op) = pprSizeAddr SLIT("fiadd") size op
-pprInstr FCHS = ptext SLIT("\tfchs")
-pprInstr (FCOM size op) = pprSizeOp SLIT("fcom") size op
-pprInstr FCOS = ptext SLIT("\tfcos")
-pprInstr (FIDIV size op) = pprSizeAddr SLIT("fidiv") size op
-pprInstr (FDIV sz src)
- = hcat [ptext SLIT("\tfdiv"), pprSize sz, space, pprOperand sz src]
-pprInstr FDIVP
- = ptext SLIT("\tfdivp")
-pprInstr (FDIVR sz src)
- = hcat [ptext SLIT("\tfdivr"), pprSize sz, space, pprOperand sz src]
-pprInstr FDIVRP
- = ptext SLIT("\tfdivpr")
-pprInstr (FIDIVR size op) = pprSizeAddr SLIT("fidivr") size op
-pprInstr (FICOM size op) = pprSizeAddr SLIT("ficom") size op
-pprInstr (FILD sz op reg) = pprSizeAddrReg SLIT("fild") sz op reg
-pprInstr (FIST size op) = pprSizeAddr SLIT("fist") size op
-pprInstr (FLD sz (OpImm (ImmCLbl src)))
- = hcat [ptext SLIT("\tfld"),pprSize sz,space,pprCLabel_asm src]
-pprInstr (FLD sz src)
- = hcat [ptext SLIT("\tfld"),pprSize sz,space,pprOperand sz src]
-pprInstr FLD1 = ptext SLIT("\tfld1")
-pprInstr FLDZ = ptext SLIT("\tfldz")
-pprInstr (FIMUL size op) = pprSizeAddr SLIT("fimul") size op
-pprInstr FRNDINT = ptext SLIT("\tfrndint")
-pprInstr FSIN = ptext SLIT("\tfsin")
-pprInstr FSQRT = ptext SLIT("\tfsqrt")
-pprInstr (FST sz dst)
- = hcat [ptext SLIT("\tfst"), pprSize sz, space, pprOperand sz dst]
-pprInstr (FSTP sz dst)
- = hcat [ptext SLIT("\tfstp"), pprSize sz, space, pprOperand sz dst]
-pprInstr (FISUB size op) = pprSizeAddr SLIT("fisub") size op
-pprInstr (FSUB sz src)
- = hcat [ptext SLIT("\tfsub"), pprSize sz, space, pprOperand sz src]
-pprInstr FSUBP
- = ptext SLIT("\tfsubp")
-pprInstr (FSUBR size src)
- = pprSizeOp SLIT("fsubr") size src
-pprInstr FSUBRP
- = ptext SLIT("\tfsubpr")
-pprInstr (FISUBR size op)
- = pprSizeAddr SLIT("fisubr") size op
-pprInstr FTST = ptext SLIT("\tftst")
-pprInstr (FCOMP sz op)
- = hcat [ptext SLIT("\tfcomp"), pprSize sz, space, pprOperand sz op]
-pprInstr FUCOMPP = ptext SLIT("\tfucompp")
-pprInstr FXCH = ptext SLIT("\tfxch")
-pprInstr FNSTSW = ptext SLIT("\tfnstsw %ax")
-pprInstr FNOP = ptext SLIT("")
+ = (<>) (ptext SLIT("\tcall ")) (pprImm imm)
+
+
+-- 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@(GFTOD src dst)
+ = pprG g bogus
+pprInstr g@(GFTOI src dst)
+ = pprG g bogus
+
+pprInstr g@(GDTOF src dst)
+ = pprG g bogus
+pprInstr g@(GDTOI src dst)
+ = pprG g bogus
+
+pprInstr g@(GITOF src dst)
+ = pprG g bogus
+pprInstr g@(GITOD src dst)
+ = pprG g bogus
+
+pprInstr g@(GCMP sz src1 src2)
+ = pprG g (hcat [gtab, text "pushl %eax ; ",
+ gpush src2 0, gsemi, gpush src1 1]
+ $$
+ hcat [gtab, text "fcompp ; fstsw %ax ; sahf ; popl %eax"])
+
+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 ; ", gpop dst 1])
+pprInstr g@(GSIN sz src dst)
+ = pprG g (hcat [gtab, gpush src 0, text " ; fsin ; ", gpop dst 1])
+pprInstr g@(GCOS sz src dst)
+ = pprG g (hcat [gtab, gpush src 0, text " ; fcos ; ", gpop dst 1])
+
+pprInstr g@(GTAN sz src dst)
+ = pprG g (hcat [gtab, text "ffree %st(6) ; ",
+ gpush src 0, text " ; fptan ; ",
+ text " fstp %st(0) ; ", gpop dst 1])
+
+pprInstr g@(GADD sz src1 src2 dst)
+ = pprG g (hcat [gtab, gpush src1 0,
+ text " ; fadd ", greg src2 1, text ",%st(0)",
+ gsemi, gpop dst 1])
+pprInstr g@(GSUB sz src1 src2 dst)
+ = pprG g (hcat [gtab, gpush src1 0,
+ text " ; fsub ", greg src2 1, text ",%st(0)",
+ gsemi, gpop dst 1])
+pprInstr g@(GMUL sz src1 src2 dst)
+ = pprG g (hcat [gtab, gpush src1 0,
+ text " ; fmul ", greg src2 1, text ",%st(0)",
+ gsemi, gpop dst 1])
+pprInstr g@(GDIV sz src1 src2 dst)
+ = 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)")
+ ]
+
+--------------------------
+gpush reg offset
+ = hcat [text "ffree %st(7) ; fld ", greg reg offset]
+gpop reg offset
+ = hcat [text "fstp ", greg reg offset]
+
+bogus = text "\tbogus"
+greg reg offset = text "%st(" <> int (gregno reg - 8+offset) <> char ')'
+gsemi = text " ; "
+gtab = char '\t'
+gsp = char ' '
+gregno (FixedReg i) = I# i
+gregno (MappedReg i) = I# i
+gregno other = pprPanic "gregno" (text (show other))
+
+pprG :: Instr -> SDoc -> SDoc
+pprG fake actual
+ = (char '#' <> pprGInstr fake) $$ actual
+
+pprGInstr (GMOV src dst) = pprSizeRegReg SLIT("gmov") DF 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 (GFTOD src dst) = pprSizeSizeRegReg SLIT("gftod") F DF src dst
+pprGInstr (GFTOI src dst) = pprSizeSizeRegReg SLIT("gftoi") F L src dst
+
+pprGInstr (GDTOF src dst) = pprSizeSizeRegReg SLIT("gdtof") DF F src dst
+pprGInstr (GDTOI src dst) = pprSizeSizeRegReg SLIT("gdtoi") DF L src dst
+
+pprGInstr (GITOF src dst) = pprSizeSizeRegReg SLIT("gitof") L F src dst
+pprGInstr (GITOD src dst) = pprSizeSizeRegReg SLIT("gitod") L DF src dst
+
+pprGInstr (GCMP sz src dst) = pprSizeRegReg SLIT("gcmp") sz 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
\end{code}
Continue with I386-only printing bits and bobs:
pprOperand s (OpImm i) = pprDollImm i
pprOperand s (OpAddr ea) = pprAddr ea
+pprSizeImmOp :: FAST_STRING -> Size -> Imm -> Operand -> SDoc
+pprSizeImmOp name size imm op1
+ = hcat [
+ char '\t',
+ ptext name,
+ pprSize size,
+ space,
+ char '$',
+ pprImm imm,
+ comma,
+ pprOperand size op1
+ ]
+
pprSizeOp :: FAST_STRING -> Size -> Operand -> SDoc
pprSizeOp name size op1
= hcat [
pprReg size reg
]
+pprSizeRegReg :: FAST_STRING -> Size -> Reg -> Reg -> SDoc
+pprSizeRegReg name size reg1 reg2
+ = hcat [
+ char '\t',
+ ptext name,
+ pprSize size,
+ space,
+ pprReg size reg1,
+ comma,
+ pprReg size reg2
+ ]
+
+pprSizeSizeRegReg :: FAST_STRING -> Size -> Size -> Reg -> Reg -> SDoc
+pprSizeSizeRegReg name size1 size2 reg1 reg2
+ = hcat [
+ char '\t',
+ ptext name,
+ pprSize size1,
+ pprSize size2,
+ space,
+ pprReg size1 reg1,
+ comma,
+ pprReg size2 reg2
+ ]
+
+pprSizeRegRegReg :: FAST_STRING -> Size -> Reg -> Reg -> Reg -> SDoc
+pprSizeRegRegReg name size reg1 reg2 reg3
+ = hcat [
+ char '\t',
+ ptext name,
+ pprSize size,
+ space,
+ pprReg size reg1,
+ comma,
+ pprReg size reg2,
+ comma,
+ pprReg size reg3
+ ]
+
pprSizeAddr :: FAST_STRING -> Size -> MachRegsAddr -> SDoc
pprSizeAddr name size op
= hcat [
pprReg size dst
]
+pprSizeRegAddr :: FAST_STRING -> Size -> Reg -> MachRegsAddr -> SDoc
+pprSizeRegAddr name size src op
+ = hcat [
+ char '\t',
+ ptext name,
+ pprSize size,
+ space,
+ pprReg size src,
+ comma,
+ pprAddr op
+ ]
+
pprOpOp :: FAST_STRING -> Size -> Operand -> Operand -> SDoc
pprOpOp name size op1 op2
= hcat [
pprSizeOpOpCoerce :: FAST_STRING -> Size -> Size -> Operand -> Operand -> SDoc
pprSizeOpOpCoerce name size1 size2 op1 op2
- = hcat [ char '\t', ptext name, space,
+ = hcat [ char '\t', ptext name, pprSize size1, pprSize size2, space,
pprOperand size1 op1,
comma,
pprOperand size2 op2
projects / ghc-hetmet.git / blobdiff