X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FnativeGen%2FPprMach.lhs;h=0a6b136ac54db9fa38ad3c01fe14c55d94ed4fb5;hb=553e90d9a32ee1b1809430f260c401cc4169c6c7;hp=9ac660ea2f814f6309b8f906b77a19f88b78d375;hpb=2773693e5f92c285ef17aa8720d89ce8689add6e;p=ghc-hetmet.git diff --git a/ghc/compiler/nativeGen/PprMach.lhs b/ghc/compiler/nativeGen/PprMach.lhs index 9ac660e..0a6b136 100644 --- a/ghc/compiler/nativeGen/PprMach.lhs +++ b/ghc/compiler/nativeGen/PprMach.lhs @@ -1,5 +1,5 @@ % -% (c) The AQUA Project, Glasgow University, 1996 +% (c) The AQUA Project, Glasgow University, 1996-1998 % \section[PprMach]{Pretty-printing assembly language} @@ -8,44 +8,38 @@ We start with the @pprXXX@s with some cross-platform commonality @pprInstr@. \begin{code} -#include "HsVersions.h" #include "nativeGen/NCG.h" -module PprMach ( pprInstr ) where +module PprMach ( pprInstr, pprSize, pprUserReg IF_OS_darwin(COMMA pprDyldSymbolStub, ) ) where -IMPORT_1_3(Char(isPrint,isDigit)) -#if __GLASGOW_HASKELL__ == 201 -import qualified GHCbase(Addr(..)) -- to see innards -IMP_Ubiq(){-uitious-} -#elif __GLASGOW_HASKELL__ >= 202 -import qualified GlaExts (Addr(..)) -import GlaExts hiding (Addr(..)) -import FastString -#else -IMP_Ubiq(){-uitious-} -#endif +#include "HsVersions.h" import MachRegs -- may differ per-platform import MachMisc -import AbsCSyn ( MagicId ) -import CLabel ( pprCLabel_asm, externallyVisibleCLabel ) -import CStrings ( charToC ) -import Maybes ( maybeToBool ) -import OrdList ( OrdList ) -import Stix ( CodeSegment(..), StixTree ) -import Pretty -- all of it - -#if __GLASGOW_HASKELL__ == 201 -a_HASH x = GHCbase.A# x -pACK_STR x = packCString x -#elif __GLASGOW_HASKELL__ >= 202 -a_HASH x = GlaExts.A# x -pACK_STR x = mkFastCharString x +import CLabel ( pprCLabel, externallyVisibleCLabel, labelDynamic ) +import Stix ( CodeSegment(..) ) +import Panic ( panic ) +import Pretty +import FastString +import qualified Outputable + +#if __GLASGOW_HASKELL__ >= 504 +import Data.Array.ST +import Data.Word ( Word8, Word16 ) #else -a_HASH x = A# x -pACK_STR x = mkFastCharString x --_packCString x +import MutableArray +import Word ( Word16 ) #endif + +import MONAD_ST + +import Char ( chr, ord ) +import Maybe ( isJust ) + +asmSDoc d = Outputable.withPprStyleDoc ( + Outputable.mkCodeStyle Outputable.AsmStyle) d +pprCLabel_asm l = asmSDoc (pprCLabel l) \end{code} %************************************************************************ @@ -57,149 +51,176 @@ pACK_STR x = mkFastCharString x --_packCString x For x86, the way we print a register name depends on which bit of it we care about. Yurgh. \begin{code} +pprUserReg :: Reg -> Doc +pprUserReg = pprReg IF_ARCH_i386(L,) + pprReg :: IF_ARCH_i386(Size ->,) Reg -> Doc 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 -> ppr_reg_no IF_ARCH_i386(s,) i + VirtualRegI u -> text "%vI_" <> asmSDoc (pprVRegUnique u) + VirtualRegF u -> text "%vF_" <> asmSDoc (pprVRegUnique u) where #if alpha_TARGET_ARCH - ppr_reg_no :: FAST_REG_NO -> Doc + ppr_reg_no :: Int -> Doc ppr_reg_no i = ptext (case i of { - ILIT( 0) -> SLIT("$0"); ILIT( 1) -> SLIT("$1"); - ILIT( 2) -> SLIT("$2"); ILIT( 3) -> SLIT("$3"); - ILIT( 4) -> SLIT("$4"); ILIT( 5) -> SLIT("$5"); - ILIT( 6) -> SLIT("$6"); ILIT( 7) -> SLIT("$7"); - ILIT( 8) -> SLIT("$8"); ILIT( 9) -> SLIT("$9"); - ILIT(10) -> SLIT("$10"); ILIT(11) -> SLIT("$11"); - ILIT(12) -> SLIT("$12"); ILIT(13) -> SLIT("$13"); - ILIT(14) -> SLIT("$14"); ILIT(15) -> SLIT("$15"); - ILIT(16) -> SLIT("$16"); ILIT(17) -> SLIT("$17"); - ILIT(18) -> SLIT("$18"); ILIT(19) -> SLIT("$19"); - ILIT(20) -> SLIT("$20"); ILIT(21) -> SLIT("$21"); - ILIT(22) -> SLIT("$22"); ILIT(23) -> SLIT("$23"); - ILIT(24) -> SLIT("$24"); ILIT(25) -> SLIT("$25"); - ILIT(26) -> SLIT("$26"); ILIT(27) -> SLIT("$27"); - ILIT(28) -> SLIT("$28"); ILIT(29) -> SLIT("$29"); - ILIT(30) -> SLIT("$30"); ILIT(31) -> SLIT("$31"); - ILIT(32) -> SLIT("$f0"); ILIT(33) -> SLIT("$f1"); - ILIT(34) -> SLIT("$f2"); ILIT(35) -> SLIT("$f3"); - ILIT(36) -> SLIT("$f4"); ILIT(37) -> SLIT("$f5"); - ILIT(38) -> SLIT("$f6"); ILIT(39) -> SLIT("$f7"); - ILIT(40) -> SLIT("$f8"); ILIT(41) -> SLIT("$f9"); - ILIT(42) -> SLIT("$f10"); ILIT(43) -> SLIT("$f11"); - ILIT(44) -> SLIT("$f12"); ILIT(45) -> SLIT("$f13"); - ILIT(46) -> SLIT("$f14"); ILIT(47) -> SLIT("$f15"); - ILIT(48) -> SLIT("$f16"); ILIT(49) -> SLIT("$f17"); - ILIT(50) -> SLIT("$f18"); ILIT(51) -> SLIT("$f19"); - ILIT(52) -> SLIT("$f20"); ILIT(53) -> SLIT("$f21"); - ILIT(54) -> SLIT("$f22"); ILIT(55) -> SLIT("$f23"); - ILIT(56) -> SLIT("$f24"); ILIT(57) -> SLIT("$f25"); - ILIT(58) -> SLIT("$f26"); ILIT(59) -> SLIT("$f27"); - ILIT(60) -> SLIT("$f28"); ILIT(61) -> SLIT("$f29"); - ILIT(62) -> SLIT("$f30"); ILIT(63) -> SLIT("$f31"); - _ -> SLIT("very naughty alpha register") + 0 -> SLIT("$0"); 1 -> SLIT("$1"); + 2 -> SLIT("$2"); 3 -> SLIT("$3"); + 4 -> SLIT("$4"); 5 -> SLIT("$5"); + 6 -> SLIT("$6"); 7 -> SLIT("$7"); + 8 -> SLIT("$8"); 9 -> SLIT("$9"); + 10 -> SLIT("$10"); 11 -> SLIT("$11"); + 12 -> SLIT("$12"); 13 -> SLIT("$13"); + 14 -> SLIT("$14"); 15 -> SLIT("$15"); + 16 -> SLIT("$16"); 17 -> SLIT("$17"); + 18 -> SLIT("$18"); 19 -> SLIT("$19"); + 20 -> SLIT("$20"); 21 -> SLIT("$21"); + 22 -> SLIT("$22"); 23 -> SLIT("$23"); + 24 -> SLIT("$24"); 25 -> SLIT("$25"); + 26 -> SLIT("$26"); 27 -> SLIT("$27"); + 28 -> SLIT("$28"); 29 -> SLIT("$29"); + 30 -> SLIT("$30"); 31 -> SLIT("$31"); + 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 alpha register") }) #endif #if i386_TARGET_ARCH - ppr_reg_no :: Size -> FAST_REG_NO -> Doc - ppr_reg_no B i = ptext + ppr_reg_no :: Size -> Int -> Doc + ppr_reg_no B = ppr_reg_byte + ppr_reg_no Bu = ppr_reg_byte + ppr_reg_no W = ppr_reg_word + ppr_reg_no Wu = ppr_reg_word + ppr_reg_no _ = ppr_reg_long + + ppr_reg_byte i = ptext (case i of { - ILIT( 0) -> SLIT("%al"); ILIT( 1) -> SLIT("%bl"); - ILIT( 2) -> SLIT("%cl"); ILIT( 3) -> SLIT("%dl"); - _ -> SLIT("very naughty I386 byte register") + 0 -> SLIT("%al"); 1 -> SLIT("%bl"); + 2 -> SLIT("%cl"); 3 -> SLIT("%dl"); + _ -> SLIT("very naughty I386 byte register") }) - {- UNUSED: - ppr_reg_no HB i = ptext + ppr_reg_word 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") + 0 -> SLIT("%ax"); 1 -> SLIT("%bx"); + 2 -> SLIT("%cx"); 3 -> SLIT("%dx"); + 4 -> SLIT("%si"); 5 -> SLIT("%di"); + 6 -> SLIT("%bp"); 7 -> SLIT("%sp"); + _ -> SLIT("very naughty I386 word register") }) - -} - -{- UNUSED: - ppr_reg_no S i = ptext - (case i of { - ILIT( 0) -> SLIT("%ax"); ILIT( 1) -> SLIT("%bx"); - ILIT( 2) -> SLIT("%cx"); ILIT( 3) -> SLIT("%dx"); - ILIT( 4) -> SLIT("%si"); ILIT( 5) -> SLIT("%di"); - ILIT( 6) -> SLIT("%bp"); ILIT( 7) -> SLIT("%sp"); - _ -> SLIT("very naughty I386 word register") - }) --} - ppr_reg_no L i = ptext + ppr_reg_long i = ptext (case i of { - ILIT( 0) -> SLIT("%eax"); ILIT( 1) -> SLIT("%ebx"); - ILIT( 2) -> SLIT("%ecx"); ILIT( 3) -> SLIT("%edx"); - ILIT( 4) -> SLIT("%esi"); ILIT( 5) -> SLIT("%edi"); - ILIT( 6) -> SLIT("%ebp"); ILIT( 7) -> SLIT("%esp"); - _ -> SLIT("very naughty I386 double word register") + 0 -> SLIT("%eax"); 1 -> SLIT("%ebx"); + 2 -> SLIT("%ecx"); 3 -> SLIT("%edx"); + 4 -> SLIT("%esi"); 5 -> SLIT("%edi"); + 6 -> SLIT("%ebp"); 7 -> SLIT("%esp"); + 8 -> SLIT("%fake0"); 9 -> SLIT("%fake1"); + 10 -> SLIT("%fake2"); 11 -> SLIT("%fake3"); + 12 -> SLIT("%fake4"); 13 -> SLIT("%fake5"); + _ -> SLIT("very naughty I386 register") }) - - 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)"); - _ -> SLIT("very naughty I386 float register") - }) - - ppr_reg_no DF i = ptext +#endif +#if sparc_TARGET_ARCH + ppr_reg_no :: Int -> Doc + ppr_reg_no 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)"); - _ -> SLIT("very naughty I386 float register") + 0 -> SLIT("%g0"); 1 -> SLIT("%g1"); + 2 -> SLIT("%g2"); 3 -> SLIT("%g3"); + 4 -> SLIT("%g4"); 5 -> SLIT("%g5"); + 6 -> SLIT("%g6"); 7 -> SLIT("%g7"); + 8 -> SLIT("%o0"); 9 -> SLIT("%o1"); + 10 -> SLIT("%o2"); 11 -> SLIT("%o3"); + 12 -> SLIT("%o4"); 13 -> SLIT("%o5"); + 14 -> SLIT("%o6"); 15 -> SLIT("%o7"); + 16 -> SLIT("%l0"); 17 -> SLIT("%l1"); + 18 -> SLIT("%l2"); 19 -> SLIT("%l3"); + 20 -> SLIT("%l4"); 21 -> SLIT("%l5"); + 22 -> SLIT("%l6"); 23 -> SLIT("%l7"); + 24 -> SLIT("%i0"); 25 -> SLIT("%i1"); + 26 -> SLIT("%i2"); 27 -> SLIT("%i3"); + 28 -> SLIT("%i4"); 29 -> SLIT("%i5"); + 30 -> SLIT("%i6"); 31 -> SLIT("%i7"); + 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 sparc register") }) #endif -#if sparc_TARGET_ARCH - ppr_reg_no :: FAST_REG_NO -> Doc +#if powerpc_TARGET_ARCH +#if darwin_TARGET_OS + ppr_reg_no :: Int -> Doc ppr_reg_no i = ptext (case i of { - ILIT( 0) -> SLIT("%g0"); ILIT( 1) -> SLIT("%g1"); - ILIT( 2) -> SLIT("%g2"); ILIT( 3) -> SLIT("%g3"); - ILIT( 4) -> SLIT("%g4"); ILIT( 5) -> SLIT("%g5"); - ILIT( 6) -> SLIT("%g6"); ILIT( 7) -> SLIT("%g7"); - ILIT( 8) -> SLIT("%o0"); ILIT( 9) -> SLIT("%o1"); - ILIT(10) -> SLIT("%o2"); ILIT(11) -> SLIT("%o3"); - ILIT(12) -> SLIT("%o4"); ILIT(13) -> SLIT("%o5"); - ILIT(14) -> SLIT("%o6"); ILIT(15) -> SLIT("%o7"); - ILIT(16) -> SLIT("%l0"); ILIT(17) -> SLIT("%l1"); - ILIT(18) -> SLIT("%l2"); ILIT(19) -> SLIT("%l3"); - ILIT(20) -> SLIT("%l4"); ILIT(21) -> SLIT("%l5"); - ILIT(22) -> SLIT("%l6"); ILIT(23) -> SLIT("%l7"); - ILIT(24) -> SLIT("%i0"); ILIT(25) -> SLIT("%i1"); - ILIT(26) -> SLIT("%i2"); ILIT(27) -> SLIT("%i3"); - ILIT(28) -> SLIT("%i4"); ILIT(29) -> SLIT("%i5"); - ILIT(30) -> SLIT("%i6"); ILIT(31) -> SLIT("%i7"); - ILIT(32) -> SLIT("%f0"); ILIT(33) -> SLIT("%f1"); - ILIT(34) -> SLIT("%f2"); ILIT(35) -> SLIT("%f3"); - ILIT(36) -> SLIT("%f4"); ILIT(37) -> SLIT("%f5"); - ILIT(38) -> SLIT("%f6"); ILIT(39) -> SLIT("%f7"); - ILIT(40) -> SLIT("%f8"); ILIT(41) -> SLIT("%f9"); - ILIT(42) -> SLIT("%f10"); ILIT(43) -> SLIT("%f11"); - ILIT(44) -> SLIT("%f12"); ILIT(45) -> SLIT("%f13"); - ILIT(46) -> SLIT("%f14"); ILIT(47) -> SLIT("%f15"); - ILIT(48) -> SLIT("%f16"); ILIT(49) -> SLIT("%f17"); - ILIT(50) -> SLIT("%f18"); ILIT(51) -> SLIT("%f19"); - ILIT(52) -> SLIT("%f20"); ILIT(53) -> SLIT("%f21"); - ILIT(54) -> SLIT("%f22"); ILIT(55) -> SLIT("%f23"); - ILIT(56) -> SLIT("%f24"); ILIT(57) -> SLIT("%f25"); - ILIT(58) -> SLIT("%f26"); ILIT(59) -> SLIT("%f27"); - ILIT(60) -> SLIT("%f28"); ILIT(61) -> SLIT("%f29"); - ILIT(62) -> SLIT("%f30"); ILIT(63) -> SLIT("%f31"); - _ -> SLIT("very naughty sparc register") + 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} @@ -215,10 +236,10 @@ pprSize :: Size -> Doc pprSize x = ptext (case x of #if alpha_TARGET_ARCH B -> SLIT("b") - BU -> SLIT("bu") + Bu -> SLIT("bu") -- W -> SLIT("w") UNUSED --- WU -> SLIT("wu") UNUSED --- L -> SLIT("l") UNUSED +-- Wu -> SLIT("wu") UNUSED + L -> SLIT("l") Q -> SLIT("q") -- FF -> SLIT("f") UNUSED -- DF -> SLIT("d") UNUSED @@ -227,34 +248,44 @@ pprSize x = ptext (case x of TF -> SLIT("t") #endif #if i386_TARGET_ARCH - B -> SLIT("b") --- HB -> SLIT("b") UNUSED --- S -> SLIT("w") UNUSED - L -> SLIT("l") - F -> SLIT("s") - DF -> SLIT("l") + B -> SLIT("b") + Bu -> SLIT("b") + W -> SLIT("w") + Wu -> SLIT("w") + L -> SLIT("l") + Lu -> SLIT("l") + F -> SLIT("s") + DF -> SLIT("l") + F80 -> SLIT("t") #endif #if sparc_TARGET_ARCH B -> SLIT("sb") - BU -> SLIT("ub") --- HW -> SLIT("hw") UNUSED --- HWU -> SLIT("uhw") UNUSED + Bu -> SLIT("ub") + H -> SLIT("sh") + Hu -> SLIT("uh") W -> SLIT("") F -> SLIT("") --- D -> SLIT("d") UNUSED DF -> SLIT("d") ) pprStSize :: Size -> Doc pprStSize x = ptext (case x of B -> SLIT("b") - BU -> SLIT("b") --- HW -> SLIT("hw") UNUSED --- HWU -> SLIT("uhw") UNUSED + Bu -> SLIT("b") + H -> SLIT("h") + Hu -> SLIT("h") W -> SLIT("") F -> SLIT("") --- D -> SLIT("d") UNUSED 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} @@ -285,6 +316,7 @@ pprCond c = ptext (case c of { LTT -> SLIT("l"); LE -> SLIT("le"); LEU -> SLIT("be"); NE -> SLIT("ne"); NEG -> SLIT("s"); POS -> SLIT("ns"); + CARRY -> SLIT("c"); OFLO -> SLIT("o"); ALWAYS -> SLIT("mp") -- hack #endif #if sparc_TARGET_ARCH @@ -297,6 +329,14 @@ pprCond c = ptext (case c of { 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} @@ -311,22 +351,53 @@ pprImm :: Imm -> Doc pprImm (ImmInt i) = int i pprImm (ImmInteger i) = integer i -pprImm (ImmCLbl l) = pprCLabel_asm l +pprImm (ImmCLbl l) = (if labelDynamic l then text "__imp_" else empty) + <> pprCLabel_asm l +pprImm (ImmIndex l i) = (if labelDynamic l then text "__imp_" else empty) + <> pprCLabel_asm l <> char '+' <> int i pprImm (ImmLit s) = s -pprImm (ImmLab s) | underscorePrefix = (<>) (char '_') s - | otherwise = s +pprImm (ImmLab dll s) = (if underscorePrefix then char '_' else empty) + <> (if dll then text "_imp__" else empty) + <> s #if sparc_TARGET_ARCH pprImm (LO i) = hcat [ pp_lo, pprImm i, rparen ] where - pp_lo = ptext (pACK_STR (a_HASH "%lo("#)) + pp_lo = text "%lo(" pprImm (HI i) = hcat [ pp_hi, pprImm i, rparen ] where - pp_hi = ptext (pACK_STR (a_HASH "%hi("#)) + 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} @@ -337,7 +408,7 @@ pprImm (HI i) %************************************************************************ \begin{code} -pprAddr :: Addr -> Doc +pprAddr :: MachRegsAddr -> Doc #if alpha_TARGET_ARCH pprAddr (AddrReg r) = parens (pprReg r) @@ -350,27 +421,27 @@ pprAddr (AddrRegImm r1 i) #if i386_TARGET_ARCH pprAddr (ImmAddr imm off) - = let - pp_imm = pprImm imm + = let pp_imm = pprImm imm in if (off == 0) then pp_imm else if (off < 0) then - (<>) pp_imm (int off) + pp_imm <> int off else - hcat [pp_imm, char '+', int off] + pp_imm <> char '+' <> int off -pprAddr (Addr base index displacement) +pprAddr (AddrBaseIndex base index displacement) = let pp_disp = ppr_disp displacement - pp_off p = (<>) pp_disp (parens p) + pp_off p = pp_disp <> char '(' <> p <> char ')' pp_reg r = pprReg L r in case (base,index) of (Nothing, Nothing) -> pp_disp (Just b, Nothing) -> pp_off (pp_reg b) - (Nothing, Just (r,i)) -> pp_off (hcat [pp_reg r, comma, int i]) - (Just b, Just (r,i)) -> pp_off (hcat [pp_reg b, comma, pp_reg r, comma, int i]) + (Nothing, Just (r,i)) -> pp_off (pp_reg r <> comma <> int i) + (Just b, Just (r,i)) -> pp_off (pp_reg b <> comma <> pp_reg r + <> comma <> int i) where ppr_disp (ImmInt 0) = empty ppr_disp imm = pprImm imm @@ -379,7 +450,7 @@ pprAddr (Addr base index displacement) ------------------- #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 ] @@ -394,6 +465,8 @@ pprAddr (AddrRegImm r1 (ImmInt i)) 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 @@ -401,6 +474,14 @@ pprAddr (AddrRegImm r1 (ImmInteger i)) 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} %************************************************************************ @@ -412,24 +493,40 @@ pprAddr (AddrRegImm r1 imm) \begin{code} pprInstr :: Instr -> Doc -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# ")) (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 (mkFastString ("\tdelta = " ++ show d))) 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_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("\t.data\n\t.align 8") {-<8 will break double constants -} - ,IF_ARCH_i386(SLIT(".data\n\t.align 2") - ,))) + ,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 @@ -442,8 +539,9 @@ pprInstr (LABEL clab) 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") + ,IF_ARCH_powerpc(SLIT(".globl ") + ,)))) , pp_lab, char '\n'], pp_lab, char ':' @@ -453,50 +551,57 @@ pprInstr (ASCII False{-no backslash conversion-} str) = hcat [ ptext SLIT("\t.asciz "), char '\"', text str, char '"' ] pprInstr (ASCII True str) - = (<>) (text "\t.ascii \"") (asciify str 60) - where - asciify :: String -> Int -> Doc - - 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)) + = vcat (map do1 (str ++ [chr 0])) + where + do1 :: Char -> Doc + do1 c = ptext SLIT("\t.byte\t0x") <> hshow (ord c) + + hshow :: Int -> Doc + hshow n | n >= 0 && n <= 255 + = char (tab !! (n `div` 16)) <> char (tab !! (n `mod` 16)) + tab = "0123456789ABCDEF" + pprInstr (DATA s xs) - = vcat [(<>) (ptext pp_size) (pprImm x) | x <- xs] - where - pp_size = case s of + = vcat (concatMap (ppr_item s) 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") + ppr_item = error "ppr_item on Alpha" +#endif +#if sparc_TARGET_ARCH + -- copy n paste of x86 version + ppr_item B 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 #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.long\t") - DF -> SLIT("\t.double\t") + ppr_item B x = [ptext SLIT("\t.byte\t") <> pprImm x] + ppr_item L 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 -#if sparc_TARGET_ARCH - B -> SLIT("\t.byte\t") - BU -> SLIT("\t.byte\t") - W -> SLIT("\t.word\t") - DF -> SLIT("\t.double\t") +#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... @@ -840,8 +945,12 @@ pprInstr (FUNBEGIN clab) where pp_lab = pprCLabel_asm clab - pp_ldgp = ptext (pACK_STR (a_HASH ":\n\tldgp $29,0($27)\n"#)) - pp_frame = ptext (pACK_STR (a_HASH "..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) @@ -854,8 +963,7 @@ pprRI :: RI -> Doc 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', @@ -868,8 +976,7 @@ pprRegRIReg name reg1 ri reg2 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', @@ -883,7 +990,7 @@ pprSizeRegRegReg name size reg1 reg2 reg3 pprReg reg3 ] -#endif {-alpha_TARGET_ARCH-} +#endif /* alpha_TARGET_ARCH */ \end{code} %************************************************************************ @@ -895,23 +1002,28 @@ pprSizeRegRegReg name size reg1 reg2 reg3 \begin{code} #if i386_TARGET_ARCH -pprInstr (MOV size (OpReg src) (OpReg dst)) -- hack +pprInstr v@(MOV size s@(OpReg src) d@(OpReg dst)) -- hack | src == dst - = ptext SLIT("") + = +#if 0 /* #ifdef DEBUG */ + (<>) (ptext SLIT("# warning: ")) (pprSizeOpOp SLIT("mov") size s d) +#else + empty +#endif pprInstr (MOV size src dst) = pprSizeOpOp SLIT("mov") size src dst -pprInstr (MOVZX size src dst) = pprSizeOpOpCoerce SLIT("movzx") L size src dst -pprInstr (MOVSX size src dst) = pprSizeOpOpCoerce SLIT("movxs") L size src dst +pprInstr (MOVZxL sizes src dst) = pprSizeOpOpCoerce SLIT("movz") sizes L src dst +pprInstr (MOVSxL sizes src dst) = pprSizeOpOpCoerce SLIT("movs") sizes L src dst -- here we do some patching, since the physical registers are only set late -- in the code generation. -pprInstr (LEA size (OpAddr (Addr src1@(Just reg1) (Just (reg2,1)) (ImmInt 0))) dst@(OpReg reg3)) +pprInstr (LEA size (OpAddr (AddrBaseIndex src1@(Just reg1) (Just (reg2,1)) (ImmInt 0))) dst@(OpReg reg3)) | reg1 == reg3 = pprSizeOpOp SLIT("add") size (OpReg reg2) dst -pprInstr (LEA size (OpAddr (Addr src1@(Just reg1) (Just (reg2,1)) (ImmInt 0))) dst@(OpReg reg3)) +pprInstr (LEA size (OpAddr (AddrBaseIndex src1@(Just reg1) (Just (reg2,1)) (ImmInt 0))) dst@(OpReg reg3)) | reg2 == reg3 = pprSizeOpOp SLIT("add") size (OpReg reg1) dst -pprInstr (LEA size (OpAddr (Addr src1@(Just reg1) Nothing displ)) dst@(OpReg reg3)) +pprInstr (LEA size (OpAddr (AddrBaseIndex src1@(Just reg1) Nothing displ)) dst@(OpReg reg3)) | reg1 == reg3 = pprInstr (ADD size (OpImm displ) dst) pprInstr (LEA size src dst) = pprSizeOpOp SLIT("lea") size src dst @@ -924,111 +1036,370 @@ pprInstr (ADD size src dst) = pprSizeOpOp SLIT("add") size src dst pprInstr (SUB size src dst) = pprSizeOpOp SLIT("sub") size src dst pprInstr (IMUL size op1 op2) = pprSizeOpOp SLIT("imul") size op1 op2 -pprInstr (IDIV size op) = pprSizeOp SLIT("idiv") size op + +{- A hack. The Intel documentation says that "The two and three + operand forms [of IMUL] may also be used with unsigned operands + because the lower half of the product is the same regardless if + (sic) the operands are signed or unsigned. The CF and OF flags, + however, cannot be used to determine if the upper half of the + result is non-zero." So there. +-} +pprInstr (MUL size op1 op2) = pprSizeOpOp SLIT("imul") size op1 op2 pprInstr (AND size src dst) = pprSizeOpOp SLIT("and") size src dst pprInstr (OR size src dst) = pprSizeOpOp SLIT("or") size src dst pprInstr (XOR size src dst) = pprSizeOpOp SLIT("xor") size src dst pprInstr (NOT size op) = pprSizeOp SLIT("not") size op pprInstr (NEGI size op) = pprSizeOp SLIT("neg") size op -pprInstr (SHL size imm dst) = pprSizeOpOp SLIT("shl") size imm dst -pprInstr (SAR size imm dst) = pprSizeOpOp SLIT("sar") size imm dst -pprInstr (SHR size imm dst) = pprSizeOpOp SLIT("shr") size imm dst + +pprInstr (SHL size imm dst) = pprSizeImmOp SLIT("shl") size imm dst +pprInstr (SAR size imm dst) = pprSizeImmOp SLIT("sar") size imm dst +pprInstr (SHR size imm dst) = pprSizeImmOp SLIT("shr") size imm dst +pprInstr (BT size imm src) = pprSizeImmOp SLIT("bt") size imm src pprInstr (CMP size src dst) = pprSizeOpOp SLIT("cmp") size src dst 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 NOP = ptext SLIT("\tnop") +pprInstr CLTD = ptext SLIT("\tcltd") pprInstr (SETCC cond op) = pprCondInstr SLIT("set") cond (pprOperand B op) 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) - = 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("") +pprInstr (JMP dsts (OpImm imm)) = (<>) (ptext SLIT("\tjmp ")) (pprImm imm) +pprInstr (JMP dsts op) = (<>) (ptext SLIT("\tjmp *")) (pprOperand L op) +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 (IREM sz src dst) = pprInstr_quotRem True False 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. +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@(GLDZ dst) + = pprG g (hcat [gtab, text "ffree %st(7) ; fldz ; ", gpop dst 1]) +pprInstr g@(GLD1 dst) + = pprG g (hcat [gtab, text "ffree %st(7) ; fld1 ; ", gpop dst 1]) + +pprInstr g@(GFTOI src dst) + = pprInstr (GDTOI src dst) +pprInstr g@(GDTOI src dst) + = pprG g (hcat [gtab, text "subl $4, %esp ; ", + gpush src 0, gsemi, text "fistpl 0(%esp) ; popl ", + pprReg L dst]) + +pprInstr g@(GITOF src dst) + = pprInstr (GITOD src dst) +pprInstr g@(GITOD src dst) + = pprG g (hcat [gtab, text "pushl ", pprReg L src, + text " ; ffree %st(7); fildl (%esp) ; ", + gpop dst 1, text " ; addl $4,%esp"]) + +{- 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 + + fcomp 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]) +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"] $$ + hcat [gtab, gcoerceto sz, gpop dst 1]) +pprInstr g@(GSIN sz src dst) + = pprG g (hcat [gtab, gpush src 0, text " ; fsin"] $$ + hcat [gtab, gcoerceto sz, gpop dst 1]) +pprInstr g@(GCOS sz src dst) + = pprG g (hcat [gtab, gpush src 0, text " ; fcos"] $$ + hcat [gtab, gcoerceto sz, gpop dst 1]) +pprInstr g@(GTAN sz src dst) + = pprG g (hcat [gtab, text "ffree %st(6) ; ", + gpush src 0, text " ; fptan ; ", + 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@(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)") + ] + + +pprInstr_quotRem signed isQuot sz src dst + | case sz of L -> False; _ -> True + = panic "pprInstr_quotRem: dunno how to do non-32bit operands" + | otherwise + = vcat [ + (text "\t# BEGIN " <> fakeInsn), + (text "\tpushl $0; pushl %eax; pushl %edx; pushl " <> pprOperand sz src), + (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" + | not signed = if isQuot then "QUOT" else "REM" + 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 +gcoerceto DF = empty +gcoerceto F = empty --text "subl $4,%esp ; fstps (%esp) ; flds (%esp) ; addl $4,%esp ; " + +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 (RealReg i) = i +gregno other = --pprPanic "gregno" (ppr other) + 999 -- bogus; only needed for debug printing + +pprG :: Instr -> Doc -> Doc +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 (GLDZ dst) = pprSizeReg SLIT("gldz") DF dst +pprGInstr (GLD1 dst) = pprSizeReg SLIT("gld1") DF dst + +pprGInstr (GFTOI src dst) = pprSizeSizeRegReg SLIT("gftoi") F L 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 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 +pprGInstr (GSIN sz src dst) = pprSizeRegReg SLIT("gsin") sz src dst +pprGInstr (GCOS sz src dst) = pprSizeRegReg SLIT("gcos") sz src dst +pprGInstr (GTAN sz src dst) = pprSizeRegReg SLIT("gtan") 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: \begin{code} pprDollImm :: Imm -> Doc -pprDollImm i = hcat [ ptext SLIT("$"), pprImm i] +pprDollImm i = ptext SLIT("$") <> pprImm i pprOperand :: Size -> Operand -> Doc -pprOperand s (OpReg r) = pprReg s r -pprOperand s (OpImm i) = pprDollImm i +pprOperand s (OpReg r) = pprReg s r +pprOperand s (OpImm i) = pprDollImm i pprOperand s (OpAddr ea) = pprAddr ea -pprSizeOp :: FAST_STRING -> Size -> Operand -> Doc +pprSizeImmOp :: LitString -> Size -> Imm -> Operand -> Doc +pprSizeImmOp name size imm op1 + = hcat [ + char '\t', + ptext name, + pprSize size, + space, + char '$', + pprImm imm, + comma, + pprOperand size op1 + ] + +pprSizeOp :: LitString -> Size -> Operand -> Doc pprSizeOp name size op1 = hcat [ char '\t', @@ -1038,7 +1409,7 @@ pprSizeOp name size op1 pprOperand size op1 ] -pprSizeOpOp :: FAST_STRING -> Size -> Operand -> Operand -> Doc +pprSizeOpOp :: LitString -> Size -> Operand -> Operand -> Doc pprSizeOpOp name size op1 op2 = hcat [ char '\t', @@ -1050,7 +1421,19 @@ pprSizeOpOp name size op1 op2 pprOperand size op2 ] -pprSizeOpReg :: FAST_STRING -> Size -> Operand -> Reg -> Doc +pprSizeByteOpOp :: LitString -> Size -> Operand -> Operand -> Doc +pprSizeByteOpOp name size op1 op2 + = hcat [ + char '\t', + ptext name, + pprSize size, + space, + pprOperand B op1, + comma, + pprOperand size op2 + ] + +pprSizeOpReg :: LitString -> Size -> Operand -> Reg -> Doc pprSizeOpReg name size op1 reg = hcat [ char '\t', @@ -1062,7 +1445,69 @@ pprSizeOpReg name size op1 reg pprReg size reg ] -pprSizeAddr :: FAST_STRING -> Size -> Addr -> Doc +pprSizeReg :: LitString -> Size -> Reg -> Doc +pprSizeReg name size reg1 + = hcat [ + char '\t', + ptext name, + pprSize size, + space, + pprReg size reg1 + ] + +pprSizeRegReg :: LitString -> Size -> Reg -> Reg -> Doc +pprSizeRegReg name size reg1 reg2 + = hcat [ + char '\t', + ptext name, + pprSize size, + space, + pprReg size reg1, + comma, + pprReg size reg2 + ] + +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', + ptext name, + pprSize size1, + pprSize size2, + space, + pprReg size1 reg1, + + comma, + pprReg size2 reg2 + ] + +pprSizeRegRegReg :: LitString -> Size -> Reg -> Reg -> Reg -> Doc +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 :: LitString -> Size -> MachRegsAddr -> Doc pprSizeAddr name size op = hcat [ char '\t', @@ -1072,7 +1517,7 @@ pprSizeAddr name size op pprAddr op ] -pprSizeAddrReg :: FAST_STRING -> Size -> Addr -> Reg -> Doc +pprSizeAddrReg :: LitString -> Size -> MachRegsAddr -> Reg -> Doc pprSizeAddrReg name size op dst = hcat [ char '\t', @@ -1084,7 +1529,19 @@ pprSizeAddrReg name size op dst pprReg size dst ] -pprOpOp :: FAST_STRING -> Size -> Operand -> Operand -> Doc +pprSizeRegAddr :: LitString -> Size -> Reg -> MachRegsAddr -> Doc +pprSizeRegAddr name size src op + = hcat [ + char '\t', + ptext name, + pprSize size, + space, + pprReg size src, + comma, + pprAddr op + ] + +pprOpOp :: LitString -> Size -> Operand -> Operand -> Doc pprOpOp name size op1 op2 = hcat [ char '\t', @@ -1094,19 +1551,19 @@ pprOpOp name size op1 op2 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, space, + = hcat [ char '\t', ptext name, pprSize size1, pprSize size2, space, pprOperand size1 op1, comma, 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} %************************************************************************ @@ -1123,61 +1580,70 @@ pprCondInstr name cond arg -- 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 @@ -1189,13 +1655,13 @@ pprInstr (ST DF reg addr) | maybeToBool off_addr 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) @@ -1217,7 +1683,10 @@ pprInstr (ANDN b reg1 ri reg2) = pprRegRIReg SLIT("andn") b reg1 ri reg2 pprInstr (OR b reg1 ri reg2) | not b && reg1 == g0 - = hcat [ ptext SLIT("\tmov\t"), pprRI ri, comma, pprReg reg2 ] + = let doit = hcat [ ptext SLIT("\tmov\t"), pprRI ri, comma, pprReg reg2 ] + in case ri of + RIReg rrr | rrr == reg2 -> empty + other -> doit | otherwise = pprRegRIReg SLIT("or") b reg1 ri reg2 @@ -1230,6 +1699,10 @@ pprInstr (SLL reg1 ri reg2) = pprRegRIReg SLIT("sll") False reg1 ri reg2 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"), @@ -1306,10 +1779,12 @@ pprInstr (BF cond b lab) pprImm lab ] -pprInstr (JMP addr) = (<>) (ptext SLIT("\tjmp\t")) (pprAddr addr) +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: @@ -1318,7 +1793,7 @@ pprRI :: RI -> Doc 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', @@ -1331,7 +1806,7 @@ pprSizeRegReg name size reg1 reg2 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', @@ -1346,7 +1821,7 @@ pprSizeRegRegReg name size reg1 reg2 reg3 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', @@ -1359,7 +1834,7 @@ pprRegRIReg name b reg1 ri reg2 pprReg reg2 ] -pprRIReg :: FAST_STRING -> Bool -> RI -> Reg -> Doc +pprRIReg :: LitString -> Bool -> RI -> Reg -> Doc pprRIReg name b ri reg1 = hcat [ char '\t', @@ -1370,10 +1845,361 @@ pprRIReg name b ri reg1 pprReg reg1 ] -pp_ld_lbracket = ptext (pACK_STR (a_HASH "\tld\t["#)) -pp_rbracket_comma = ptext (pACK_STR (a_HASH "],"#)) -pp_comma_lbracket = ptext (pACK_STR (a_HASH ",["#)) -pp_comma_a = ptext (pACK_STR (a_HASH ",a"#)) +pp_ld_lbracket = ptext SLIT("\tld\t[") +pp_rbracket_comma = text "]," +pp_comma_lbracket = text ",[" +pp_comma_a = text ",a" + +#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 -#endif {-sparc_TARGET_ARCH-} +-- 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}