import CLabel ( pprCLabel_asm, externallyVisibleCLabel )
import CStrings ( charToC )
import Maybes ( maybeToBool )
-import Stix ( CodeSegment(..) )
+import Stix ( CodeSegment(..), StixTree(..) )
import Char ( isPrint, isDigit )
import Outputable
+
+import ST
+import MutableArray
+import Char ( ord )
\end{code}
%************************************************************************
_ -> 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
\begin{code}
pprInstr :: Instr -> SDoc
---pprInstr (COMMENT s) = (<>) (ptext SLIT("# ")) (ptext s)
-pprInstr (COMMENT s) = empty -- nuke 'em
---alpha: = (<>) (ptext SLIT("\t# ")) (ptext s)
---i386 : = (<>) (ptext SLIT("# ")) (ptext s)
---sparc: = (<>) (ptext SLIT("! ")) (ptext s)
+--pprInstr (COMMENT s) = empty -- nuke 'em
+pprInstr (COMMENT s)
+ = IF_ARCH_alpha( ((<>) (ptext SLIT("\t# ")) (ptext s))
+ ,IF_ARCH_sparc( ((<>) (ptext SLIT("! ")) (ptext s))
+ ,IF_ARCH_i386( ((<>) (ptext SLIT("# ")) (ptext s))
+ ,)))
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((_PK_ ".text\n\t.align 2\x2c\&0x90") {-needs per-OS variation!-}
+ ,IF_ARCH_i386(SLIT(".text\n\t.align 4,0x90") {-needs per-OS variation!-}
,)))
pprInstr (SEGMENT DataSegment)
= ptext
IF_ARCH_alpha(SLIT("\t.data\n\t.align 3")
,IF_ARCH_sparc(SLIT("\t.data\n\t.align 8") {-<8 will break double constants -}
- ,IF_ARCH_i386(SLIT(".data\n\t.align 2")
+ ,IF_ARCH_i386(SLIT(".data\n\t.align 4")
,)))
pprInstr (LABEL clab)
| isDigit d = (<>) (text (charToC c)) (asciify cs 0)
| otherwise = (<>) (text (charToC c)) (asciify cs (n-1))
+#if 0
pprInstr (DATA s xs)
= vcat [(<>) (ptext pp_size) (pprImm x) | x <- xs]
where
#if alpha_TARGET_ARCH
B -> SLIT("\t.byte\t")
BU -> SLIT("\t.byte\t")
---UNUSED: W -> SLIT("\t.word\t")
---UNUSED: WU -> SLIT("\t.word\t")
---UNUSED: L -> SLIT("\t.long\t")
Q -> SLIT("\t.quad\t")
---UNUSED: FF -> SLIT("\t.f_floating\t")
---UNUSED: DF -> SLIT("\t.d_floating\t")
---UNUSED: GF -> SLIT("\t.g_floating\t")
---UNUSED: SF -> SLIT("\t.s_floating\t")
TF -> SLIT("\t.t_floating\t")
#endif
#if i386_TARGET_ARCH
B -> SLIT("\t.byte\t")
---UNUSED: HB -> SLIT("\t.byte\t")
---UNUSED: S -> SLIT("\t.word\t")
L -> SLIT("\t.long\t")
F -> SLIT("\t.float\t")
DF -> SLIT("\t.double\t")
W -> SLIT("\t.word\t")
DF -> SLIT("\t.double\t")
#endif
+#endif
+
+
+pprInstr (DATA s xs)
+ = 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]
+ ppr_item F (ImmDouble r)
+ = let bs = floatToBytes (fromRational r)
+ in map (\b -> text "\t.byte\t" <> pprImm (ImmInt b)) bs
+ ppr_item DF (ImmDouble r)
+ = let bs = doubleToBytes (fromRational r)
+ in map (\b -> text "\t.byte\t" <> pprImm (ImmInt b)) bs
+
+ floatToBytes :: Float -> [Int]
+ floatToBytes f
+ = runST (do
+ arr <- newFloatArray ((0::Int),3)
+ writeFloatArray arr 0 f
+ i0 <- readCharArray arr 0
+ i1 <- readCharArray arr 1
+ i2 <- readCharArray arr 2
+ i3 <- readCharArray arr 3
+ return (map ord [i0,i1,i2,i3])
+ )
+
+ doubleToBytes :: Double -> [Int]
+ doubleToBytes d
+ = runST (do
+ arr <- newDoubleArray ((0::Int),7)
+ writeDoubleArray arr 0 d
+ i0 <- readCharArray arr 0
+ i1 <- readCharArray arr 1
+ i2 <- readCharArray arr 2
+ i3 <- readCharArray arr 3
+ i4 <- readCharArray arr 4
+ i5 <- readCharArray arr 5
+ i6 <- readCharArray arr 6
+ i7 <- readCharArray arr 7
+ return (map ord [i0,i1,i2,i3,i4,i5,i6,i7])
+ )
+
+#endif
-- fall through to rest of (machine-specific) pprInstr...
\end{code}
where
pp_lab = pprCLabel_asm clab
- pp_ldgp = ptext SLIT(":\n\tldgp $29,0($27)\n")
- pp_frame = ptext SLIT("..ng:\n\t.frame $30,4240,$26,0\n\t.prologue 1")
+ -- 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)
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
+pprInstr PUSHA = ptext SLIT("\tpushal")
+pprInstr POPA = ptext SLIT("\tpopal")
pprInstr (NOP) = ptext SLIT("\tnop")
pprInstr (CLTD) = ptext SLIT("\tcltd")
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@(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
+
+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 (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:
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 [
projects / ghc-hetmet.git / blobdiff