\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 CLabel ( pprCLabel, externallyVisibleCLabel, labelDynamic )
import Stix ( CodeSegment(..) )
-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, Word16 )
+#else
import MutableArray
+import Word ( Word16 )
+#endif
+
+import MONAD_ST
+
import Char ( chr, ord )
import Maybe ( isJust )
_ -> SLIT("very naughty sparc register")
})
#endif
+#if powerpc_TARGET_ARCH
+#if darwin_TARGET_OS
+ 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")
+ })
+#else
+ ppr_reg_no :: Int -> Doc
+ ppr_reg_no i | i <= 31 = int i -- GPRs
+ | i <= 63 = int (i-32) -- FPRs
+ | otherwise = ptext SLIT("very naughty powerpc register")
+#endif
+#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
+#if darwin_TARGET_OS
+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("
+#else
+pprImm (LO i)
+ = pprImm i <> text "@l"
+
+pprImm (HI i)
+ = pprImm i <> text "@h"
+
+pprImm (HA i)
+ = pprImm i <> text "@ha"
+#endif
+#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(IF_OS_darwin(SLIT(".const_data\n.align 2"),
+ SLIT(".section .rodata\n\t.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.short\t") <> pprImm x]
+ ppr_item Hu x = [ptext SLIT("\t.short\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',
pprReg reg3
]
-#endif {-alpha_TARGET_ARCH-}
+#endif /* alpha_TARGET_ARCH */
\end{code}
%************************************************************************
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
]
-pprCondRegReg :: FAST_STRING -> Size -> Cond -> Reg -> Reg -> Doc
+pprCondRegReg :: LitString -> Size -> Cond -> Reg -> Reg -> Doc
pprCondRegReg name size cond reg1 reg2
= hcat [
char '\t',
pprReg size reg2
]
-pprSizeSizeRegReg :: FAST_STRING -> Size -> Size -> Reg -> Reg -> Doc
+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]
-#endif {-i386_TARGET_ARCH-}
+#endif /* i386_TARGET_ARCH */
\end{code}
%************************************************************************
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 ]
+ = 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',
pp_comma_lbracket = text ",["
pp_comma_a = text ",a"
-#endif {-sparc_TARGET_ARCH-}
+#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)
+ | reg1 == reg2 = empty
+ | otherwise = 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 reg3) = pprLogic SLIT("subf") reg1 reg2 (RIReg reg3)
+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)
+
+ -- for some reason, "andi" doesn't exist.
+ -- we'll use "andi." instead.
+pprInstr (AND reg1 reg2 (RIImm imm)) = hcat [
+ char '\t',
+ ptext SLIT("andi."),
+ char '\t',
+ pprReg reg1,
+ ptext SLIT(", "),
+ pprReg reg2,
+ ptext SLIT(", "),
+ pprImm imm
+ ]
+pprInstr (AND reg1 reg2 ri) = pprLogic SLIT("and") reg1 reg2 (toUI16 ri)
+
+pprInstr (OR reg1 reg2 ri) = pprLogic SLIT("or") reg1 reg2 (toUI16 ri)
+pprInstr (XOR reg1 reg2 ri) = pprLogic SLIT("xor") reg1 reg2 (toUI16 ri)
+
+pprInstr (XORIS reg1 reg2 imm) = hcat [
+ char '\t',
+ ptext SLIT("xoris"),
+ char '\t',
+ pprReg reg1,
+ ptext SLIT(", "),
+ pprReg reg2,
+ ptext SLIT(", "),
+ pprImm imm
+ ]
+
+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 (FNEG reg1 reg2) = pprUnary SLIT("fneg") reg1 reg2
+
+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 (FCTIWZ reg1 reg2) = pprUnary SLIT("fctiwz") reg1 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'
+
+-- hack to ensure that negative vals come out in non-negative form
+-- (assuming that fromIntegral{Int->Word16} will do a 'c-style'
+-- conversion, and not throw a fit/exception.)
+toUI16 :: RI -> RI
+toUI16 (RIImm (ImmInt x))
+ | x < 0 = RIImm (ImmInt (fromIntegral ((fromIntegral x) :: Word16)))
+toUI16 (RIImm (ImmInteger x))
+ | x < 0 = RIImm (ImmInt (fromIntegral ((fromIntegral x) :: Word16)))
+toUI16 x = x
+
+{-
+ 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