import MachMisc
import CLabel ( pprCLabel_asm, externallyVisibleCLabel, labelDynamic )
-import CStrings ( charToC )
-import Maybes ( maybeToBool )
import Stix ( CodeSegment(..), StixTree(..) )
import Char ( isPrint, isDigit )
import Outputable
import ST
import MutableArray
-import Char ( ord )
+import Char ( chr, ord )
+import Maybe ( isJust )
\end{code}
%************************************************************************
pprReg IF_ARCH_i386(s,) r
= case r of
- FixedReg i -> ppr_reg_no IF_ARCH_i386(s,) i
- MappedReg i -> ppr_reg_no IF_ARCH_i386(s,) i
- other -> text (show other) -- should only happen when debugging
+ RealReg (I# i) -> ppr_reg_no IF_ARCH_i386(s,) i
+ VirtualRegI u -> text "%vI_" <> ppr u
+ VirtualRegF u -> text "%vF_" <> ppr u
where
#if alpha_TARGET_ARCH
ppr_reg_no :: FAST_REG_NO -> SDoc
#endif
#if i386_TARGET_ARCH
ppr_reg_no :: Size -> FAST_REG_NO -> SDoc
- ppr_reg_no B i = ptext
+ ppr_reg_no B i= ptext
(case i of {
ILIT( 0) -> SLIT("%al"); ILIT( 1) -> SLIT("%bl");
ILIT( 2) -> SLIT("%cl"); ILIT( 3) -> SLIT("%dl");
BU -> SLIT("bu")
-- W -> SLIT("w") UNUSED
-- WU -> SLIT("wu") UNUSED
--- L -> SLIT("l") UNUSED
+ L -> SLIT("l")
Q -> SLIT("q")
-- FF -> SLIT("f") UNUSED
-- DF -> SLIT("d") UNUSED
-------------------
#if sparc_TARGET_ARCH
-pprAddr (AddrRegReg r1 (FixedReg ILIT(0))) = pprReg r1
+pprAddr (AddrRegReg r1 (RealReg 0)) = pprReg r1
pprAddr (AddrRegReg r1 r2)
= hcat [ pprReg r1, char '+', pprReg r2 ]
pprInstr (SEGMENT TextSegment)
= 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_sparc(ptext SLIT(".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
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_sparc(SLIT(".data\n\t.align 8") {-<8 will break double constants -}
,IF_ARCH_i386(SLIT(".data\n\t.align 4")
,)))
hcat [ptext
IF_ARCH_alpha(SLIT("\t.globl\t")
,IF_ARCH_i386(SLIT(".globl ")
- ,IF_ARCH_sparc(SLIT("\t.global\t")
+ ,IF_ARCH_sparc(SLIT(".global\t")
,)))
, pp_lab, char '\n'],
pp_lab,
= hcat [ ptext SLIT("\t.asciz "), char '\"', text str, char '"' ]
pprInstr (ASCII True str)
- = --(<>) (text "\t.ascii \"") (asciify 60 str)
- asciify str
+#if 0
+ -- The Solaris assembler doesn't understand \x escapes in
+ -- strings.
+ = asciify str
where
asciify :: String -> SDoc
asciify "" = text "\t.ascii \"\\0\""
in this $$ asciify rest
asciify_char :: Char -> String
asciify_char c = '\\' : 'x' : hshow (ord c)
-
- hshow :: Int -> String
- hshow n | n >= 0 && n <= 255
- = [ tab !! (n `div` 16), tab !! (n `mod` 16)]
- tab = "0123456789abcdef"
-
-{-
- asciify :: String -> Int -> SDoc
- asciify [] _ = text "\\0\""
- asciify s n | n <= 0 = (<>) (text "\"\n\t.ascii \"") (asciify s 60)
- asciify ('\\':cs) n = (<>) (text "\\\\") (asciify cs (n-1))
- asciify ('\"':cs) n = (<>) (text "\\\"") (asciify cs (n-1))
- asciify (c:cs) n | isPrint c = (<>) (char c) (asciify cs (n-1))
- asciify [c] _ = (<>) (text (charToC c)) (text ("\\0\"")){-"-}
- asciify (c:(cs@(d:_))) n
- | isDigit d = (<>) (text (charToC c)) (asciify cs 0)
- | otherwise = (<>) (text (charToC c)) (asciify cs (n-1))
- asciify [] _ = text "\\0\
--}
-
-#if 0
-pprInstr (DATA s xs)
- = vcat [(<>) (ptext pp_size) (pprImm x) | x <- xs]
- where
- pp_size = case s of
-#if alpha_TARGET_ARCH
- B -> SLIT("\t.byte\t")
- BU -> SLIT("\t.byte\t")
- Q -> SLIT("\t.quad\t")
- TF -> SLIT("\t.t_floating\t")
-#endif
-#if i386_TARGET_ARCH
- B -> SLIT("\t.byte\t")
- L -> SLIT("\t.long\t")
- F -> SLIT("\t.float\t")
- DF -> SLIT("\t.double\t")
-#endif
-#if sparc_TARGET_ARCH
- B -> SLIT("\t.byte\t")
- BU -> SLIT("\t.byte\t")
- W -> SLIT("\t.word\t")
- DF -> SLIT("\t.double\t")
-#endif
#endif
+ = vcat (map do1 (str ++ [chr 0]))
+ where
+ do1 :: Char -> SDoc
+ do1 c = text "\t.byte\t0x" <> text (hshow (ord c))
+
+ hshow :: Int -> String
+ hshow n | n >= 0 && n <= 255
+ = [ tab !! (n `div` 16), tab !! (n `mod` 16)]
+ tab = "0123456789ABCDEF"
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
+ -- copy n paste of x86 version
+ ppr_item B x = [text "\t.byte\t" <> pprImm x]
+ ppr_item W x = [text "\t.long\t" <> pprImm x]
+ ppr_item F (ImmFloat 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
#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)
+ ppr_item F (ImmFloat 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
+#endif
+ -- 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.
floatToBytes :: Float -> [Int]
floatToBytes f
= runST (do
return (map ord [i0,i1,i2,i3,i4,i5,i6,i7])
)
-#endif
-
-- fall through to rest of (machine-specific) pprInstr...
\end{code}
pprInstr v@(MOV size s@(OpReg src) d@(OpReg dst)) -- hack
| src == dst
=
-#ifdef DEBUG
+#if 0 /* #ifdef DEBUG */
(<>) (ptext SLIT("# warning: ")) (pprSizeOpOp SLIT("mov") size s d)
#else
empty
pprInstr (JXX cond lab) = pprCondInstr SLIT("j") cond (pprCLabel_asm lab)
-pprInstr (JMP (OpImm imm)) = (<>) (ptext SLIT("\tjmp ")) (pprImm imm)
-pprInstr (JMP op) = (<>) (ptext SLIT("\tjmp *")) (pprOperand L op)
-pprInstr (CALL imm)
- = (<>) (ptext SLIT("\tcall ")) (pprImm imm)
+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)
-- Simulating a flat register set on the x86 FP stack is tricky.
gpop dst 1, text " ; addl $4,%esp"])
pprInstr g@(GCMP sz src1 src2)
- = pprG g (hcat [gtab, text "pushl %eax ; ",
- gpush src2 0, gsemi, gpush src1 1]
+ = pprG g (hcat [gtab, text "pushl %eax ; ",gpush src1 0]
$$
- hcat [gtab, text "fcompp ; fstsw %ax ; sahf ; popl %eax"])
+ hcat [gtab, text "fcomp ", greg src2 1,
+ text "; fstsw %ax ; sahf ; popl %eax"])
pprInstr g@(GABS sz src dst)
= pprG g (hcat [gtab, gpush src 0, text " ; fabs ; ", gpop dst 1])
text " fstp %st(0)"] $$
hcat [gtab, gcoerceto sz, gpop dst 1])
+-- 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@(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)
+ | 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)")
gsemi = text " ; "
gtab = char '\t'
gsp = char ' '
-gregno (FixedReg i) = I# i
-gregno (MappedReg i) = I# i
-gregno other = pprPanic "gregno" (text (show other))
+
+gregno (RealReg i) = i
+gregno other = --pprPanic "gregno" (ppr other)
+ 999 -- bogus; only needed for debug printing
pprG :: Instr -> SDoc -> SDoc
pprG fake actual
-- 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 DF (AddrRegReg g1 g2) reg)
- = hcat [
- ptext SLIT("\tadd\t"), pprReg g1,comma,pprReg g2,comma,pprReg g1, char '\n',
- pp_ld_lbracket, pprReg g1, pp_rbracket_comma, pprReg reg, char '\n',
- pp_ld_lbracket, pprReg g1, ptext SLIT("+4]"), comma, pprReg (fPair reg)
+ = 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 (fPair reg)],
+ hcat [ptext SLIT("\tsub\t"), pprReg g1,comma,pprReg g2,comma,pprReg g1]
]
-pprInstr (LD DF addr reg) | maybeToBool off_addr
- = hcat [
- pp_ld_lbracket,
- pprAddr addr,
- pp_rbracket_comma,
- pprReg reg,
-
- char '\n',
- pp_ld_lbracket,
- pprAddr addr2,
- pp_rbracket_comma,
- pprReg (fPair reg)
+-- Translate to
+-- ld [addr],%fn
+-- ld [addr+4],%f(n+1)
+pprInstr (LD DF addr reg) | isJust off_addr
+ = vcat [
+ hcat [pp_ld_lbracket, pprAddr addr, pp_rbracket_comma, pprReg reg],
+ hcat [pp_ld_lbracket, pprAddr addr2, pp_rbracket_comma,pprReg (fPair reg)]
]
where
off_addr = addrOffset addr 4
addr2 = case off_addr of Just x -> x
+
pprInstr (LD size addr reg)
= hcat [
- ptext SLIT("\tld"),
- pprSize size,
- char '\t',
- lbrack,
- pprAddr addr,
- pp_rbracket_comma,
- pprReg reg
+ 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 DF reg (AddrRegReg g1 g2))
- = hcat [
- ptext SLIT("\tadd\t"),
- pprReg g1,comma,pprReg g2,comma,pprReg g1, char '\n',
- ptext SLIT("\tst\t"),
- pprReg reg, pp_comma_lbracket, pprReg g1,
- ptext SLIT("]\n\tst\t"),
- pprReg (fPair reg), pp_comma_lbracket, pprReg g1, ptext SLIT("+4]")
+ = 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 (fPair reg), pp_comma_lbracket,
+ pprReg g1, ptext SLIT("+4]")],
+ hcat [ptext SLIT("\tsub\t"), pprReg g1,comma,pprReg g2,comma,pprReg g1]
]
-pprInstr (ST DF reg addr) | maybeToBool off_addr
- = hcat [
- ptext SLIT("\tst\t"),
- pprReg reg, pp_comma_lbracket, pprAddr addr,
-
- ptext SLIT("]\n\tst\t"),
- pprReg (fPair reg), pp_comma_lbracket,
- pprAddr addr2, rbrack
+-- Translate to
+-- st %fn,[addr]
+-- st %f(n+1),[addr+4]
+pprInstr (ST DF reg addr) | isJust off_addr
+ = vcat [
+ hcat [ptext SLIT("\tst\t"), pprReg reg, pp_comma_lbracket,
+ pprAddr addr, rbrack],
+ hcat [ptext SLIT("\tst\t"), pprReg (fPair reg), pp_comma_lbracket,
+ pprAddr addr2, rbrack]
]
where
off_addr = addrOffset addr 4
pprInstr (ST size reg addr)
= hcat [
- ptext SLIT("\tst"),
- pprStSize size,
- char '\t',
- pprReg reg,
- pp_comma_lbracket,
- pprAddr addr,
- rbrack
+ ptext SLIT("\tst"),
+ pprStSize size,
+ char '\t',
+ pprReg reg,
+ pp_comma_lbracket,
+ pprAddr addr,
+ rbrack
]
pprInstr (ADD x cc reg1 ri reg2)
projects / ghc-hetmet.git / blobdiff