\begin{code}
#include "nativeGen/NCG.h"
-module PprMach ( pprInstr, pprSize, pprUserReg ) where
+module PprMach ( pprInstr, pprSize, pprUserReg IF_OS_darwin(COMMA pprDyldSymbolStub, ) ) where
#include "HsVersions.h"
import Unique ( pprUnique )
import Panic ( panic )
import Pretty
+import FastString
import qualified Outputable
-import ST
+#if __GLASGOW_HASKELL__ >= 504
+import Data.Array.ST
+import Data.Word ( Word8 )
+#else
import MutableArray
+#endif
+
+import MONAD_ST
+
import Char ( chr, ord )
import Maybe ( isJust )
_ -> SLIT("very naughty sparc register")
})
#endif
+#if powerpc_TARGET_ARCH
+ 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")
+ })
+#endif
\end{code}
%************************************************************************
F -> SLIT("")
DF -> SLIT("d")
#endif
+#if powerpc_TARGET_ARCH
+ B -> SLIT("b")
+ Bu -> SLIT("b")
+ H -> SLIT("h")
+ Hu -> SLIT("h")
+ W -> SLIT("w")
+ F -> SLIT("fs")
+ DF -> SLIT("fd")
+#endif
)
\end{code}
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
})
\end{code}
where
pp_hi = text "%hi("
#endif
+#if powerpc_TARGET_ARCH
+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("
+#endif
\end{code}
%************************************************************************
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)
+ = error "PprMach.pprAddr (AddrRegReg) unimplemented"
+
+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
\end{code}
%************************************************************************
--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))
- ,)))
+ = IF_ARCH_alpha( ((<>) (ptext SLIT("\t# ")) (ftext s))
+ ,IF_ARCH_sparc( ((<>) (ptext SLIT("! ")) (ftext s))
+ ,IF_ARCH_i386( ((<>) (ptext SLIT("# ")) (ftext s))
+ ,IF_ARCH_powerpc( ((<>) (ptext SLIT("; ")) (ftext s))
+ ,))))
pprInstr (DELTA d)
- = pprInstr (COMMENT (_PK_ ("\tdelta = " ++ show d)))
+ = pprInstr (COMMENT (mkFastString ("\tdelta = " ++ show d)))
pprInstr (SEGMENT TextSegment)
= IF_ARCH_alpha(ptext SLIT("\t.text\n\t.align 3") {-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!-}
- ,)))
+ ,IF_ARCH_powerpc(ptext SLIT(".text\n.align 2")
+ ,))))
pprInstr (SEGMENT DataSegment)
= 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(SLIT(".data\n\t.align 4")
- ,)))
+ ,IF_ARCH_powerpc(SLIT(".data\n.align 2")
+ ,))))
pprInstr (SEGMENT RoDataSegment)
= 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(SLIT(".section .rodata\n\t.align 4")
- ,)))
+ ,IF_ARCH_powerpc(SLIT(".const_data\n.align 2")
+ ,))))
pprInstr (LABEL clab)
= let
IF_ARCH_alpha(SLIT("\t.globl\t")
,IF_ARCH_i386(SLIT(".globl ")
,IF_ARCH_sparc(SLIT(".global\t")
- ,)))
+ ,IF_ARCH_powerpc(SLIT(".globl ")
+ ,))))
, pp_lab, char '\n'],
pp_lab,
char ':'
= let bs = doubleToBytes (fromRational r)
in map (\b -> ptext SLIT("\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
- 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])
- )
+#if powerpc_TARGET_ARCH
+ ppr_item B x = [ptext SLIT("\t.byte\t") <> pprImm x]
+ ppr_item Bu x = [ptext SLIT("\t.byte\t") <> pprImm x]
+ ppr_item H x = [ptext SLIT("\t.byte\t") <> pprImm x]
+ ppr_item Hu x = [ptext SLIT("\t.byte\t") <> pprImm x]
+ ppr_item W x = [ptext SLIT("\t.long\t") <> pprImm x]
+ ppr_item F (ImmFloat r)
+ = let bs = floatToBytes (fromRational r)
+ in map (\b -> ptext SLIT("\t.byte\t") <> pprImm (ImmInt b)) bs
+ ppr_item DF (ImmDouble r)
+ = let bs = doubleToBytes (fromRational r)
+ in map (\b -> ptext SLIT("\t.byte\t") <> pprImm (ImmInt b)) bs
+#endif
-- fall through to rest of (machine-specific) pprInstr...
\end{code}
pprRI (RIReg r) = pprReg r
pprRI (RIImm r) = pprImm r
-pprRegRIReg :: FAST_STRING -> Reg -> RI -> Reg -> Doc
-
+pprRegRIReg :: LitString -> Reg -> RI -> Reg -> Doc
pprRegRIReg name reg1 ri reg2
= hcat [
char '\t',
pprReg reg2
]
-pprSizeRegRegReg :: FAST_STRING -> Size -> Reg -> Reg -> Reg -> Doc
-
+pprSizeRegRegReg :: LitString -> Size -> Reg -> Reg -> Reg -> Doc
pprSizeRegRegReg name size reg1 reg2 reg3
= hcat [
char '\t',
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
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"
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
pprOperand s (OpImm i) = pprDollImm i
pprOperand s (OpAddr ea) = pprAddr ea
-pprSizeImmOp :: FAST_STRING -> Size -> Imm -> Operand -> Doc
+pprSizeImmOp :: LitString -> Size -> Imm -> Operand -> Doc
pprSizeImmOp name size imm op1
= hcat [
char '\t',
pprOperand size op1
]
-pprSizeOp :: FAST_STRING -> Size -> Operand -> Doc
+pprSizeOp :: LitString -> Size -> Operand -> Doc
pprSizeOp name size op1
= hcat [
char '\t',
pprOperand size op1
]
-pprSizeOpOp :: FAST_STRING -> Size -> Operand -> Operand -> Doc
+pprSizeOpOp :: LitString -> Size -> Operand -> Operand -> Doc
pprSizeOpOp name size op1 op2
= hcat [
char '\t',
pprOperand size op2
]
-pprSizeByteOpOp :: FAST_STRING -> Size -> Operand -> Operand -> Doc
+pprSizeByteOpOp :: LitString -> Size -> Operand -> Operand -> Doc
pprSizeByteOpOp name size op1 op2
= hcat [
char '\t',
pprOperand size op2
]
-pprSizeOpReg :: FAST_STRING -> Size -> Operand -> Reg -> Doc
+pprSizeOpReg :: LitString -> Size -> Operand -> Reg -> Doc
pprSizeOpReg name size op1 reg
= hcat [
char '\t',
pprReg size reg
]
-pprSizeReg :: FAST_STRING -> Size -> Reg -> Doc
+pprSizeReg :: LitString -> Size -> Reg -> Doc
pprSizeReg name size reg1
= hcat [
char '\t',
pprReg size reg1
]
-pprSizeRegReg :: FAST_STRING -> Size -> Reg -> Reg -> Doc
+pprSizeRegReg :: LitString -> Size -> Reg -> Reg -> Doc
pprSizeRegReg name size reg1 reg2
= hcat [
char '\t',
pprReg size reg2
]
-pprSizeSizeRegReg :: FAST_STRING -> Size -> Size -> Reg -> Reg -> Doc
+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',
pprSize size2,
space,
pprReg size1 reg1,
+
comma,
pprReg size2 reg2
]
-pprSizeRegRegReg :: FAST_STRING -> Size -> Reg -> Reg -> Reg -> Doc
+pprSizeRegRegReg :: LitString -> Size -> Reg -> Reg -> Reg -> Doc
pprSizeRegRegReg name size reg1 reg2 reg3
= hcat [
char '\t',
pprReg size reg3
]
-pprSizeAddr :: FAST_STRING -> Size -> MachRegsAddr -> Doc
+pprSizeAddr :: LitString -> Size -> MachRegsAddr -> Doc
pprSizeAddr name size op
= hcat [
char '\t',
pprAddr op
]
-pprSizeAddrReg :: FAST_STRING -> Size -> MachRegsAddr -> Reg -> Doc
+pprSizeAddrReg :: LitString -> Size -> MachRegsAddr -> Reg -> Doc
pprSizeAddrReg name size op dst
= hcat [
char '\t',
pprReg size dst
]
-pprSizeRegAddr :: FAST_STRING -> Size -> Reg -> MachRegsAddr -> Doc
+pprSizeRegAddr :: LitString -> Size -> Reg -> MachRegsAddr -> Doc
pprSizeRegAddr name size src op
= hcat [
char '\t',
pprAddr op
]
-pprOpOp :: FAST_STRING -> Size -> Operand -> Operand -> Doc
+pprOpOp :: LitString -> Size -> Operand -> Operand -> Doc
pprOpOp name size op1 op2
= hcat [
char '\t',
pprOperand size op2
]
-pprSizeOpOpCoerce :: FAST_STRING -> Size -> Size -> Operand -> Operand -> Doc
+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,
pprOperand size2 op2
]
-pprCondInstr :: FAST_STRING -> Cond -> Doc -> Doc
+pprCondInstr :: LitString -> Cond -> Doc -> Doc
pprCondInstr name cond arg
= hcat [ char '\t', ptext name, pprCond cond, space, arg]
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:
pprRI (RIReg r) = pprReg r
pprRI (RIImm r) = pprImm r
-pprSizeRegReg :: FAST_STRING -> Size -> Reg -> Reg -> Doc
+pprSizeRegReg :: LitString -> Size -> Reg -> Reg -> Doc
pprSizeRegReg name size reg1 reg2
= hcat [
char '\t',
pprReg reg2
]
-pprSizeRegRegReg :: FAST_STRING -> Size -> Reg -> Reg -> Reg -> Doc
+pprSizeRegRegReg :: LitString -> Size -> Reg -> Reg -> Reg -> Doc
pprSizeRegRegReg name size reg1 reg2 reg3
= hcat [
char '\t',
pprReg reg3
]
-pprRegRIReg :: FAST_STRING -> Bool -> Reg -> RI -> Reg -> Doc
+pprRegRIReg :: LitString -> Bool -> Reg -> RI -> Reg -> Doc
pprRegRIReg name b reg1 ri reg2
= hcat [
char '\t',
pprReg reg2
]
-pprRIReg :: FAST_STRING -> Bool -> RI -> Reg -> Doc
+pprRIReg :: LitString -> Bool -> RI -> Reg -> Doc
pprRIReg name b ri reg1
= hcat [
char '\t',
#endif {-sparc_TARGET_ARCH-}
\end{code}
+
+%************************************************************************
+%* *
+\subsubsection{@pprInstr@ for PowerPC}
+%* *
+%************************************************************************
+
+\begin{code}
+#if powerpc_TARGET_ARCH
+pprInstr (LD sz reg addr) = hcat [
+ char '\t',
+ ptext SLIT("l"),
+ ptext (case sz of
+ B -> SLIT("ba")
+ Bu -> SLIT("bz")
+ H -> SLIT("ha")
+ Hu -> SLIT("hz")
+ W -> SLIT("wz")
+ F -> SLIT("fs")
+ DF -> SLIT("fd")),
+ char '\t',
+ pprReg reg,
+ ptext SLIT(", "),
+ pprAddr addr
+ ]
+pprInstr (ST sz reg addr) = hcat [
+ char '\t',
+ ptext SLIT("st"),
+ pprSize sz,
+ 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"),
+ 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) = 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 lbl) = hcat [
+ char '\t',
+ ptext SLIT("b"),
+ pprCond cond,
+ 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 imm _) = hcat [
+ char '\t',
+ ptext SLIT("bl"),
+ char '\t',
+ pprImm imm
+ ]
+pprInstr (BCTRL _) = hcat [
+ char '\t',
+ ptext SLIT("bctrl")
+ ]
+pprInstr (ADD reg1 reg2 ri) = pprLogic SLIT("add") reg1 reg2 ri
+pprInstr (SUBF reg1 reg2 ri) = pprLogic SLIT("subf") reg1 reg2 ri
+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 (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 (SLW reg1 reg2 ri) = pprLogic SLIT("slw") reg1 reg2 ri
+pprInstr (SRW reg1 reg2 ri) = pprLogic SLIT("srw") reg1 reg2 ri
+pprInstr (SRAW reg1 reg2 ri) = pprLogic SLIT("sraw") reg1 reg2 ri
+pprInstr (NEG reg1 reg2) = pprUnary SLIT("neg") reg1 reg2
+pprInstr (NOT reg1 reg2) = pprUnary SLIT("not") reg1 reg2
+
+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 (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 _ = ptext SLIT("something")
+
+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 DF = empty
+pprFSize F = char 's'
+
+{-
+ The Mach-O object file format used in Darwin/Mac OS X needs a so-called
+ "symbol stub" for every function that might be imported from a dynamic
+ library.
+ The stubs are always the same, and they are all output at the end of the
+ generated assembly (see AsmCodeGen.lhs), so we don't use the Instr datatype.
+ Instead, we just pretty-print it directly.
+-}
+
+#if darwin_TARGET_OS
+pprDyldSymbolStub fn =
+ vcat [
+ ptext SLIT(".symbol_stub"),
+ ptext SLIT("L_") <> ftext fn <> ptext SLIT("$stub:"),
+ ptext SLIT("\t.indirect_symbol _") <> ftext fn,
+ ptext SLIT("\tlis r11,ha16(L_") <> ftext fn <> ptext SLIT("$lazy_ptr)"),
+ ptext SLIT("\tlwz r12,lo16(L_") <> ftext fn <> ptext SLIT("$lazy_ptr)(r11)"),
+ ptext SLIT("\tmtctr r12"),
+ ptext SLIT("\taddi r11,r11,lo16(L_") <> ftext fn <> ptext SLIT("$lazy_ptr)"),
+ ptext SLIT("\tbctr"),
+ ptext SLIT(".lazy_symbol_pointer"),
+ ptext SLIT("L_") <> ftext fn <> ptext SLIT("$lazy_ptr:"),
+ ptext SLIT("\t.indirect_symbol _") <> ftext fn,
+ ptext SLIT("\t.long dyld_stub_binding_helper")
+ ]
+#endif
+
+
+#endif {-powerpc_TARGET_ARCH-}
+\end{code}
+
+\begin{code}
+#if __GLASGOW_HASKELL__ >= 504
+newFloatArray :: (Int,Int) -> ST s (STUArray s Int Float)
+newFloatArray = newArray_
+
+newDoubleArray :: (Int,Int) -> ST s (STUArray s Int Double)
+newDoubleArray = newArray_
+
+castFloatToCharArray :: STUArray s Int Float -> ST s (STUArray s Int Word8)
+castFloatToCharArray = castSTUArray
+
+castDoubleToCharArray :: STUArray s Int Double -> ST s (STUArray s Int Word8)
+castDoubleToCharArray = castSTUArray
+
+writeFloatArray :: STUArray s Int Float -> Int -> Float -> ST s ()
+writeFloatArray = writeArray
+
+writeDoubleArray :: STUArray s Int Double -> Int -> Double -> ST s ()
+writeDoubleArray = writeArray
+
+readCharArray :: STUArray s Int Word8 -> Int -> ST s Char
+readCharArray arr i = do
+ w <- readArray arr i
+ return $! (chr (fromIntegral w))
+
+#else
+
+castFloatToCharArray :: MutableByteArray s t -> ST s (MutableByteArray s t)
+castFloatToCharArray = return
+
+castDoubleToCharArray :: MutableByteArray s t -> ST s (MutableByteArray s t)
+
+
+castDoubleToCharArray = return
+
+#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.
+
+-- ToDo: this stuff is very similar to the shenanigans in PprAbs,
+-- could they be merged?
+
+floatToBytes :: Float -> [Int]
+floatToBytes f
+ = runST (do
+ arr <- newFloatArray ((0::Int),3)
+ writeFloatArray arr 0 f
+ arr <- castFloatToCharArray arr
+ 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
+ arr <- castDoubleToCharArray arr
+ 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])
+ )
+\end{code}
projects / ghc-hetmet.git / blobdiff