#if sparc_TARGET_ARCH
B -> SLIT("sb")
Bu -> SLIT("ub")
+ H -> SLIT("sh")
+ Hu -> SLIT("uh")
W -> SLIT("")
F -> SLIT("")
DF -> SLIT("d")
pprStSize x = ptext (case x of
B -> SLIT("b")
Bu -> SLIT("b")
+ H -> SLIT("h")
+ Hu -> SLIT("h")
W -> SLIT("")
F -> SLIT("")
DF -> SLIT("d")
pprInstr PUSHA = ptext SLIT("\tpushal")
pprInstr POPA = ptext SLIT("\tpopal")
-pprInstr (NOP) = ptext SLIT("\tnop")
-pprInstr (CLTD) = ptext SLIT("\tcltd")
+pprInstr NOP = ptext SLIT("\tnop")
+pprInstr CLTD = ptext SLIT("\tcltd")
pprInstr (SETCC cond op) = pprCondInstr SLIT("set") cond (pprOperand B op)
pprInstr (JMP dsts (OpImm imm)) = (<>) (ptext SLIT("\tjmp ")) (pprImm imm)
pprInstr (JMP dsts op) = (<>) (ptext SLIT("\tjmp *")) (pprOperand L op)
-pprInstr (CALL imm) = (<>) (ptext SLIT("\tcall ")) (pprImm imm)
+pprInstr (CALL (Left imm)) = (<>) (ptext SLIT("\tcall ")) (pprImm imm)
+pprInstr (CALL (Right reg)) = (<>) (ptext SLIT("\tcall *")) (pprReg L reg)
-- First bool indicates signedness; second whether quot or rem
pprInstr (IQUOT sz src dst) = pprInstr_quotRem True True sz src dst
pprInstr (QUOT sz src dst) = pprInstr_quotRem False True sz src dst
pprInstr (REM sz src dst) = pprInstr_quotRem False False sz src dst
+pprInstr (IMUL64 sd_hi sd_lo) = pprInstr_imul64 sd_hi sd_lo
+
+
-- 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.
text " ; ffree %st(7); fildl (%esp) ; ",
gpop dst 1, text " ; addl $4,%esp"])
-pprInstr g@(GCMP sz src1 src2)
- = pprG g (hcat [gtab, text "pushl %eax ; ",gpush src1 0]
- $$
- hcat [gtab, text "fcomp ", greg src2 1,
- text "; fstsw %ax ; sahf ; popl %eax"])
+{- Gruesome swamp follows. If you're unfortunate enough to have ventured
+ this far into the jungle AND you give a Rat's Ass (tm) what's going
+ on, here's the deal. Generate code to do a floating point comparison
+ of src1 and src2, of kind cond, and set the Zero flag if true.
+
+ The complications are to do with handling NaNs correctly. We want the
+ property that if either argument is NaN, then the result of the
+ comparison is False ... except if we're comparing for inequality,
+ in which case the answer is True.
+
+ Here's how the general (non-inequality) case works. As an
+ example, consider generating the an equality test:
+
+ pushl %eax -- we need to mess with this
+ <get src1 to top of FPU stack>
+ fcomp <src2 location in FPU stack> and pop pushed src1
+ -- Result of comparison is in FPU Status Register bits
+ -- C3 C2 and C0
+ fstsw %ax -- Move FPU Status Reg to %ax
+ sahf -- move C3 C2 C0 from %ax to integer flag reg
+ -- now the serious magic begins
+ setpo %ah -- %ah = if comparable(neither arg was NaN) then 1 else 0
+ sete %al -- %al = if arg1 == arg2 then 1 else 0
+ andb %ah,%al -- %al &= %ah
+ -- so %al == 1 iff (comparable && same); else it holds 0
+ decb %al -- %al == 0, ZeroFlag=1 iff (comparable && same);
+ else %al == 0xFF, ZeroFlag=0
+ -- the zero flag is now set as we desire.
+ popl %eax
+
+ The special case of inequality differs thusly:
+
+ setpe %ah -- %ah = if incomparable(either arg was NaN) then 1 else 0
+ setne %al -- %al = if arg1 /= arg2 then 1 else 0
+ orb %ah,%al -- %al = if (incomparable || different) then 1 else 0
+ decb %al -- if (incomparable || different) then (%al == 0, ZF=1)
+ else (%al == 0xFF, ZF=0)
+-}
+pprInstr g@(GCMP cond src1 src2)
+ | case cond of { NE -> True; other -> False }
+ = pprG g (vcat [
+ hcat [gtab, text "pushl %eax ; ",gpush src1 0],
+ hcat [gtab, text "fcomp ", greg src2 1,
+ text "; fstsw %ax ; sahf ; setpe %ah"],
+ hcat [gtab, text "setne %al ; ",
+ text "orb %ah,%al ; decb %al ; popl %eax"]
+ ])
+ | otherwise
+ = pprG g (vcat [
+ hcat [gtab, text "pushl %eax ; ",gpush src1 0],
+ hcat [gtab, text "fcomp ", greg src2 1,
+ text "; fstsw %ax ; sahf ; setpo %ah"],
+ hcat [gtab, text "set", pprCond (fix_FP_cond cond), text " %al ; ",
+ text "andb %ah,%al ; decb %al ; popl %eax"]
+ ])
+ where
+ {- On the 486, the flags set by FP compare are the unsigned ones!
+ (This looks like a HACK to me. WDP 96/03)
+ -}
+ fix_FP_cond :: Cond -> Cond
+ fix_FP_cond GE = GEU
+ fix_FP_cond GTT = GU
+ fix_FP_cond LTT = LU
+ fix_FP_cond LE = LEU
+ fix_FP_cond EQQ = EQQ
+ fix_FP_cond NE = NE
+ -- there should be no others
+
pprInstr g@(GABS sz src dst)
= pprG g (hcat [gtab, gpush src 0, text " ; fabs ; ", gpop dst 1])
= vcat [
(text "\t# BEGIN " <> fakeInsn),
(text "\tpushl $0; pushl %eax; pushl %edx; pushl " <> pprOperand sz src),
- (text "\tmovl " <> pprOperand sz dst <> text ",%eax; xorl %edx,%edx; cltd"),
+ (text "\tmovl " <> pprOperand sz dst <> text ",%eax; " <> widen_to_64),
(x86op <> text " 0(%esp); movl " <> text resReg <> text ",12(%esp)"),
(text "\tpopl %edx; popl %edx; popl %eax; popl " <> pprOperand sz dst),
(text "\t# END " <> fakeInsn)
]
where
+ widen_to_64 | signed = text "cltd"
+ | not signed = text "xorl %edx,%edx"
x86op = if signed then text "\tidivl" else text "\tdivl"
resReg = if isQuot then "%eax" else "%edx"
opStr | signed = if isQuot then "IQUOT" else "IREM"
fakeInsn = text opStr <+> pprOperand sz src
<> char ',' <+> pprOperand sz dst
+-- Emit code to make hi_reg:lo_reg be the 64-bit product of hi_reg and lo_reg
+pprInstr_imul64 hi_reg lo_reg
+ = let fakeInsn = text "imul64" <+> pp_hi_reg <> comma <+> pp_lo_reg
+ pp_hi_reg = pprReg L hi_reg
+ pp_lo_reg = pprReg L lo_reg
+ in
+ vcat [
+ text "\t# BEGIN " <> fakeInsn,
+ text "\tpushl" <+> pp_hi_reg <> text" ; pushl" <+> pp_lo_reg,
+ text "\tpushl %eax ; pushl %edx",
+ text "\tmovl 12(%esp), %eax ; imull 8(%esp)",
+ text "\tmovl %edx, 12(%esp) ; movl %eax, 8(%esp)",
+ text "\tpopl %edx ; popl %eax",
+ text "\tpopl" <+> pp_lo_reg <> text " ; popl" <+> pp_hi_reg,
+ text "\t# END " <> fakeInsn
+ ]
+
+
--------------------------
-- coerce %st(0) to the specified size
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 (GCMP co src dst) = pprCondRegReg SLIT("gcmp_") DF 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
pprReg size reg2
]
+pprCondRegReg :: FAST_STRING -> 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 :: FAST_STRING -> Size -> Size -> Reg -> Reg -> Doc
pprSizeSizeRegReg name size1 size2 reg1 reg2
= hcat [
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 (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 (SETHI imm reg)
= hcat [
ptext SLIT("\tsethi\t"),
pprInstr (JMP dsts addr) = (<>) (ptext SLIT("\tjmp\t")) (pprAddr addr)
-pprInstr (CALL imm n _)
+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 ]
\end{code}
Continue with SPARC-only printing bits and bobs:
projects / ghc-hetmet.git / blobdiff