ghc/compiler/nativeGen/PprMach.hs

   1 -----------------------------------------------------------------------------
   2 --
   3 -- Pretty-printing assembly language
   4 --
   5 -- (c) The University of Glasgow 1993-2005
   6 --
   7 -----------------------------------------------------------------------------
   8
   9 -- We start with the @pprXXX@s with some cross-platform commonality
  10 -- (e.g., 'pprReg'); we conclude with the no-commonality monster,
  11 -- 'pprInstr'.
  12
  13 #include "nativeGen/NCG.h"
  14
  15 module PprMach (
  16         pprNatCmmTop, pprBasicBlock,
  17         pprInstr, pprSize, pprUserReg,
  18   ) where
  19
  20
  21 #include "HsVersions.h"
  22
  23 import Cmm
  24 import MachOp           ( MachRep(..), wordRep, isFloatingRep )
  25 import MachRegs         -- may differ per-platform
  26 import MachInstrs
  27
  28 import CLabel           ( CLabel, pprCLabel, externallyVisibleCLabel,
  29                           labelDynamic, mkAsmTempLabel, entryLblToInfoLbl )
  30 #if HAVE_SUBSECTIONS_VIA_SYMBOLS
  31 import CLabel       ( mkDeadStripPreventer )
  32 #endif
  33
  34 import Panic            ( panic )
  35 import Unique           ( pprUnique )
  36 import Pretty
  37 import FastString
  38 import qualified Outputable
  39
  40 import StaticFlags      ( opt_PIC, opt_Static )
  41
  42 #if __GLASGOW_HASKELL__ >= 504
  43 import Data.Array.ST
  44 import Data.Word        ( Word8 )
  45 #else
  46 import MutableArray
  47 #endif
  48
  49 import MONAD_ST
  50 import Char             ( chr, ord )
  51 import Maybe            ( isJust )
  52
  53 #if powerpc_TARGET_ARCH
  54 import DATA_WORD(Word32)
  55 import DATA_BITS
  56 #endif
  57
  58 -- -----------------------------------------------------------------------------
  59 -- Printing this stuff out
  60
  61 asmSDoc d = Outputable.withPprStyleDoc (
  62               Outputable.mkCodeStyle Outputable.AsmStyle) d
  63 pprCLabel_asm l = asmSDoc (pprCLabel l)
  64
  65 pprNatCmmTop :: NatCmmTop -> Doc
  66 pprNatCmmTop (CmmData section dats) =
  67   pprSectionHeader section $$ vcat (map pprData dats)
  68
  69  -- special case for split markers:
  70 pprNatCmmTop (CmmProc [] lbl _ []) = pprLabel lbl
  71
  72 pprNatCmmTop (CmmProc info lbl params blocks) =
  73   pprSectionHeader Text $$
  74   (if not (null info)
  75         then
  76 #if HAVE_SUBSECTIONS_VIA_SYMBOLS
  77             pprCLabel_asm (mkDeadStripPreventer $ entryLblToInfoLbl lbl)
  78                 <> char ':' $$
  79 #endif
  80             vcat (map pprData info) $$
  81             pprLabel (entryLblToInfoLbl lbl)
  82         else empty) $$
  83   (case blocks of
  84         [] -> empty
  85         (BasicBlock _ instrs : rest) ->
  86                 (if null info then pprLabel lbl else empty) $$
  87                 -- the first block doesn't get a label:
  88                 vcat (map pprInstr instrs) $$
  89                 vcat (map pprBasicBlock rest)
  90   )
  91 #if HAVE_SUBSECTIONS_VIA_SYMBOLS
  92         -- If we are using the .subsections_via_symbols directive
  93         -- (available on recent versions of Darwin),
  94         -- we have to make sure that there is some kind of reference
  95         -- from the entry code to a label on the _top_ of of the info table,
  96         -- so that the linker will not think it is unreferenced and dead-strip
  97         -- it. That's why the label is called a DeadStripPreventer (_dsp).
  98   $$ if not (null info)
  99                     then text "\t.long "
 100                       <+> pprCLabel_asm (entryLblToInfoLbl lbl)
 101                       <+> char '-'
 102                       <+> pprCLabel_asm (mkDeadStripPreventer $ entryLblToInfoLbl lbl)
 103                     else empty
 104 #endif
 105
 106
 107 pprBasicBlock :: NatBasicBlock -> Doc
 108 pprBasicBlock (BasicBlock (BlockId id) instrs) =
 109   pprLabel (mkAsmTempLabel id) $$
 110   vcat (map pprInstr instrs)
 111
 112 -- -----------------------------------------------------------------------------
 113 -- pprReg: print a 'Reg'
 114
 115 -- For x86, the way we print a register name depends
 116 -- on which bit of it we care about.  Yurgh.
 117
 118 pprUserReg :: Reg -> Doc
 119 pprUserReg = pprReg IF_ARCH_i386(I32,) IF_ARCH_x86_64(I64,)
 120
 121 pprReg :: IF_ARCH_i386(MachRep ->,) IF_ARCH_x86_64(MachRep ->,) Reg -> Doc
 122
 123 pprReg IF_ARCH_i386(s,) IF_ARCH_x86_64(s,) r
 124   = case r of
 125       RealReg i      -> ppr_reg_no IF_ARCH_i386(s,) IF_ARCH_x86_64(s,) i
 126       VirtualRegI  u  -> text "%vI_" <> asmSDoc (pprUnique u)
 127       VirtualRegHi u  -> text "%vHi_" <> asmSDoc (pprUnique u)
 128       VirtualRegF  u  -> text "%vF_" <> asmSDoc (pprUnique u)
 129       VirtualRegD  u  -> text "%vD_" <> asmSDoc (pprUnique u)
 130   where
 131 #if alpha_TARGET_ARCH
 132     ppr_reg_no :: Int -> Doc
 133     ppr_reg_no i = ptext
 134       (case i of {
 135          0 -> SLIT("$0");    1 -> SLIT("$1");
 136          2 -> SLIT("$2");    3 -> SLIT("$3");
 137          4 -> SLIT("$4");    5 -> SLIT("$5");
 138          6 -> SLIT("$6");    7 -> SLIT("$7");
 139          8 -> SLIT("$8");    9 -> SLIT("$9");
 140         10 -> SLIT("$10");  11 -> SLIT("$11");
 141         12 -> SLIT("$12");  13 -> SLIT("$13");
 142         14 -> SLIT("$14");  15 -> SLIT("$15");
 143         16 -> SLIT("$16");  17 -> SLIT("$17");
 144         18 -> SLIT("$18");  19 -> SLIT("$19");
 145         20 -> SLIT("$20");  21 -> SLIT("$21");
 146         22 -> SLIT("$22");  23 -> SLIT("$23");
 147         24 -> SLIT("$24");  25 -> SLIT("$25");
 148         26 -> SLIT("$26");  27 -> SLIT("$27");
 149         28 -> SLIT("$28");  29 -> SLIT("$29");
 150         30 -> SLIT("$30");  31 -> SLIT("$31");
 151         32 -> SLIT("$f0");  33 -> SLIT("$f1");
 152         34 -> SLIT("$f2");  35 -> SLIT("$f3");
 153         36 -> SLIT("$f4");  37 -> SLIT("$f5");
 154         38 -> SLIT("$f6");  39 -> SLIT("$f7");
 155         40 -> SLIT("$f8");  41 -> SLIT("$f9");
 156         42 -> SLIT("$f10"); 43 -> SLIT("$f11");
 157         44 -> SLIT("$f12"); 45 -> SLIT("$f13");
 158         46 -> SLIT("$f14"); 47 -> SLIT("$f15");
 159         48 -> SLIT("$f16"); 49 -> SLIT("$f17");
 160         50 -> SLIT("$f18"); 51 -> SLIT("$f19");
 161         52 -> SLIT("$f20"); 53 -> SLIT("$f21");
 162         54 -> SLIT("$f22"); 55 -> SLIT("$f23");
 163         56 -> SLIT("$f24"); 57 -> SLIT("$f25");
 164         58 -> SLIT("$f26"); 59 -> SLIT("$f27");
 165         60 -> SLIT("$f28"); 61 -> SLIT("$f29");
 166         62 -> SLIT("$f30"); 63 -> SLIT("$f31");
 167         _  -> SLIT("very naughty alpha register")
 168       })
 169 #endif
 170 #if i386_TARGET_ARCH
 171     ppr_reg_no :: MachRep -> Int -> Doc
 172     ppr_reg_no I8   = ppr_reg_byte
 173     ppr_reg_no I16  = ppr_reg_word
 174     ppr_reg_no _    = ppr_reg_long
 175
 176     ppr_reg_byte i = ptext
 177       (case i of {
 178          0 -> SLIT("%al");     1 -> SLIT("%bl");
 179          2 -> SLIT("%cl");     3 -> SLIT("%dl");
 180         _  -> SLIT("very naughty I386 byte register")
 181       })
 182
 183     ppr_reg_word i = ptext
 184       (case i of {
 185          0 -> SLIT("%ax");     1 -> SLIT("%bx");
 186          2 -> SLIT("%cx");     3 -> SLIT("%dx");
 187          4 -> SLIT("%si");     5 -> SLIT("%di");
 188          6 -> SLIT("%bp");     7 -> SLIT("%sp");
 189         _  -> SLIT("very naughty I386 word register")
 190       })
 191
 192     ppr_reg_long i = ptext
 193       (case i of {
 194          0 -> SLIT("%eax");    1 -> SLIT("%ebx");
 195          2 -> SLIT("%ecx");    3 -> SLIT("%edx");
 196          4 -> SLIT("%esi");    5 -> SLIT("%edi");
 197          6 -> SLIT("%ebp");    7 -> SLIT("%esp");
 198          8 -> SLIT("%fake0");  9 -> SLIT("%fake1");
 199         10 -> SLIT("%fake2"); 11 -> SLIT("%fake3");
 200         12 -> SLIT("%fake4"); 13 -> SLIT("%fake5");
 201         _  -> SLIT("very naughty I386 register")
 202       })
 203 #endif
 204
 205 #if x86_64_TARGET_ARCH
 206     ppr_reg_no :: MachRep -> Int -> Doc
 207     ppr_reg_no I8   = ppr_reg_byte
 208     ppr_reg_no I16  = ppr_reg_word
 209     ppr_reg_no I32  = ppr_reg_long
 210     ppr_reg_no _    = ppr_reg_quad
 211
 212     ppr_reg_byte i = ptext
 213       (case i of {
 214          0 -> SLIT("%al");     1 -> SLIT("%bl");
 215          2 -> SLIT("%cl");     3 -> SLIT("%dl");
 216          4 -> SLIT("%sil");    5 -> SLIT("%dil"); -- new 8-bit regs!
 217          6 -> SLIT("%bpl");    7 -> SLIT("%spl");
 218          8 -> SLIT("%r8b");    9  -> SLIT("%r9b");
 219         10 -> SLIT("%r10b");   11 -> SLIT("%r11b");
 220         12 -> SLIT("%r12b");   13 -> SLIT("%r13b");
 221         14 -> SLIT("%r14b");   15 -> SLIT("%r15b");
 222         _  -> SLIT("very naughty x86_64 byte register")
 223       })
 224
 225     ppr_reg_word i = ptext
 226       (case i of {
 227          0 -> SLIT("%ax");     1 -> SLIT("%bx");
 228          2 -> SLIT("%cx");     3 -> SLIT("%dx");
 229          4 -> SLIT("%si");     5 -> SLIT("%di");
 230          6 -> SLIT("%bp");     7 -> SLIT("%sp");
 231          8 -> SLIT("%r8w");    9  -> SLIT("%r9w");
 232         10 -> SLIT("%r10w");   11 -> SLIT("%r11w");
 233         12 -> SLIT("%r12w");   13 -> SLIT("%r13w");
 234         14 -> SLIT("%r14w");   15 -> SLIT("%r15w");
 235         _  -> SLIT("very naughty x86_64 word register")
 236       })
 237
 238     ppr_reg_long i = ptext
 239       (case i of {
 240          0 -> SLIT("%eax");    1  -> SLIT("%ebx");
 241          2 -> SLIT("%ecx");    3  -> SLIT("%edx");
 242          4 -> SLIT("%esi");    5  -> SLIT("%edi");
 243          6 -> SLIT("%ebp");    7  -> SLIT("%esp");
 244          8 -> SLIT("%r8d");    9  -> SLIT("%r9d");
 245         10 -> SLIT("%r10d");   11 -> SLIT("%r11d");
 246         12 -> SLIT("%r12d");   13 -> SLIT("%r13d");
 247         14 -> SLIT("%r14d");   15 -> SLIT("%r15d");
 248         _  -> SLIT("very naughty x86_64 register")
 249       })
 250
 251     ppr_reg_quad i = ptext
 252       (case i of {
 253          0 -> SLIT("%rax");     1 -> SLIT("%rbx");
 254          2 -> SLIT("%rcx");     3 -> SLIT("%rdx");
 255          4 -> SLIT("%rsi");     5 -> SLIT("%rdi");
 256          6 -> SLIT("%rbp");     7 -> SLIT("%rsp");
 257          8 -> SLIT("%r8");      9 -> SLIT("%r9");
 258         10 -> SLIT("%r10");    11 -> SLIT("%r11");
 259         12 -> SLIT("%r12");    13 -> SLIT("%r13");
 260         14 -> SLIT("%r14");    15 -> SLIT("%r15");
 261         16 -> SLIT("%xmm0");   17 -> SLIT("%xmm1");
 262         18 -> SLIT("%xmm2");   19 -> SLIT("%xmm3");
 263         20 -> SLIT("%xmm4");   21 -> SLIT("%xmm5");
 264         22 -> SLIT("%xmm6");   23 -> SLIT("%xmm7");
 265         24 -> SLIT("%xmm8");   25 -> SLIT("%xmm9");
 266         26 -> SLIT("%xmm10");  27 -> SLIT("%xmm11");
 267         28 -> SLIT("%xmm12");  29 -> SLIT("%xmm13");
 268         30 -> SLIT("%xmm14");  31 -> SLIT("%xmm15");
 269         _  -> SLIT("very naughty x86_64 register")
 270       })
 271 #endif
 272
 273 #if sparc_TARGET_ARCH
 274     ppr_reg_no :: Int -> Doc
 275     ppr_reg_no i = ptext
 276       (case i of {
 277          0 -> SLIT("%g0");   1 -> SLIT("%g1");
 278          2 -> SLIT("%g2");   3 -> SLIT("%g3");
 279          4 -> SLIT("%g4");   5 -> SLIT("%g5");
 280          6 -> SLIT("%g6");   7 -> SLIT("%g7");
 281          8 -> SLIT("%o0");   9 -> SLIT("%o1");
 282         10 -> SLIT("%o2");  11 -> SLIT("%o3");
 283         12 -> SLIT("%o4");  13 -> SLIT("%o5");
 284         14 -> SLIT("%o6");  15 -> SLIT("%o7");
 285         16 -> SLIT("%l0");  17 -> SLIT("%l1");
 286         18 -> SLIT("%l2");  19 -> SLIT("%l3");
 287         20 -> SLIT("%l4");  21 -> SLIT("%l5");
 288         22 -> SLIT("%l6");  23 -> SLIT("%l7");
 289         24 -> SLIT("%i0");  25 -> SLIT("%i1");
 290         26 -> SLIT("%i2");  27 -> SLIT("%i3");
 291         28 -> SLIT("%i4");  29 -> SLIT("%i5");
 292         30 -> SLIT("%i6");  31 -> SLIT("%i7");
 293         32 -> SLIT("%f0");  33 -> SLIT("%f1");
 294         34 -> SLIT("%f2");  35 -> SLIT("%f3");
 295         36 -> SLIT("%f4");  37 -> SLIT("%f5");
 296         38 -> SLIT("%f6");  39 -> SLIT("%f7");
 297         40 -> SLIT("%f8");  41 -> SLIT("%f9");
 298         42 -> SLIT("%f10"); 43 -> SLIT("%f11");
 299         44 -> SLIT("%f12"); 45 -> SLIT("%f13");
 300         46 -> SLIT("%f14"); 47 -> SLIT("%f15");
 301         48 -> SLIT("%f16"); 49 -> SLIT("%f17");
 302         50 -> SLIT("%f18"); 51 -> SLIT("%f19");
 303         52 -> SLIT("%f20"); 53 -> SLIT("%f21");
 304         54 -> SLIT("%f22"); 55 -> SLIT("%f23");
 305         56 -> SLIT("%f24"); 57 -> SLIT("%f25");
 306         58 -> SLIT("%f26"); 59 -> SLIT("%f27");
 307         60 -> SLIT("%f28"); 61 -> SLIT("%f29");
 308         62 -> SLIT("%f30"); 63 -> SLIT("%f31");
 309         _  -> SLIT("very naughty sparc register")
 310       })
 311 #endif
 312 #if powerpc_TARGET_ARCH
 313 #if darwin_TARGET_OS
 314     ppr_reg_no :: Int -> Doc
 315     ppr_reg_no i = ptext
 316       (case i of {
 317          0 -> SLIT("r0");   1 -> SLIT("r1");
 318          2 -> SLIT("r2");   3 -> SLIT("r3");
 319          4 -> SLIT("r4");   5 -> SLIT("r5");
 320          6 -> SLIT("r6");   7 -> SLIT("r7");
 321          8 -> SLIT("r8");   9 -> SLIT("r9");
 322         10 -> SLIT("r10");  11 -> SLIT("r11");
 323         12 -> SLIT("r12");  13 -> SLIT("r13");
 324         14 -> SLIT("r14");  15 -> SLIT("r15");
 325         16 -> SLIT("r16");  17 -> SLIT("r17");
 326         18 -> SLIT("r18");  19 -> SLIT("r19");
 327         20 -> SLIT("r20");  21 -> SLIT("r21");
 328         22 -> SLIT("r22");  23 -> SLIT("r23");
 329         24 -> SLIT("r24");  25 -> SLIT("r25");
 330         26 -> SLIT("r26");  27 -> SLIT("r27");
 331         28 -> SLIT("r28");  29 -> SLIT("r29");
 332         30 -> SLIT("r30");  31 -> SLIT("r31");
 333         32 -> SLIT("f0");  33 -> SLIT("f1");
 334         34 -> SLIT("f2");  35 -> SLIT("f3");
 335         36 -> SLIT("f4");  37 -> SLIT("f5");
 336         38 -> SLIT("f6");  39 -> SLIT("f7");
 337         40 -> SLIT("f8");  41 -> SLIT("f9");
 338         42 -> SLIT("f10"); 43 -> SLIT("f11");
 339         44 -> SLIT("f12"); 45 -> SLIT("f13");
 340         46 -> SLIT("f14"); 47 -> SLIT("f15");
 341         48 -> SLIT("f16"); 49 -> SLIT("f17");
 342         50 -> SLIT("f18"); 51 -> SLIT("f19");
 343         52 -> SLIT("f20"); 53 -> SLIT("f21");
 344         54 -> SLIT("f22"); 55 -> SLIT("f23");
 345         56 -> SLIT("f24"); 57 -> SLIT("f25");
 346         58 -> SLIT("f26"); 59 -> SLIT("f27");
 347         60 -> SLIT("f28"); 61 -> SLIT("f29");
 348         62 -> SLIT("f30"); 63 -> SLIT("f31");
 349         _  -> SLIT("very naughty powerpc register")
 350       })
 351 #else
 352     ppr_reg_no :: Int -> Doc
 353     ppr_reg_no i | i <= 31 = int i      -- GPRs
 354                  | i <= 63 = int (i-32) -- FPRs
 355                  | otherwise = ptext SLIT("very naughty powerpc register")
 356 #endif
 357 #endif
 358
 359
 360 -- -----------------------------------------------------------------------------
 361 -- pprSize: print a 'Size'
 362
 363 #if powerpc_TARGET_ARCH || i386_TARGET_ARCH || x86_64_TARGET_ARCH || sparc_TARGET_ARCH
 364 pprSize :: MachRep -> Doc
 365 #else
 366 pprSize :: Size -> Doc
 367 #endif
 368
 369 pprSize x = ptext (case x of
 370 #if alpha_TARGET_ARCH
 371          B  -> SLIT("b")
 372          Bu -> SLIT("bu")
 373 --       W  -> SLIT("w") UNUSED
 374 --       Wu -> SLIT("wu") UNUSED
 375          L  -> SLIT("l")
 376          Q  -> SLIT("q")
 377 --       FF -> SLIT("f") UNUSED
 378 --       DF -> SLIT("d") UNUSED
 379 --       GF -> SLIT("g") UNUSED
 380 --       SF -> SLIT("s") UNUSED
 381          TF -> SLIT("t")
 382 #endif
 383 #if i386_TARGET_ARCH || x86_64_TARGET_ARCH
 384         I8   -> SLIT("b")
 385         I16  -> SLIT("w")
 386         I32  -> SLIT("l")
 387         I64  -> SLIT("q")
 388 #endif
 389 #if i386_TARGET_ARCH
 390         F32  -> SLIT("s")
 391         F64  -> SLIT("l")
 392         F80  -> SLIT("t")
 393 #endif
 394 #if x86_64_TARGET_ARCH
 395         F32  -> SLIT("ss")      -- "scalar single-precision float" (SSE2)
 396         F64  -> SLIT("sd")      -- "scalar double-precision float" (SSE2)
 397 #endif
 398 #if sparc_TARGET_ARCH
 399         I8   -> SLIT("sb")
 400         I16   -> SLIT("sh")
 401         I32   -> SLIT("")
 402         F32   -> SLIT("")
 403         F64  -> SLIT("d")
 404     )
 405 pprStSize :: MachRep -> Doc
 406 pprStSize x = ptext (case x of
 407         I8   -> SLIT("b")
 408         I16  -> SLIT("h")
 409         I32  -> SLIT("")
 410         F32  -> SLIT("")
 411         F64  -> SLIT("d")
 412 #endif
 413 #if powerpc_TARGET_ARCH
 414         I8   -> SLIT("b")
 415         I16  -> SLIT("h")
 416         I32  -> SLIT("w")
 417         F32  -> SLIT("fs")
 418         F64  -> SLIT("fd")
 419 #endif
 420     )
 421
 422 -- -----------------------------------------------------------------------------
 423 -- pprCond: print a 'Cond'
 424
 425 pprCond :: Cond -> Doc
 426
 427 pprCond c = ptext (case c of {
 428 #if alpha_TARGET_ARCH
 429         EQQ  -> SLIT("eq");
 430         LTT  -> SLIT("lt");
 431         LE  -> SLIT("le");
 432         ULT -> SLIT("ult");
 433         ULE -> SLIT("ule");
 434         NE  -> SLIT("ne");
 435         GTT  -> SLIT("gt");
 436         GE  -> SLIT("ge")
 437 #endif
 438 #if i386_TARGET_ARCH || x86_64_TARGET_ARCH
 439         GEU     -> SLIT("ae");  LU    -> SLIT("b");
 440         EQQ     -> SLIT("e");   GTT   -> SLIT("g");
 441         GE      -> SLIT("ge");  GU    -> SLIT("a");
 442         LTT     -> SLIT("l");   LE    -> SLIT("le");
 443         LEU     -> SLIT("be");  NE    -> SLIT("ne");
 444         NEG     -> SLIT("s");   POS   -> SLIT("ns");
 445         CARRY   -> SLIT("c");   OFLO  -> SLIT("o");
 446         PARITY  -> SLIT("p");   NOTPARITY -> SLIT("np");
 447         ALWAYS  -> SLIT("mp")   -- hack
 448 #endif
 449 #if sparc_TARGET_ARCH
 450         ALWAYS  -> SLIT("");    NEVER -> SLIT("n");
 451         GEU     -> SLIT("geu"); LU    -> SLIT("lu");
 452         EQQ     -> SLIT("e");   GTT   -> SLIT("g");
 453         GE      -> SLIT("ge");  GU    -> SLIT("gu");
 454         LTT     -> SLIT("l");   LE    -> SLIT("le");
 455         LEU     -> SLIT("leu"); NE    -> SLIT("ne");
 456         NEG     -> SLIT("neg"); POS   -> SLIT("pos");
 457         VC      -> SLIT("vc");  VS    -> SLIT("vs")
 458 #endif
 459 #if powerpc_TARGET_ARCH
 460         ALWAYS  -> SLIT("");
 461         EQQ     -> SLIT("eq");  NE    -> SLIT("ne");
 462         LTT     -> SLIT("lt");  GE    -> SLIT("ge");
 463         GTT     -> SLIT("gt");  LE    -> SLIT("le");
 464         LU      -> SLIT("lt");  GEU   -> SLIT("ge");
 465         GU      -> SLIT("gt");  LEU   -> SLIT("le");
 466 #endif
 467     })
 468
 469
 470 -- -----------------------------------------------------------------------------
 471 -- pprImm: print an 'Imm'
 472
 473 pprImm :: Imm -> Doc
 474
 475 pprImm (ImmInt i)     = int i
 476 pprImm (ImmInteger i) = integer i
 477 pprImm (ImmCLbl l)    = pprCLabel_asm l
 478 pprImm (ImmIndex l i) = pprCLabel_asm l <> char '+' <> int i
 479 pprImm (ImmLit s)     = s
 480
 481 pprImm (ImmFloat _) = ptext SLIT("naughty float immediate")
 482 pprImm (ImmDouble _) = ptext SLIT("naughty double immediate")
 483
 484 pprImm (ImmConstantSum a b) = pprImm a <> char '+' <> pprImm b
 485 #if sparc_TARGET_ARCH
 486 -- ToDo: This should really be fixed in the PIC support, but only
 487 -- print a for now.
 488 pprImm (ImmConstantDiff a b) = pprImm a
 489 #else
 490 pprImm (ImmConstantDiff a b) = pprImm a <> char '-'
 491                             <> lparen <> pprImm b <> rparen
 492 #endif
 493
 494 #if sparc_TARGET_ARCH
 495 pprImm (LO i)
 496   = hcat [ pp_lo, pprImm i, rparen ]
 497   where
 498     pp_lo = text "%lo("
 499
 500 pprImm (HI i)
 501   = hcat [ pp_hi, pprImm i, rparen ]
 502   where
 503     pp_hi = text "%hi("
 504 #endif
 505 #if powerpc_TARGET_ARCH
 506 #if darwin_TARGET_OS
 507 pprImm (LO i)
 508   = hcat [ pp_lo, pprImm i, rparen ]
 509   where
 510     pp_lo = text "lo16("
 511
 512 pprImm (HI i)
 513   = hcat [ pp_hi, pprImm i, rparen ]
 514   where
 515     pp_hi = text "hi16("
 516
 517 pprImm (HA i)
 518   = hcat [ pp_ha, pprImm i, rparen ]
 519   where
 520     pp_ha = text "ha16("
 521
 522 #else
 523 pprImm (LO i)
 524   = pprImm i <> text "@l"
 525
 526 pprImm (HI i)
 527   = pprImm i <> text "@h"
 528
 529 pprImm (HA i)
 530   = pprImm i <> text "@ha"
 531 #endif
 532 #endif
 533
 534
 535 -- -----------------------------------------------------------------------------
 536 -- @pprAddr: print an 'AddrMode'
 537
 538 pprAddr :: AddrMode -> Doc
 539
 540 #if alpha_TARGET_ARCH
 541 pprAddr (AddrReg r) = parens (pprReg r)
 542 pprAddr (AddrImm i) = pprImm i
 543 pprAddr (AddrRegImm r1 i)
 544   = (<>) (pprImm i) (parens (pprReg r1))
 545 #endif
 546
 547 -------------------
 548
 549 #if i386_TARGET_ARCH || x86_64_TARGET_ARCH
 550 pprAddr (ImmAddr imm off)
 551   = let pp_imm = pprImm imm
 552     in
 553     if (off == 0) then
 554         pp_imm
 555     else if (off < 0) then
 556         pp_imm <> int off
 557     else
 558         pp_imm <> char '+' <> int off
 559
 560 pprAddr (AddrBaseIndex base index displacement)
 561   = let
 562         pp_disp  = ppr_disp displacement
 563         pp_off p = pp_disp <> char '(' <> p <> char ')'
 564         pp_reg r = pprReg wordRep r
 565     in
 566     case (base,index) of
 567       (EABaseNone,  EAIndexNone) -> pp_disp
 568       (EABaseReg b, EAIndexNone) -> pp_off (pp_reg b)
 569       (EABaseRip,   EAIndexNone) -> pp_off (ptext SLIT("%rip"))
 570       (EABaseNone,  EAIndex r i) -> pp_off (comma <> pp_reg r <> comma <> int i)
 571       (EABaseReg b, EAIndex r i) -> pp_off (pp_reg b <> comma <> pp_reg r
 572                                        <> comma <> int i)
 573   where
 574     ppr_disp (ImmInt 0) = empty
 575     ppr_disp imm        = pprImm imm
 576 #endif
 577
 578 -------------------
 579
 580 #if sparc_TARGET_ARCH
 581 pprAddr (AddrRegReg r1 (RealReg 0)) = pprReg r1
 582
 583 pprAddr (AddrRegReg r1 r2)
 584   = hcat [ pprReg r1, char '+', pprReg r2 ]
 585
 586 pprAddr (AddrRegImm r1 (ImmInt i))
 587   | i == 0 = pprReg r1
 588   | not (fits13Bits i) = largeOffsetError i
 589   | otherwise = hcat [ pprReg r1, pp_sign, int i ]
 590   where
 591     pp_sign = if i > 0 then char '+' else empty
 592
 593 pprAddr (AddrRegImm r1 (ImmInteger i))
 594   | i == 0 = pprReg r1
 595   | not (fits13Bits i) = largeOffsetError i
 596   | otherwise  = hcat [ pprReg r1, pp_sign, integer i ]
 597   where
 598     pp_sign = if i > 0 then char '+' else empty
 599
 600 pprAddr (AddrRegImm r1 imm)
 601   = hcat [ pprReg r1, char '+', pprImm imm ]
 602 #endif
 603
 604 -------------------
 605
 606 #if powerpc_TARGET_ARCH
 607 pprAddr (AddrRegReg r1 r2)
 608   = pprReg r1 <+> ptext SLIT(", ") <+> pprReg r2
 609
 610 pprAddr (AddrRegImm r1 (ImmInt i)) = hcat [ int i, char '(', pprReg r1, char ')' ]
 611 pprAddr (AddrRegImm r1 (ImmInteger i)) = hcat [ integer i, char '(', pprReg r1, char ')' ]
 612 pprAddr (AddrRegImm r1 imm) = hcat [ pprImm imm, char '(', pprReg r1, char ')' ]
 613 #endif
 614
 615
 616 -- -----------------------------------------------------------------------------
 617 -- pprData: print a 'CmmStatic'
 618
 619 pprSectionHeader Text
 620     = ptext
 621         IF_ARCH_alpha(SLIT("\t.text\n\t.align 3") {-word boundary-}
 622        ,IF_ARCH_sparc(SLIT(".text\n\t.align 4") {-word boundary-}
 623        ,IF_ARCH_i386(IF_OS_darwin(SLIT(".text\n\t.align 2"),
 624                                   SLIT(".text\n\t.align 4,0x90"))
 625                                   {-needs per-OS variation!-}
 626        ,IF_ARCH_x86_64(SLIT(".text\n\t.align 8") {-needs per-OS variation!-}
 627        ,IF_ARCH_powerpc(SLIT(".text\n.align 2")
 628        ,)))))
 629 pprSectionHeader Data
 630     = ptext
 631          IF_ARCH_alpha(SLIT("\t.data\n\t.align 3")
 632         ,IF_ARCH_sparc(SLIT(".data\n\t.align 8") {-<8 will break double constants -}
 633         ,IF_ARCH_i386(IF_OS_darwin(SLIT(".data\n\t.align 2"),
 634                                    SLIT(".data\n\t.align 4"))
 635         ,IF_ARCH_x86_64(SLIT(".data\n\t.align 8")
 636         ,IF_ARCH_powerpc(SLIT(".data\n.align 2")
 637         ,)))))
 638 pprSectionHeader ReadOnlyData
 639     = ptext
 640          IF_ARCH_alpha(SLIT("\t.data\n\t.align 3")
 641         ,IF_ARCH_sparc(SLIT(".data\n\t.align 8") {-<8 will break double constants -}
 642         ,IF_ARCH_i386(IF_OS_darwin(SLIT(".const\n.align 2"),
 643                                    SLIT(".section .rodata\n\t.align 4"))
 644         ,IF_ARCH_x86_64(SLIT(".section .rodata\n\t.align 8")
 645         ,IF_ARCH_powerpc(IF_OS_darwin(SLIT(".const\n.align 2"),
 646                                       SLIT(".section .rodata\n\t.align 2"))
 647         ,)))))
 648 pprSectionHeader RelocatableReadOnlyData
 649     = ptext
 650          IF_ARCH_alpha(SLIT("\t.data\n\t.align 3")
 651         ,IF_ARCH_sparc(SLIT(".data\n\t.align 8") {-<8 will break double constants -}
 652         ,IF_ARCH_i386(IF_OS_darwin(SLIT(".const_data\n.align 2"),
 653                                    SLIT(".section .rodata\n\t.align 4"))
 654         ,IF_ARCH_x86_64(SLIT(".section .rodata\n\t.align 8")
 655         ,IF_ARCH_powerpc(IF_OS_darwin(SLIT(".const_data\n.align 2"),
 656                                       SLIT(".data\n\t.align 2"))
 657         ,)))))
 658 pprSectionHeader UninitialisedData
 659     = ptext
 660          IF_ARCH_alpha(SLIT("\t.bss\n\t.align 3")
 661         ,IF_ARCH_sparc(SLIT(".bss\n\t.align 8") {-<8 will break double constants -}
 662         ,IF_ARCH_i386(IF_OS_darwin(SLIT(".const_data\n\t.align 2"),
 663                                    SLIT(".section .bss\n\t.align 4"))
 664         ,IF_ARCH_x86_64(SLIT(".section .bss\n\t.align 8")
 665         ,IF_ARCH_powerpc(IF_OS_darwin(SLIT(".const_data\n.align 2"),
 666                                       SLIT(".section .bss\n\t.align 2"))
 667         ,)))))
 668 pprSectionHeader ReadOnlyData16
 669     = ptext
 670          IF_ARCH_alpha(SLIT("\t.data\n\t.align 4")
 671         ,IF_ARCH_sparc(SLIT(".data\n\t.align 16")
 672         ,IF_ARCH_i386(IF_OS_darwin(SLIT(".const\n.align 4"),
 673                                    SLIT(".section .rodata\n\t.align 16"))
 674         ,IF_ARCH_x86_64(SLIT(".section .rodata.cst16\n\t.align 16")
 675         ,IF_ARCH_powerpc(IF_OS_darwin(SLIT(".const\n.align 4"),
 676                                       SLIT(".section .rodata\n\t.align 4"))
 677         ,)))))
 678
 679 pprSectionHeader (OtherSection sec)
 680     = panic "PprMach.pprSectionHeader: unknown section"
 681
 682 pprData :: CmmStatic -> Doc
 683 pprData (CmmAlign bytes)         = pprAlign bytes
 684 pprData (CmmDataLabel lbl)       = pprLabel lbl
 685 pprData (CmmString str)          = pprASCII str
 686 pprData (CmmUninitialised bytes) = ptext SLIT(".space ") <> int bytes
 687 pprData (CmmStaticLit lit)       = pprDataItem lit
 688
 689 pprGloblDecl :: CLabel -> Doc
 690 pprGloblDecl lbl
 691   | not (externallyVisibleCLabel lbl) = empty
 692   | otherwise = ptext IF_ARCH_sparc(SLIT(".global "),
 693                                     SLIT(".globl ")) <>
 694                 pprCLabel_asm lbl
 695
 696 pprLabel :: CLabel -> Doc
 697 pprLabel lbl = pprGloblDecl lbl $$ (pprCLabel_asm lbl <> char ':')
 698
 699
 700 pprASCII str
 701   = vcat (map do1 str) $$ do1 0
 702     where
 703        do1 :: Word8 -> Doc
 704        do1 w = ptext SLIT("\t.byte\t") <> int (fromIntegral w)
 705
 706 pprAlign bytes =
 707         IF_ARCH_alpha(ptextSLIT(".align ") <> int pow2,
 708         IF_ARCH_i386(ptext SLIT(".align ") <> int IF_OS_darwin(pow2,bytes),
 709         IF_ARCH_x86_64(ptext SLIT(".align ") <> int bytes,
 710         IF_ARCH_sparc(ptext SLIT(".align ") <> int bytes,
 711         IF_ARCH_powerpc(ptext SLIT(".align ") <> int pow2,)))))
 712   where
 713         pow2 = log2 bytes
 714
 715         log2 :: Int -> Int  -- cache the common ones
 716         log2 1 = 0
 717         log2 2 = 1
 718         log2 4 = 2
 719         log2 8 = 3
 720         log2 n = 1 + log2 (n `quot` 2)
 721
 722
 723 pprDataItem :: CmmLit -> Doc
 724 pprDataItem lit
 725   = vcat (ppr_item (cmmLitRep lit) lit)
 726     where
 727         imm = litToImm lit
 728
 729         -- These seem to be common:
 730         ppr_item I8   x = [ptext SLIT("\t.byte\t") <> pprImm imm]
 731         ppr_item I32  x = [ptext SLIT("\t.long\t") <> pprImm imm]
 732         ppr_item F32  (CmmFloat r _)
 733            = let bs = floatToBytes (fromRational r)
 734              in  map (\b -> ptext SLIT("\t.byte\t") <> pprImm (ImmInt b)) bs
 735         ppr_item F64 (CmmFloat r _)
 736            = let bs = doubleToBytes (fromRational r)
 737              in  map (\b -> ptext SLIT("\t.byte\t") <> pprImm (ImmInt b)) bs
 738
 739 #if sparc_TARGET_ARCH
 740         -- copy n paste of x86 version
 741         ppr_item I16  x = [ptext SLIT("\t.short\t") <> pprImm imm]
 742         ppr_item I64  x = [ptext SLIT("\t.quad\t") <> pprImm imm]
 743 #endif
 744 #if i386_TARGET_ARCH || x86_64_TARGET_ARCH
 745         ppr_item I16  x = [ptext SLIT("\t.word\t") <> pprImm imm]
 746 #endif
 747 #if i386_TARGET_ARCH
 748         ppr_item I64  x = [ptext SLIT("\t.quad\t") <> pprImm imm]
 749 #endif
 750 #if x86_64_TARGET_ARCH
 751         -- x86_64: binutils can't handle the R_X86_64_PC64 relocation
 752         -- type, which means we can't do pc-relative 64-bit addresses.
 753         -- Fortunately we're assuming the small memory model, in which
 754         -- all such offsets will fit into 32 bits, so we have to stick
 755         -- to 32-bit offset fields and modify the RTS appropriately
 756         -- (see InfoTables.h).
 757         --
 758         ppr_item I64  x
 759            | isRelativeReloc x =
 760                 [ptext SLIT("\t.long\t") <> pprImm imm,
 761                  ptext SLIT("\t.long\t0")]
 762            | otherwise =
 763                 [ptext SLIT("\t.quad\t") <> pprImm imm]
 764            where
 765                 isRelativeReloc (CmmLabelOff _ _)       = True
 766                 isRelativeReloc (CmmLabelDiffOff _ _ _) = True
 767                 isRelativeReloc _ = False
 768 #endif
 769 #if powerpc_TARGET_ARCH
 770         ppr_item I16 x = [ptext SLIT("\t.short\t") <> pprImm imm]
 771         ppr_item I64 (CmmInt x _)  =
 772                 [ptext SLIT("\t.long\t")
 773                     <> int (fromIntegral
 774                         (fromIntegral (x `shiftR` 32) :: Word32)),
 775                  ptext SLIT("\t.long\t")
 776                     <> int (fromIntegral (fromIntegral x :: Word32))]
 777 #endif
 778
 779 -- fall through to rest of (machine-specific) pprInstr...
 780
 781 -- -----------------------------------------------------------------------------
 782 -- pprInstr: print an 'Instr'
 783
 784 pprInstr :: Instr -> Doc
 785
 786 --pprInstr (COMMENT s) = empty -- nuke 'em
 787 pprInstr (COMMENT s)
 788    =  IF_ARCH_alpha( ((<>) (ptext SLIT("\t# ")) (ftext s))
 789      ,IF_ARCH_sparc( ((<>) (ptext SLIT("! "))   (ftext s))
 790      ,IF_ARCH_i386( ((<>) (ptext SLIT("# "))   (ftext s))
 791      ,IF_ARCH_x86_64( ((<>) (ptext SLIT("# "))   (ftext s))
 792      ,IF_ARCH_powerpc( IF_OS_linux(
 793         ((<>) (ptext SLIT("# ")) (ftext s)),
 794         ((<>) (ptext SLIT("; ")) (ftext s)))
 795      ,)))))
 796
 797 pprInstr (DELTA d)
 798    = pprInstr (COMMENT (mkFastString ("\tdelta = " ++ show d)))
 799
 800 pprInstr (NEWBLOCK _)
 801    = panic "PprMach.pprInstr: NEWBLOCK"
 802
 803 pprInstr (LDATA _ _)
 804    = panic "PprMach.pprInstr: LDATA"
 805
 806 -- -----------------------------------------------------------------------------
 807 -- pprInstr for an Alpha
 808
 809 #if alpha_TARGET_ARCH
 810
 811 pprInstr (LD size reg addr)
 812   = hcat [
 813         ptext SLIT("\tld"),
 814         pprSize size,
 815         char '\t',
 816         pprReg reg,
 817         comma,
 818         pprAddr addr
 819     ]
 820
 821 pprInstr (LDA reg addr)
 822   = hcat [
 823         ptext SLIT("\tlda\t"),
 824         pprReg reg,
 825         comma,
 826         pprAddr addr
 827     ]
 828
 829 pprInstr (LDAH reg addr)
 830   = hcat [
 831         ptext SLIT("\tldah\t"),
 832         pprReg reg,
 833         comma,
 834         pprAddr addr
 835     ]
 836
 837 pprInstr (LDGP reg addr)
 838   = hcat [
 839         ptext SLIT("\tldgp\t"),
 840         pprReg reg,
 841         comma,
 842         pprAddr addr
 843     ]
 844
 845 pprInstr (LDI size reg imm)
 846   = hcat [
 847         ptext SLIT("\tldi"),
 848         pprSize size,
 849         char '\t',
 850         pprReg reg,
 851         comma,
 852         pprImm imm
 853     ]
 854
 855 pprInstr (ST size reg addr)
 856   = hcat [
 857         ptext SLIT("\tst"),
 858         pprSize size,
 859         char '\t',
 860         pprReg reg,
 861         comma,
 862         pprAddr addr
 863     ]
 864
 865 pprInstr (CLR reg)
 866   = hcat [
 867         ptext SLIT("\tclr\t"),
 868         pprReg reg
 869     ]
 870
 871 pprInstr (ABS size ri reg)
 872   = hcat [
 873         ptext SLIT("\tabs"),
 874         pprSize size,
 875         char '\t',
 876         pprRI ri,
 877         comma,
 878         pprReg reg
 879     ]
 880
 881 pprInstr (NEG size ov ri reg)
 882   = hcat [
 883         ptext SLIT("\tneg"),
 884         pprSize size,
 885         if ov then ptext SLIT("v\t") else char '\t',
 886         pprRI ri,
 887         comma,
 888         pprReg reg
 889     ]
 890
 891 pprInstr (ADD size ov reg1 ri reg2)
 892   = hcat [
 893         ptext SLIT("\tadd"),
 894         pprSize size,
 895         if ov then ptext SLIT("v\t") else char '\t',
 896         pprReg reg1,
 897         comma,
 898         pprRI ri,
 899         comma,
 900         pprReg reg2
 901     ]
 902
 903 pprInstr (SADD size scale reg1 ri reg2)
 904   = hcat [
 905         ptext (case scale of {{-UNUSED:L -> SLIT("\ts4");-} Q -> SLIT("\ts8")}),
 906         ptext SLIT("add"),
 907         pprSize size,
 908         char '\t',
 909         pprReg reg1,
 910         comma,
 911         pprRI ri,
 912         comma,
 913         pprReg reg2
 914     ]
 915
 916 pprInstr (SUB size ov reg1 ri reg2)
 917   = hcat [
 918         ptext SLIT("\tsub"),
 919         pprSize size,
 920         if ov then ptext SLIT("v\t") else char '\t',
 921         pprReg reg1,
 922         comma,
 923         pprRI ri,
 924         comma,
 925         pprReg reg2
 926     ]
 927
 928 pprInstr (SSUB size scale reg1 ri reg2)
 929   = hcat [
 930         ptext (case scale of {{-UNUSED:L -> SLIT("\ts4");-} Q -> SLIT("\ts8")}),
 931         ptext SLIT("sub"),
 932         pprSize size,
 933         char '\t',
 934         pprReg reg1,
 935         comma,
 936         pprRI ri,
 937         comma,
 938         pprReg reg2
 939     ]
 940
 941 pprInstr (MUL size ov reg1 ri reg2)
 942   = hcat [
 943         ptext SLIT("\tmul"),
 944         pprSize size,
 945         if ov then ptext SLIT("v\t") else char '\t',
 946         pprReg reg1,
 947         comma,
 948         pprRI ri,
 949         comma,
 950         pprReg reg2
 951     ]
 952
 953 pprInstr (DIV size uns reg1 ri reg2)
 954   = hcat [
 955         ptext SLIT("\tdiv"),
 956         pprSize size,
 957         if uns then ptext SLIT("u\t") else char '\t',
 958         pprReg reg1,
 959         comma,
 960         pprRI ri,
 961         comma,
 962         pprReg reg2
 963     ]
 964
 965 pprInstr (REM size uns reg1 ri reg2)
 966   = hcat [
 967         ptext SLIT("\trem"),
 968         pprSize size,
 969         if uns then ptext SLIT("u\t") else char '\t',
 970         pprReg reg1,
 971         comma,
 972         pprRI ri,
 973         comma,
 974         pprReg reg2
 975     ]
 976
 977 pprInstr (NOT ri reg)
 978   = hcat [
 979         ptext SLIT("\tnot"),
 980         char '\t',
 981         pprRI ri,
 982         comma,
 983         pprReg reg
 984     ]
 985
 986 pprInstr (AND reg1 ri reg2) = pprRegRIReg SLIT("and") reg1 ri reg2
 987 pprInstr (ANDNOT reg1 ri reg2) = pprRegRIReg SLIT("andnot") reg1 ri reg2
 988 pprInstr (OR reg1 ri reg2) = pprRegRIReg SLIT("or") reg1 ri reg2
 989 pprInstr (ORNOT reg1 ri reg2) = pprRegRIReg SLIT("ornot") reg1 ri reg2
 990 pprInstr (XOR reg1 ri reg2) = pprRegRIReg SLIT("xor") reg1 ri reg2
 991 pprInstr (XORNOT reg1 ri reg2) = pprRegRIReg SLIT("xornot") reg1 ri reg2
 992
 993 pprInstr (SLL reg1 ri reg2) = pprRegRIReg SLIT("sll") reg1 ri reg2
 994 pprInstr (SRL reg1 ri reg2) = pprRegRIReg SLIT("srl") reg1 ri reg2
 995 pprInstr (SRA reg1 ri reg2) = pprRegRIReg SLIT("sra") reg1 ri reg2
 996
 997 pprInstr (ZAP reg1 ri reg2) = pprRegRIReg SLIT("zap") reg1 ri reg2
 998 pprInstr (ZAPNOT reg1 ri reg2) = pprRegRIReg SLIT("zapnot") reg1 ri reg2
 999
1000 pprInstr (NOP) = ptext SLIT("\tnop")
1001
1002 pprInstr (CMP cond reg1 ri reg2)
1003   = hcat [
1004         ptext SLIT("\tcmp"),
1005         pprCond cond,
1006         char '\t',
1007         pprReg reg1,
1008         comma,
1009         pprRI ri,
1010         comma,
1011         pprReg reg2
1012     ]
1013
1014 pprInstr (FCLR reg)
1015   = hcat [
1016         ptext SLIT("\tfclr\t"),
1017         pprReg reg
1018     ]
1019
1020 pprInstr (FABS reg1 reg2)
1021   = hcat [
1022         ptext SLIT("\tfabs\t"),
1023         pprReg reg1,
1024         comma,
1025         pprReg reg2
1026     ]
1027
1028 pprInstr (FNEG size reg1 reg2)
1029   = hcat [
1030         ptext SLIT("\tneg"),
1031         pprSize size,
1032         char '\t',
1033         pprReg reg1,
1034         comma,
1035         pprReg reg2
1036     ]
1037
1038 pprInstr (FADD size reg1 reg2 reg3) = pprSizeRegRegReg SLIT("add") size reg1 reg2 reg3
1039 pprInstr (FDIV size reg1 reg2 reg3) = pprSizeRegRegReg SLIT("div") size reg1 reg2 reg3
1040 pprInstr (FMUL size reg1 reg2 reg3) = pprSizeRegRegReg SLIT("mul") size reg1 reg2 reg3
1041 pprInstr (FSUB size reg1 reg2 reg3) = pprSizeRegRegReg SLIT("sub") size reg1 reg2 reg3
1042
1043 pprInstr (CVTxy size1 size2 reg1 reg2)
1044   = hcat [
1045         ptext SLIT("\tcvt"),
1046         pprSize size1,
1047         case size2 of {Q -> ptext SLIT("qc"); _ -> pprSize size2},
1048         char '\t',
1049         pprReg reg1,
1050         comma,
1051         pprReg reg2
1052     ]
1053
1054 pprInstr (FCMP size cond reg1 reg2 reg3)
1055   = hcat [
1056         ptext SLIT("\tcmp"),
1057         pprSize size,
1058         pprCond cond,
1059         char '\t',
1060         pprReg reg1,
1061         comma,
1062         pprReg reg2,
1063         comma,
1064         pprReg reg3
1065     ]
1066
1067 pprInstr (FMOV reg1 reg2)
1068   = hcat [
1069         ptext SLIT("\tfmov\t"),
1070         pprReg reg1,
1071         comma,
1072         pprReg reg2
1073     ]
1074
1075 pprInstr (BI ALWAYS reg lab) = pprInstr (BR lab)
1076
1077 pprInstr (BI NEVER reg lab) = empty
1078
1079 pprInstr (BI cond reg lab)
1080   = hcat [
1081         ptext SLIT("\tb"),
1082         pprCond cond,
1083         char '\t',
1084         pprReg reg,
1085         comma,
1086         pprImm lab
1087     ]
1088
1089 pprInstr (BF cond reg lab)
1090   = hcat [
1091         ptext SLIT("\tfb"),
1092         pprCond cond,
1093         char '\t',
1094         pprReg reg,
1095         comma,
1096         pprImm lab
1097     ]
1098
1099 pprInstr (BR lab)
1100   = (<>) (ptext SLIT("\tbr\t")) (pprImm lab)
1101
1102 pprInstr (JMP reg addr hint)
1103   = hcat [
1104         ptext SLIT("\tjmp\t"),
1105         pprReg reg,
1106         comma,
1107         pprAddr addr,
1108         comma,
1109         int hint
1110     ]
1111
1112 pprInstr (BSR imm n)
1113   = (<>) (ptext SLIT("\tbsr\t")) (pprImm imm)
1114
1115 pprInstr (JSR reg addr n)
1116   = hcat [
1117         ptext SLIT("\tjsr\t"),
1118         pprReg reg,
1119         comma,
1120         pprAddr addr
1121     ]
1122
1123 pprInstr (FUNBEGIN clab)
1124   = hcat [
1125         if (externallyVisibleCLabel clab) then
1126             hcat [ptext SLIT("\t.globl\t"), pp_lab, char '\n']
1127         else
1128             empty,
1129         ptext SLIT("\t.ent "),
1130         pp_lab,
1131         char '\n',
1132         pp_lab,
1133         pp_ldgp,
1134         pp_lab,
1135         pp_frame
1136     ]
1137     where
1138         pp_lab = pprCLabel_asm clab
1139
1140         -- NEVER use commas within those string literals, cpp will ruin your day
1141         pp_ldgp  = hcat [ ptext SLIT(":\n\tldgp $29"), char ',', ptext SLIT("0($27)\n") ]
1142         pp_frame = hcat [ ptext SLIT("..ng:\n\t.frame $30"), char ',',
1143                           ptext SLIT("4240"), char ',',
1144                           ptext SLIT("$26"), char ',',
1145                           ptext SLIT("0\n\t.prologue 1") ]
1146
1147 pprInstr (FUNEND clab)
1148   = (<>) (ptext SLIT("\t.align 4\n\t.end ")) (pprCLabel_asm clab)
1149 \end{code}
1150
1151 Continue with Alpha-only printing bits and bobs:
1152 \begin{code}
1153 pprRI :: RI -> Doc
1154
1155 pprRI (RIReg r) = pprReg r
1156 pprRI (RIImm r) = pprImm r
1157
1158 pprRegRIReg :: LitString -> Reg -> RI -> Reg -> Doc
1159 pprRegRIReg name reg1 ri reg2
1160   = hcat [
1161         char '\t',
1162         ptext name,
1163         char '\t',
1164         pprReg reg1,
1165         comma,
1166         pprRI ri,
1167         comma,
1168         pprReg reg2
1169     ]
1170
1171 pprSizeRegRegReg :: LitString -> Size -> Reg -> Reg -> Reg -> Doc
1172 pprSizeRegRegReg name size reg1 reg2 reg3
1173   = hcat [
1174         char '\t',
1175         ptext name,
1176         pprSize size,
1177         char '\t',
1178         pprReg reg1,
1179         comma,
1180         pprReg reg2,
1181         comma,
1182         pprReg reg3
1183     ]
1184
1185 #endif /* alpha_TARGET_ARCH */
1186
1187
1188 -- -----------------------------------------------------------------------------
1189 -- pprInstr for an x86
1190
1191 #if i386_TARGET_ARCH || x86_64_TARGET_ARCH
1192
1193 pprInstr v@(MOV size s@(OpReg src) d@(OpReg dst)) -- hack
1194   | src == dst
1195   =
1196 #if 0 /* #ifdef DEBUG */
1197     (<>) (ptext SLIT("# warning: ")) (pprSizeOpOp SLIT("mov") size s d)
1198 #else
1199     empty
1200 #endif
1201
1202 pprInstr (MOV size src dst)
1203   = pprSizeOpOp SLIT("mov") size src dst
1204
1205 pprInstr (MOVZxL I32 src dst) = pprSizeOpOp SLIT("mov") I32 src dst
1206         -- 32-to-64 bit zero extension on x86_64 is accomplished by a simple
1207         -- movl.  But we represent it as a MOVZxL instruction, because
1208         -- the reg alloc would tend to throw away a plain reg-to-reg
1209         -- move, and we still want it to do that.
1210
1211 pprInstr (MOVZxL sizes src dst) = pprSizeOpOpCoerce SLIT("movz") sizes I32 src dst
1212         -- zero-extension only needs to extend to 32 bits: on x86_64,
1213         -- the remaining zero-extension to 64 bits is automatic, and the 32-bit
1214         -- instruction is shorter.
1215
1216 pprInstr (MOVSxL sizes src dst) = pprSizeOpOpCoerce SLIT("movs") sizes wordRep src dst
1217
1218 -- here we do some patching, since the physical registers are only set late
1219 -- in the code generation.
1220 pprInstr (LEA size (OpAddr (AddrBaseIndex src1@(EABaseReg reg1) (EAIndex reg2 1) (ImmInt 0))) dst@(OpReg reg3))
1221   | reg1 == reg3
1222   = pprSizeOpOp SLIT("add") size (OpReg reg2) dst
1223 pprInstr (LEA size (OpAddr (AddrBaseIndex src1@(EABaseReg reg1) (EAIndex reg2 1) (ImmInt 0))) dst@(OpReg reg3))
1224   | reg2 == reg3
1225   = pprSizeOpOp SLIT("add") size (OpReg reg1) dst
1226 pprInstr (LEA size (OpAddr (AddrBaseIndex src1@(EABaseReg reg1) EAIndexNone displ)) dst@(OpReg reg3))
1227   | reg1 == reg3
1228   = pprInstr (ADD size (OpImm displ) dst)
1229 pprInstr (LEA size src dst) = pprSizeOpOp SLIT("lea") size src dst
1230
1231 pprInstr (ADD size (OpImm (ImmInt (-1))) dst)
1232   = pprSizeOp SLIT("dec") size dst
1233 pprInstr (ADD size (OpImm (ImmInt 1)) dst)
1234   = pprSizeOp SLIT("inc") size dst
1235 pprInstr (ADD size src dst)
1236   = pprSizeOpOp SLIT("add") size src dst
1237 pprInstr (ADC size src dst)
1238   = pprSizeOpOp SLIT("adc") size src dst
1239 pprInstr (SUB size src dst) = pprSizeOpOp SLIT("sub") size src dst
1240 pprInstr (IMUL size op1 op2) = pprSizeOpOp SLIT("imul") size op1 op2
1241
1242 {- A hack.  The Intel documentation says that "The two and three
1243    operand forms [of IMUL] may also be used with unsigned operands
1244    because the lower half of the product is the same regardless if
1245    (sic) the operands are signed or unsigned.  The CF and OF flags,
1246    however, cannot be used to determine if the upper half of the
1247    result is non-zero."  So there.
1248 -}
1249 pprInstr (AND size src dst) = pprSizeOpOp SLIT("and") size src dst
1250 pprInstr (OR  size src dst) = pprSizeOpOp SLIT("or")  size src dst
1251
1252 pprInstr (XOR F32 src dst)  = pprOpOp SLIT("xorps") F32 src dst
1253 pprInstr (XOR F64 src dst)  = pprOpOp SLIT("xorpd") F64 src dst
1254 pprInstr (XOR size src dst) = pprSizeOpOp SLIT("xor")  size src dst
1255
1256 pprInstr (NOT size op) = pprSizeOp SLIT("not") size op
1257 pprInstr (NEGI size op) = pprSizeOp SLIT("neg") size op
1258
1259 pprInstr (SHL size src dst) = pprShift SLIT("shl") size src dst
1260 pprInstr (SAR size src dst) = pprShift SLIT("sar") size src dst
1261 pprInstr (SHR size src dst) = pprShift SLIT("shr") size src dst
1262
1263 pprInstr (BT  size imm src) = pprSizeImmOp SLIT("bt") size imm src
1264
1265 pprInstr (CMP size src dst)
1266   | isFloatingRep size =  pprSizeOpOp SLIT("ucomi")  size src dst -- SSE2
1267   | otherwise          =  pprSizeOpOp SLIT("cmp")  size src dst
1268
1269 pprInstr (TEST size src dst) = pprSizeOpOp SLIT("test")  size src dst
1270 pprInstr (PUSH size op) = pprSizeOp SLIT("push") size op
1271 pprInstr (POP size op) = pprSizeOp SLIT("pop") size op
1272
1273 -- both unused (SDM):
1274 -- pprInstr PUSHA = ptext SLIT("\tpushal")
1275 -- pprInstr POPA = ptext SLIT("\tpopal")
1276
1277 pprInstr NOP = ptext SLIT("\tnop")
1278 pprInstr (CLTD I32) = ptext SLIT("\tcltd")
1279 pprInstr (CLTD I64) = ptext SLIT("\tcqto")
1280
1281 pprInstr (SETCC cond op) = pprCondInstr SLIT("set") cond (pprOperand I8 op)
1282
1283 pprInstr (JXX cond (BlockId id))
1284   = pprCondInstr SLIT("j") cond (pprCLabel_asm lab)
1285   where lab = mkAsmTempLabel id
1286
1287 pprInstr (JMP (OpImm imm)) = (<>) (ptext SLIT("\tjmp ")) (pprImm imm)
1288 pprInstr (JMP op)          = (<>) (ptext SLIT("\tjmp *")) (pprOperand wordRep op)
1289 pprInstr (JMP_TBL op ids)  = pprInstr (JMP op)
1290 pprInstr (CALL (Left imm) _)    = (<>) (ptext SLIT("\tcall ")) (pprImm imm)
1291 pprInstr (CALL (Right reg) _)   = (<>) (ptext SLIT("\tcall *")) (pprReg wordRep reg)
1292
1293 pprInstr (IDIV sz op)   = pprSizeOp SLIT("idiv") sz op
1294 pprInstr (DIV sz op)    = pprSizeOp SLIT("div")  sz op
1295 pprInstr (IMUL2 sz op)  = pprSizeOp SLIT("imul") sz op
1296
1297 #if x86_64_TARGET_ARCH
1298 pprInstr (MUL size op1 op2) = pprSizeOpOp SLIT("mul") size op1 op2
1299
1300 pprInstr (FDIV size op1 op2) = pprSizeOpOp SLIT("div") size op1 op2
1301
1302 pprInstr (CVTSS2SD from to) = pprRegReg SLIT("cvtss2sd") from to
1303 pprInstr (CVTSD2SS from to) = pprRegReg SLIT("cvtsd2ss") from to
1304 pprInstr (CVTSS2SI from to) = pprOpReg  SLIT("cvtss2si") from to
1305 pprInstr (CVTSD2SI from to) = pprOpReg  SLIT("cvtsd2si") from to
1306 pprInstr (CVTSI2SS from to) = pprOpReg  SLIT("cvtsi2ss") from to
1307 pprInstr (CVTSI2SD from to) = pprOpReg  SLIT("cvtsi2sd") from to
1308 #endif
1309
1310     -- FETCHGOT for PIC on ELF platforms
1311 pprInstr (FETCHGOT reg)
1312    = vcat [ ptext SLIT("\tcall 1f"),
1313             hcat [ ptext SLIT("1:\tpopl\t"), pprReg I32 reg ],
1314             hcat [ ptext SLIT("\taddl\t$_GLOBAL_OFFSET_TABLE_+(.-1b), "),
1315                    pprReg I32 reg ]
1316           ]
1317
1318     -- FETCHPC for PIC on Darwin/x86
1319     -- get the instruction pointer into a register
1320     -- (Terminology note: the IP is called Program Counter on PPC,
1321     --  and it's a good thing to use the same name on both platforms)
1322 pprInstr (FETCHPC reg)
1323    = vcat [ ptext SLIT("\tcall 1f"),
1324             hcat [ ptext SLIT("1:\tpopl\t"), pprReg I32 reg ]
1325           ]
1326
1327
1328
1329 #endif
1330
1331 -- -----------------------------------------------------------------------------
1332 -- i386 floating-point
1333
1334 #if i386_TARGET_ARCH
1335 -- Simulating a flat register set on the x86 FP stack is tricky.
1336 -- you have to free %st(7) before pushing anything on the FP reg stack
1337 -- so as to preclude the possibility of a FP stack overflow exception.
1338 pprInstr g@(GMOV src dst)
1339    | src == dst
1340    = empty
1341    | otherwise
1342    = pprG g (hcat [gtab, gpush src 0, gsemi, gpop dst 1])
1343
1344 -- GLD sz addr dst ==> FFREE %st(7) ; FLDsz addr ; FSTP (dst+1)
1345 pprInstr g@(GLD sz addr dst)
1346  = pprG g (hcat [gtab, text "ffree %st(7) ; fld", pprSize sz, gsp,
1347                  pprAddr addr, gsemi, gpop dst 1])
1348
1349 -- GST sz src addr ==> FFREE %st(7) ; FLD dst ; FSTPsz addr
1350 pprInstr g@(GST sz src addr)
1351  = pprG g (hcat [gtab, gpush src 0, gsemi,
1352                  text "fstp", pprSize sz, gsp, pprAddr addr])
1353
1354 pprInstr g@(GLDZ dst)
1355  = pprG g (hcat [gtab, text "ffree %st(7) ; fldz ; ", gpop dst 1])
1356 pprInstr g@(GLD1 dst)
1357  = pprG g (hcat [gtab, text "ffree %st(7) ; fld1 ; ", gpop dst 1])
1358
1359 pprInstr g@(GFTOI src dst)
1360    = pprInstr (GDTOI src dst)
1361 pprInstr g@(GDTOI src dst)
1362    = pprG g (hcat [gtab, text "subl $4, %esp ; ",
1363                    gpush src 0, gsemi, text "fistpl 0(%esp) ; popl ",
1364                    pprReg I32 dst])
1365
1366 pprInstr g@(GITOF src dst)
1367    = pprInstr (GITOD src dst)
1368 pprInstr g@(GITOD src dst)
1369    = pprG g (hcat [gtab, text "pushl ", pprReg I32 src,
1370                    text " ; ffree %st(7); fildl (%esp) ; ",
1371                    gpop dst 1, text " ; addl $4,%esp"])
1372
1373 {- Gruesome swamp follows.  If you're unfortunate enough to have ventured
1374    this far into the jungle AND you give a Rat's Ass (tm) what's going
1375    on, here's the deal.  Generate code to do a floating point comparison
1376    of src1 and src2, of kind cond, and set the Zero flag if true.
1377
1378    The complications are to do with handling NaNs correctly.  We want the
1379    property that if either argument is NaN, then the result of the
1380    comparison is False ... except if we're comparing for inequality,
1381    in which case the answer is True.
1382
1383    Here's how the general (non-inequality) case works.  As an
1384    example, consider generating the an equality test:
1385
1386      pushl %eax         -- we need to mess with this
1387      <get src1 to top of FPU stack>
1388      fcomp <src2 location in FPU stack> and pop pushed src1
1389                 -- Result of comparison is in FPU Status Register bits
1390                 -- C3 C2 and C0
1391      fstsw %ax  -- Move FPU Status Reg to %ax
1392      sahf       -- move C3 C2 C0 from %ax to integer flag reg
1393      -- now the serious magic begins
1394      setpo %ah     -- %ah = if comparable(neither arg was NaN) then 1 else 0
1395      sete  %al     -- %al = if arg1 == arg2 then 1 else 0
1396      andb %ah,%al  -- %al &= %ah
1397                    -- so %al == 1 iff (comparable && same); else it holds 0
1398      decb %al      -- %al == 0, ZeroFlag=1  iff (comparable && same);
1399                       else %al == 0xFF, ZeroFlag=0
1400      -- the zero flag is now set as we desire.
1401      popl %eax
1402
1403    The special case of inequality differs thusly:
1404
1405      setpe %ah     -- %ah = if incomparable(either arg was NaN) then 1 else 0
1406      setne %al     -- %al = if arg1 /= arg2 then 1 else 0
1407      orb %ah,%al   -- %al = if (incomparable || different) then 1 else 0
1408      decb %al      -- if (incomparable || different) then (%al == 0, ZF=1)
1409                                                      else (%al == 0xFF, ZF=0)
1410 -}
1411 pprInstr g@(GCMP cond src1 src2)
1412    | case cond of { NE -> True; other -> False }
1413    = pprG g (vcat [
1414         hcat [gtab, text "pushl %eax ; ",gpush src1 0],
1415         hcat [gtab, text "fcomp ", greg src2 1,
1416                     text "; fstsw %ax ; sahf ;  setpe %ah"],
1417         hcat [gtab, text "setne %al ;  ",
1418               text "orb %ah,%al ;  decb %al ;  popl %eax"]
1419     ])
1420    | otherwise
1421    = pprG g (vcat [
1422         hcat [gtab, text "pushl %eax ; ",gpush src1 0],
1423         hcat [gtab, text "fcomp ", greg src2 1,
1424                     text "; fstsw %ax ; sahf ;  setpo %ah"],
1425         hcat [gtab, text "set", pprCond (fix_FP_cond cond), text " %al ;  ",
1426               text "andb %ah,%al ;  decb %al ;  popl %eax"]
1427     ])
1428     where
1429         {- On the 486, the flags set by FP compare are the unsigned ones!
1430            (This looks like a HACK to me.  WDP 96/03)
1431         -}
1432         fix_FP_cond :: Cond -> Cond
1433         fix_FP_cond GE   = GEU
1434         fix_FP_cond GTT  = GU
1435         fix_FP_cond LTT  = LU
1436         fix_FP_cond LE   = LEU
1437         fix_FP_cond EQQ  = EQQ
1438         fix_FP_cond NE   = NE
1439         -- there should be no others
1440
1441
1442 pprInstr g@(GABS sz src dst)
1443    = pprG g (hcat [gtab, gpush src 0, text " ; fabs ; ", gpop dst 1])
1444 pprInstr g@(GNEG sz src dst)
1445    = pprG g (hcat [gtab, gpush src 0, text " ; fchs ; ", gpop dst 1])
1446
1447 pprInstr g@(GSQRT sz src dst)
1448    = pprG g (hcat [gtab, gpush src 0, text " ; fsqrt"] $$
1449              hcat [gtab, gcoerceto sz, gpop dst 1])
1450 pprInstr g@(GSIN sz src dst)
1451    = pprG g (hcat [gtab, gpush src 0, text " ; fsin"] $$
1452              hcat [gtab, gcoerceto sz, gpop dst 1])
1453 pprInstr g@(GCOS sz src dst)
1454    = pprG g (hcat [gtab, gpush src 0, text " ; fcos"] $$
1455              hcat [gtab, gcoerceto sz, gpop dst 1])
1456 pprInstr g@(GTAN sz src dst)
1457    = pprG g (hcat [gtab, text "ffree %st(6) ; ",
1458                    gpush src 0, text " ; fptan ; ",
1459                    text " fstp %st(0)"] $$
1460              hcat [gtab, gcoerceto sz, gpop dst 1])
1461
1462 -- In the translations for GADD, GMUL, GSUB and GDIV,
1463 -- the first two cases are mere optimisations.  The otherwise clause
1464 -- generates correct code under all circumstances.
1465
1466 pprInstr g@(GADD sz src1 src2 dst)
1467    | src1 == dst
1468    = pprG g (text "\t#GADD-xxxcase1" $$
1469              hcat [gtab, gpush src2 0,
1470                    text " ; faddp %st(0),", greg src1 1])
1471    | src2 == dst
1472    = pprG g (text "\t#GADD-xxxcase2" $$
1473              hcat [gtab, gpush src1 0,
1474                    text " ; faddp %st(0),", greg src2 1])
1475    | otherwise
1476    = pprG g (hcat [gtab, gpush src1 0,
1477                    text " ; fadd ", greg src2 1, text ",%st(0)",
1478                    gsemi, gpop dst 1])
1479
1480
1481 pprInstr g@(GMUL sz src1 src2 dst)
1482    | src1 == dst
1483    = pprG g (text "\t#GMUL-xxxcase1" $$
1484              hcat [gtab, gpush src2 0,
1485                    text " ; fmulp %st(0),", greg src1 1])
1486    | src2 == dst
1487    = pprG g (text "\t#GMUL-xxxcase2" $$
1488              hcat [gtab, gpush src1 0,
1489                    text " ; fmulp %st(0),", greg src2 1])
1490    | otherwise
1491    = pprG g (hcat [gtab, gpush src1 0,
1492                    text " ; fmul ", greg src2 1, text ",%st(0)",
1493                    gsemi, gpop dst 1])
1494
1495
1496 pprInstr g@(GSUB sz src1 src2 dst)
1497    | src1 == dst
1498    = pprG g (text "\t#GSUB-xxxcase1" $$
1499              hcat [gtab, gpush src2 0,
1500                    text " ; fsubrp %st(0),", greg src1 1])
1501    | src2 == dst
1502    = pprG g (text "\t#GSUB-xxxcase2" $$
1503              hcat [gtab, gpush src1 0,
1504                    text " ; fsubp %st(0),", greg src2 1])
1505    | otherwise
1506    = pprG g (hcat [gtab, gpush src1 0,
1507                    text " ; fsub ", greg src2 1, text ",%st(0)",
1508                    gsemi, gpop dst 1])
1509
1510
1511 pprInstr g@(GDIV sz src1 src2 dst)
1512    | src1 == dst
1513    = pprG g (text "\t#GDIV-xxxcase1" $$
1514              hcat [gtab, gpush src2 0,
1515                    text " ; fdivrp %st(0),", greg src1 1])
1516    | src2 == dst
1517    = pprG g (text "\t#GDIV-xxxcase2" $$
1518              hcat [gtab, gpush src1 0,
1519                    text " ; fdivp %st(0),", greg src2 1])
1520    | otherwise
1521    = pprG g (hcat [gtab, gpush src1 0,
1522                    text " ; fdiv ", greg src2 1, text ",%st(0)",
1523                    gsemi, gpop dst 1])
1524
1525
1526 pprInstr GFREE
1527    = vcat [ ptext SLIT("\tffree %st(0) ;ffree %st(1) ;ffree %st(2) ;ffree %st(3)"),
1528             ptext SLIT("\tffree %st(4) ;ffree %st(5) ;ffree %st(6) ;ffree %st(7)")
1529           ]
1530
1531 --------------------------
1532
1533 -- coerce %st(0) to the specified size
1534 gcoerceto F64 = empty
1535 gcoerceto F32 = empty --text "subl $4,%esp ; fstps (%esp) ; flds (%esp) ; addl $4,%esp ; "
1536
1537 gpush reg offset
1538    = hcat [text "ffree %st(7) ; fld ", greg reg offset]
1539 gpop reg offset
1540    = hcat [text "fstp ", greg reg offset]
1541
1542 greg reg offset = text "%st(" <> int (gregno reg - 8+offset) <> char ')'
1543 gsemi = text " ; "
1544 gtab  = char '\t'
1545 gsp   = char ' '
1546
1547 gregno (RealReg i) = i
1548 gregno other       = --pprPanic "gregno" (ppr other)
1549                      999   -- bogus; only needed for debug printing
1550
1551 pprG :: Instr -> Doc -> Doc
1552 pprG fake actual
1553    = (char '#' <> pprGInstr fake) $$ actual
1554
1555 pprGInstr (GMOV src dst)   = pprSizeRegReg SLIT("gmov") F64 src dst
1556 pprGInstr (GLD sz src dst) = pprSizeAddrReg SLIT("gld") sz src dst
1557 pprGInstr (GST sz src dst) = pprSizeRegAddr SLIT("gst") sz src dst
1558
1559 pprGInstr (GLDZ dst) = pprSizeReg SLIT("gldz") F64 dst
1560 pprGInstr (GLD1 dst) = pprSizeReg SLIT("gld1") F64 dst
1561
1562 pprGInstr (GFTOI src dst) = pprSizeSizeRegReg SLIT("gftoi") F32 I32  src dst
1563 pprGInstr (GDTOI src dst) = pprSizeSizeRegReg SLIT("gdtoi") F64 I32 src dst
1564
1565 pprGInstr (GITOF src dst) = pprSizeSizeRegReg SLIT("gitof") I32 F32  src dst
1566 pprGInstr (GITOD src dst) = pprSizeSizeRegReg SLIT("gitod") I32 F64 src dst
1567
1568 pprGInstr (GCMP co src dst) = pprCondRegReg SLIT("gcmp_") F64 co src dst
1569 pprGInstr (GABS sz src dst) = pprSizeRegReg SLIT("gabs") sz src dst
1570 pprGInstr (GNEG sz src dst) = pprSizeRegReg SLIT("gneg") sz src dst
1571 pprGInstr (GSQRT sz src dst) = pprSizeRegReg SLIT("gsqrt") sz src dst
1572 pprGInstr (GSIN sz src dst) = pprSizeRegReg SLIT("gsin") sz src dst
1573 pprGInstr (GCOS sz src dst) = pprSizeRegReg SLIT("gcos") sz src dst
1574 pprGInstr (GTAN sz src dst) = pprSizeRegReg SLIT("gtan") sz src dst
1575
1576 pprGInstr (GADD sz src1 src2 dst) = pprSizeRegRegReg SLIT("gadd") sz src1 src2 dst
1577 pprGInstr (GSUB sz src1 src2 dst) = pprSizeRegRegReg SLIT("gsub") sz src1 src2 dst
1578 pprGInstr (GMUL sz src1 src2 dst) = pprSizeRegRegReg SLIT("gmul") sz src1 src2 dst
1579 pprGInstr (GDIV sz src1 src2 dst) = pprSizeRegRegReg SLIT("gdiv") sz src1 src2 dst
1580 #endif
1581
1582 #if i386_TARGET_ARCH || x86_64_TARGET_ARCH
1583
1584 -- Continue with I386-only printing bits and bobs:
1585
1586 pprDollImm :: Imm -> Doc
1587
1588 pprDollImm i =  ptext SLIT("$") <> pprImm i
1589
1590 pprOperand :: MachRep -> Operand -> Doc
1591 pprOperand s (OpReg r)   = pprReg s r
1592 pprOperand s (OpImm i)   = pprDollImm i
1593 pprOperand s (OpAddr ea) = pprAddr ea
1594
1595 pprMnemonic_  :: LitString -> Doc
1596 pprMnemonic_ name =
1597    char '\t' <> ptext name <> space
1598
1599 pprMnemonic  :: LitString -> MachRep -> Doc
1600 pprMnemonic name size =
1601    char '\t' <> ptext name <> pprSize size <> space
1602
1603 pprSizeImmOp :: LitString -> MachRep -> Imm -> Operand -> Doc
1604 pprSizeImmOp name size imm op1
1605   = hcat [
1606         pprMnemonic name size,
1607         char '$',
1608         pprImm imm,
1609         comma,
1610         pprOperand size op1
1611     ]
1612
1613 pprSizeOp :: LitString -> MachRep -> Operand -> Doc
1614 pprSizeOp name size op1
1615   = hcat [
1616         pprMnemonic name size,
1617         pprOperand size op1
1618     ]
1619
1620 pprSizeOpOp :: LitString -> MachRep -> Operand -> Operand -> Doc
1621 pprSizeOpOp name size op1 op2
1622   = hcat [
1623         pprMnemonic name size,
1624         pprOperand size op1,
1625         comma,
1626         pprOperand size op2
1627     ]
1628
1629 pprOpOp :: LitString -> MachRep -> Operand -> Operand -> Doc
1630 pprOpOp name size op1 op2
1631   = hcat [
1632         pprMnemonic_ name,
1633         pprOperand size op1,
1634         comma,
1635         pprOperand size op2
1636     ]
1637
1638 pprSizeReg :: LitString -> MachRep -> Reg -> Doc
1639 pprSizeReg name size reg1
1640   = hcat [
1641         pprMnemonic name size,
1642         pprReg size reg1
1643     ]
1644
1645 pprSizeRegReg :: LitString -> MachRep -> Reg -> Reg -> Doc
1646 pprSizeRegReg name size reg1 reg2
1647   = hcat [
1648         pprMnemonic name size,
1649         pprReg size reg1,
1650         comma,
1651         pprReg size reg2
1652     ]
1653
1654 pprRegReg :: LitString -> Reg -> Reg -> Doc
1655 pprRegReg name reg1 reg2
1656   = hcat [
1657         pprMnemonic_ name,
1658         pprReg wordRep reg1,
1659         comma,
1660         pprReg wordRep reg2
1661     ]
1662
1663 pprOpReg :: LitString -> Operand -> Reg -> Doc
1664 pprOpReg name op1 reg2
1665   = hcat [
1666         pprMnemonic_ name,
1667         pprOperand wordRep op1,
1668         comma,
1669         pprReg wordRep reg2
1670     ]
1671
1672 pprCondRegReg :: LitString -> MachRep -> Cond -> Reg -> Reg -> Doc
1673 pprCondRegReg name size cond reg1 reg2
1674   = hcat [
1675         char '\t',
1676         ptext name,
1677         pprCond cond,
1678         space,
1679         pprReg size reg1,
1680         comma,
1681         pprReg size reg2
1682     ]
1683
1684 pprSizeSizeRegReg :: LitString -> MachRep -> MachRep -> Reg -> Reg -> Doc
1685 pprSizeSizeRegReg name size1 size2 reg1 reg2
1686   = hcat [
1687         char '\t',
1688         ptext name,
1689         pprSize size1,
1690         pprSize size2,
1691         space,
1692         pprReg size1 reg1,
1693
1694         comma,
1695         pprReg size2 reg2
1696     ]
1697
1698 pprSizeRegRegReg :: LitString -> MachRep -> Reg -> Reg -> Reg -> Doc
1699 pprSizeRegRegReg name size reg1 reg2 reg3
1700   = hcat [
1701         pprMnemonic name size,
1702         pprReg size reg1,
1703         comma,
1704         pprReg size reg2,
1705         comma,
1706         pprReg size reg3
1707     ]
1708
1709 pprSizeAddrReg :: LitString -> MachRep -> AddrMode -> Reg -> Doc
1710 pprSizeAddrReg name size op dst
1711   = hcat [
1712         pprMnemonic name size,
1713         pprAddr op,
1714         comma,
1715         pprReg size dst
1716     ]
1717
1718 pprSizeRegAddr :: LitString -> MachRep -> Reg -> AddrMode -> Doc
1719 pprSizeRegAddr name size src op
1720   = hcat [
1721         pprMnemonic name size,
1722         pprReg size src,
1723         comma,
1724         pprAddr op
1725     ]
1726
1727 pprShift :: LitString -> MachRep -> Operand -> Operand -> Doc
1728 pprShift name size src dest
1729   = hcat [
1730         pprMnemonic name size,
1731         pprOperand I8 src,  -- src is 8-bit sized
1732         comma,
1733         pprOperand size dest
1734     ]
1735
1736 pprSizeOpOpCoerce :: LitString -> MachRep -> MachRep -> Operand -> Operand -> Doc
1737 pprSizeOpOpCoerce name size1 size2 op1 op2
1738   = hcat [ char '\t', ptext name, pprSize size1, pprSize size2, space,
1739         pprOperand size1 op1,
1740         comma,
1741         pprOperand size2 op2
1742     ]
1743
1744 pprCondInstr :: LitString -> Cond -> Doc -> Doc
1745 pprCondInstr name cond arg
1746   = hcat [ char '\t', ptext name, pprCond cond, space, arg]
1747
1748 #endif /* i386_TARGET_ARCH */
1749
1750
1751 -- ------------------------------------------------------------------------------- pprInstr for a SPARC
1752
1753 #if sparc_TARGET_ARCH
1754
1755 -- a clumsy hack for now, to handle possible double alignment problems
1756
1757 -- even clumsier, to allow for RegReg regs that show when doing indexed
1758 -- reads (bytearrays).
1759 --
1760
1761 -- Translate to the following:
1762 --    add g1,g2,g1
1763 --    ld  [g1],%fn
1764 --    ld  [g1+4],%f(n+1)
1765 --    sub g1,g2,g1           -- to restore g1
1766
1767 pprInstr (LD F64 (AddrRegReg g1 g2) reg)
1768   = vcat [
1769        hcat [ptext SLIT("\tadd\t"), pprReg g1,comma,pprReg g2,comma,pprReg g1],
1770        hcat [pp_ld_lbracket, pprReg g1, pp_rbracket_comma, pprReg reg],
1771        hcat [pp_ld_lbracket, pprReg g1, ptext SLIT("+4]"), comma, pprReg (fPair reg)],
1772        hcat [ptext SLIT("\tsub\t"), pprReg g1,comma,pprReg g2,comma,pprReg g1]
1773     ]
1774
1775 -- Translate to
1776 --    ld  [addr],%fn
1777 --    ld  [addr+4],%f(n+1)
1778 pprInstr (LD F64 addr reg) | isJust off_addr
1779   = vcat [
1780        hcat [pp_ld_lbracket, pprAddr addr, pp_rbracket_comma, pprReg reg],
1781        hcat [pp_ld_lbracket, pprAddr addr2, pp_rbracket_comma,pprReg (fPair reg)]
1782     ]
1783   where
1784     off_addr = addrOffset addr 4
1785     addr2 = case off_addr of Just x -> x
1786
1787
1788 pprInstr (LD size addr reg)
1789   = hcat [
1790        ptext SLIT("\tld"),
1791        pprSize size,
1792        char '\t',
1793        lbrack,
1794        pprAddr addr,
1795        pp_rbracket_comma,
1796        pprReg reg
1797     ]
1798
1799 -- The same clumsy hack as above
1800
1801 -- Translate to the following:
1802 --    add g1,g2,g1
1803 --    st  %fn,[g1]
1804 --    st  %f(n+1),[g1+4]
1805 --    sub g1,g2,g1           -- to restore g1
1806 pprInstr (ST F64 reg (AddrRegReg g1 g2))
1807  = vcat [
1808        hcat [ptext SLIT("\tadd\t"), pprReg g1,comma,pprReg g2,comma,pprReg g1],
1809        hcat [ptext SLIT("\tst\t"), pprReg reg, pp_comma_lbracket,
1810              pprReg g1, rbrack],
1811        hcat [ptext SLIT("\tst\t"), pprReg (fPair reg), pp_comma_lbracket,
1812              pprReg g1, ptext SLIT("+4]")],
1813        hcat [ptext SLIT("\tsub\t"), pprReg g1,comma,pprReg g2,comma,pprReg g1]
1814     ]
1815
1816 -- Translate to
1817 --    st  %fn,[addr]
1818 --    st  %f(n+1),[addr+4]
1819 pprInstr (ST F64 reg addr) | isJust off_addr
1820  = vcat [
1821       hcat [ptext SLIT("\tst\t"), pprReg reg, pp_comma_lbracket,
1822             pprAddr addr, rbrack],
1823       hcat [ptext SLIT("\tst\t"), pprReg (fPair reg), pp_comma_lbracket,
1824             pprAddr addr2, rbrack]
1825     ]
1826   where
1827     off_addr = addrOffset addr 4
1828     addr2 = case off_addr of Just x -> x
1829
1830 -- no distinction is made between signed and unsigned bytes on stores for the
1831 -- Sparc opcodes (at least I cannot see any, and gas is nagging me --SOF),
1832 -- so we call a special-purpose pprSize for ST..
1833
1834 pprInstr (ST size reg addr)
1835   = hcat [
1836        ptext SLIT("\tst"),
1837        pprStSize size,
1838        char '\t',
1839        pprReg reg,
1840        pp_comma_lbracket,
1841        pprAddr addr,
1842        rbrack
1843     ]
1844
1845 pprInstr (ADD x cc reg1 ri reg2)
1846   | not x && not cc && riZero ri
1847   = hcat [ ptext SLIT("\tmov\t"), pprReg reg1, comma, pprReg reg2 ]
1848   | otherwise
1849   = pprRegRIReg (if x then SLIT("addx") else SLIT("add")) cc reg1 ri reg2
1850
1851 pprInstr (SUB x cc reg1 ri reg2)
1852   | not x && cc && reg2 == g0
1853   = hcat [ ptext SLIT("\tcmp\t"), pprReg reg1, comma, pprRI ri ]
1854   | not x && not cc && riZero ri
1855   = hcat [ ptext SLIT("\tmov\t"), pprReg reg1, comma, pprReg reg2 ]
1856   | otherwise
1857   = pprRegRIReg (if x then SLIT("subx") else SLIT("sub")) cc reg1 ri reg2
1858
1859 pprInstr (AND  b reg1 ri reg2) = pprRegRIReg SLIT("and")  b reg1 ri reg2
1860 pprInstr (ANDN b reg1 ri reg2) = pprRegRIReg SLIT("andn") b reg1 ri reg2
1861
1862 pprInstr (OR b reg1 ri reg2)
1863   | not b && reg1 == g0
1864   = let doit = hcat [ ptext SLIT("\tmov\t"), pprRI ri, comma, pprReg reg2 ]
1865     in  case ri of
1866            RIReg rrr | rrr == reg2 -> empty
1867            other                   -> doit
1868   | otherwise
1869   = pprRegRIReg SLIT("or") b reg1 ri reg2
1870
1871 pprInstr (ORN b reg1 ri reg2) = pprRegRIReg SLIT("orn") b reg1 ri reg2
1872
1873 pprInstr (XOR  b reg1 ri reg2) = pprRegRIReg SLIT("xor")  b reg1 ri reg2
1874 pprInstr (XNOR b reg1 ri reg2) = pprRegRIReg SLIT("xnor") b reg1 ri reg2
1875
1876 pprInstr (SLL reg1 ri reg2) = pprRegRIReg SLIT("sll") False reg1 ri reg2
1877 pprInstr (SRL reg1 ri reg2) = pprRegRIReg SLIT("srl") False reg1 ri reg2
1878 pprInstr (SRA reg1 ri reg2) = pprRegRIReg SLIT("sra") False reg1 ri reg2
1879
1880 pprInstr (RDY rd) = ptext SLIT("\trd\t%y,") <> pprReg rd
1881 pprInstr (SMUL b reg1 ri reg2) = pprRegRIReg SLIT("smul")  b reg1 ri reg2
1882 pprInstr (UMUL b reg1 ri reg2) = pprRegRIReg SLIT("umul")  b reg1 ri reg2
1883
1884 pprInstr (SETHI imm reg)
1885   = hcat [
1886         ptext SLIT("\tsethi\t"),
1887         pprImm imm,
1888         comma,
1889         pprReg reg
1890     ]
1891
1892 pprInstr NOP = ptext SLIT("\tnop")
1893
1894 pprInstr (FABS F32 reg1 reg2) = pprSizeRegReg SLIT("fabs") F32 reg1 reg2
1895 pprInstr (FABS F64 reg1 reg2)
1896   = (<>) (pprSizeRegReg SLIT("fabs") F32 reg1 reg2)
1897     (if (reg1 == reg2) then empty
1898      else (<>) (char '\n')
1899           (pprSizeRegReg SLIT("fmov") F32 (fPair reg1) (fPair reg2)))
1900
1901 pprInstr (FADD size reg1 reg2 reg3)
1902   = pprSizeRegRegReg SLIT("fadd") size reg1 reg2 reg3
1903 pprInstr (FCMP e size reg1 reg2)
1904   = pprSizeRegReg (if e then SLIT("fcmpe") else SLIT("fcmp")) size reg1 reg2
1905 pprInstr (FDIV size reg1 reg2 reg3)
1906   = pprSizeRegRegReg SLIT("fdiv") size reg1 reg2 reg3
1907
1908 pprInstr (FMOV F32 reg1 reg2) = pprSizeRegReg SLIT("fmov") F32 reg1 reg2
1909 pprInstr (FMOV F64 reg1 reg2)
1910   = (<>) (pprSizeRegReg SLIT("fmov") F32 reg1 reg2)
1911     (if (reg1 == reg2) then empty
1912      else (<>) (char '\n')
1913           (pprSizeRegReg SLIT("fmov") F32 (fPair reg1) (fPair reg2)))
1914
1915 pprInstr (FMUL size reg1 reg2 reg3)
1916   = pprSizeRegRegReg SLIT("fmul") size reg1 reg2 reg3
1917
1918 pprInstr (FNEG F32 reg1 reg2) = pprSizeRegReg SLIT("fneg") F32 reg1 reg2
1919 pprInstr (FNEG F64 reg1 reg2)
1920   = (<>) (pprSizeRegReg SLIT("fneg") F32 reg1 reg2)
1921     (if (reg1 == reg2) then empty
1922      else (<>) (char '\n')
1923           (pprSizeRegReg SLIT("fmov") F32 (fPair reg1) (fPair reg2)))
1924
1925 pprInstr (FSQRT size reg1 reg2)     = pprSizeRegReg SLIT("fsqrt") size reg1 reg2
1926 pprInstr (FSUB size reg1 reg2 reg3) = pprSizeRegRegReg SLIT("fsub") size reg1 reg2 reg3
1927 pprInstr (FxTOy size1 size2 reg1 reg2)
1928   = hcat [
1929         ptext SLIT("\tf"),
1930         ptext
1931         (case size1 of
1932             I32  -> SLIT("ito")
1933             F32  -> SLIT("sto")
1934             F64  -> SLIT("dto")),
1935         ptext
1936         (case size2 of
1937             I32  -> SLIT("i\t")
1938             F32  -> SLIT("s\t")
1939             F64  -> SLIT("d\t")),
1940         pprReg reg1, comma, pprReg reg2
1941     ]
1942
1943
1944 pprInstr (BI cond b lab)
1945   = hcat [
1946         ptext SLIT("\tb"), pprCond cond,
1947         if b then pp_comma_a else empty,
1948         char '\t',
1949         pprImm lab
1950     ]
1951
1952 pprInstr (BF cond b lab)
1953   = hcat [
1954         ptext SLIT("\tfb"), pprCond cond,
1955         if b then pp_comma_a else empty,
1956         char '\t',
1957         pprImm lab
1958     ]
1959
1960 pprInstr (JMP addr) = (<>) (ptext SLIT("\tjmp\t")) (pprAddr addr)
1961
1962 pprInstr (CALL (Left imm) n _)
1963   = hcat [ ptext SLIT("\tcall\t"), pprImm imm, comma, int n ]
1964 pprInstr (CALL (Right reg) n _)
1965   = hcat [ ptext SLIT("\tcall\t"), pprReg reg, comma, int n ]
1966
1967 pprRI :: RI -> Doc
1968 pprRI (RIReg r) = pprReg r
1969 pprRI (RIImm r) = pprImm r
1970
1971 pprSizeRegReg :: LitString -> MachRep -> Reg -> Reg -> Doc
1972 pprSizeRegReg name size reg1 reg2
1973   = hcat [
1974         char '\t',
1975         ptext name,
1976         (case size of
1977             F32  -> ptext SLIT("s\t")
1978             F64 -> ptext SLIT("d\t")),
1979         pprReg reg1,
1980         comma,
1981         pprReg reg2
1982     ]
1983
1984 pprSizeRegRegReg :: LitString -> MachRep -> Reg -> Reg -> Reg -> Doc
1985 pprSizeRegRegReg name size reg1 reg2 reg3
1986   = hcat [
1987         char '\t',
1988         ptext name,
1989         (case size of
1990             F32  -> ptext SLIT("s\t")
1991             F64  -> ptext SLIT("d\t")),
1992         pprReg reg1,
1993         comma,
1994         pprReg reg2,
1995         comma,
1996         pprReg reg3
1997     ]
1998
1999 pprRegRIReg :: LitString -> Bool -> Reg -> RI -> Reg -> Doc
2000 pprRegRIReg name b reg1 ri reg2
2001   = hcat [
2002         char '\t',
2003         ptext name,
2004         if b then ptext SLIT("cc\t") else char '\t',
2005         pprReg reg1,
2006         comma,
2007         pprRI ri,
2008         comma,
2009         pprReg reg2
2010     ]
2011
2012 pprRIReg :: LitString -> Bool -> RI -> Reg -> Doc
2013 pprRIReg name b ri reg1
2014   = hcat [
2015         char '\t',
2016         ptext name,
2017         if b then ptext SLIT("cc\t") else char '\t',
2018         pprRI ri,
2019         comma,
2020         pprReg reg1
2021     ]
2022
2023 pp_ld_lbracket    = ptext SLIT("\tld\t[")
2024 pp_rbracket_comma = text "],"
2025 pp_comma_lbracket = text ",["
2026 pp_comma_a        = text ",a"
2027
2028 #endif /* sparc_TARGET_ARCH */
2029
2030
2031 -- -----------------------------------------------------------------------------
2032 -- pprInstr for PowerPC
2033
2034 #if powerpc_TARGET_ARCH
2035 pprInstr (LD sz reg addr) = hcat [
2036         char '\t',
2037         ptext SLIT("l"),
2038         ptext (case sz of
2039             I8  -> SLIT("bz")
2040             I16 -> SLIT("hz")
2041             I32 -> SLIT("wz")
2042             F32 -> SLIT("fs")
2043             F64 -> SLIT("fd")),
2044         case addr of AddrRegImm _ _ -> empty
2045                      AddrRegReg _ _ -> char 'x',
2046         char '\t',
2047         pprReg reg,
2048         ptext SLIT(", "),
2049         pprAddr addr
2050     ]
2051 pprInstr (LA sz reg addr) = hcat [
2052         char '\t',
2053         ptext SLIT("l"),
2054         ptext (case sz of
2055             I8  -> SLIT("ba")
2056             I16 -> SLIT("ha")
2057             I32 -> SLIT("wa")
2058             F32 -> SLIT("fs")
2059             F64 -> SLIT("fd")),
2060         case addr of AddrRegImm _ _ -> empty
2061                      AddrRegReg _ _ -> char 'x',
2062         char '\t',
2063         pprReg reg,
2064         ptext SLIT(", "),
2065         pprAddr addr
2066     ]
2067 pprInstr (ST sz reg addr) = hcat [
2068         char '\t',
2069         ptext SLIT("st"),
2070         pprSize sz,
2071         case addr of AddrRegImm _ _ -> empty
2072                      AddrRegReg _ _ -> char 'x',
2073         char '\t',
2074         pprReg reg,
2075         ptext SLIT(", "),
2076         pprAddr addr
2077     ]
2078 pprInstr (STU sz reg addr) = hcat [
2079         char '\t',
2080         ptext SLIT("st"),
2081         pprSize sz,
2082         ptext SLIT("u\t"),
2083         case addr of AddrRegImm _ _ -> empty
2084                      AddrRegReg _ _ -> char 'x',
2085         pprReg reg,
2086         ptext SLIT(", "),
2087         pprAddr addr
2088     ]
2089 pprInstr (LIS reg imm) = hcat [
2090         char '\t',
2091         ptext SLIT("lis"),
2092         char '\t',
2093         pprReg reg,
2094         ptext SLIT(", "),
2095         pprImm imm
2096     ]
2097 pprInstr (LI reg imm) = hcat [
2098         char '\t',
2099         ptext SLIT("li"),
2100         char '\t',
2101         pprReg reg,
2102         ptext SLIT(", "),
2103         pprImm imm
2104     ]
2105 pprInstr (MR reg1 reg2)
2106     | reg1 == reg2 = empty
2107     | otherwise = hcat [
2108         char '\t',
2109         case regClass reg1 of
2110             RcInteger -> ptext SLIT("mr")
2111             _ -> ptext SLIT("fmr"),
2112         char '\t',
2113         pprReg reg1,
2114         ptext SLIT(", "),
2115         pprReg reg2
2116     ]
2117 pprInstr (CMP sz reg ri) = hcat [
2118         char '\t',
2119         op,
2120         char '\t',
2121         pprReg reg,
2122         ptext SLIT(", "),
2123         pprRI ri
2124     ]
2125     where
2126         op = hcat [
2127                 ptext SLIT("cmp"),
2128                 pprSize sz,
2129                 case ri of
2130                     RIReg _ -> empty
2131                     RIImm _ -> char 'i'
2132             ]
2133 pprInstr (CMPL sz reg ri) = hcat [
2134         char '\t',
2135         op,
2136         char '\t',
2137         pprReg reg,
2138         ptext SLIT(", "),
2139         pprRI ri
2140     ]
2141     where
2142         op = hcat [
2143                 ptext SLIT("cmpl"),
2144                 pprSize sz,
2145                 case ri of
2146                     RIReg _ -> empty
2147                     RIImm _ -> char 'i'
2148             ]
2149 pprInstr (BCC cond (BlockId id)) = hcat [
2150         char '\t',
2151         ptext SLIT("b"),
2152         pprCond cond,
2153         char '\t',
2154         pprCLabel_asm lbl
2155     ]
2156     where lbl = mkAsmTempLabel id
2157
2158 pprInstr (JMP lbl) = hcat [ -- an alias for b that takes a CLabel
2159         char '\t',
2160         ptext SLIT("b"),
2161         char '\t',
2162         pprCLabel_asm lbl
2163     ]
2164
2165 pprInstr (MTCTR reg) = hcat [
2166         char '\t',
2167         ptext SLIT("mtctr"),
2168         char '\t',
2169         pprReg reg
2170     ]
2171 pprInstr (BCTR _) = hcat [
2172         char '\t',
2173         ptext SLIT("bctr")
2174     ]
2175 pprInstr (BL lbl _) = hcat [
2176         ptext SLIT("\tbl\t"),
2177         pprCLabel_asm lbl
2178     ]
2179 pprInstr (BCTRL _) = hcat [
2180         char '\t',
2181         ptext SLIT("bctrl")
2182     ]
2183 pprInstr (ADD reg1 reg2 ri) = pprLogic SLIT("add") reg1 reg2 ri
2184 pprInstr (ADDIS reg1 reg2 imm) = hcat [
2185         char '\t',
2186         ptext SLIT("addis"),
2187         char '\t',
2188         pprReg reg1,
2189         ptext SLIT(", "),
2190         pprReg reg2,
2191         ptext SLIT(", "),
2192         pprImm imm
2193     ]
2194
2195 pprInstr (ADDC reg1 reg2 reg3) = pprLogic SLIT("addc") reg1 reg2 (RIReg reg3)
2196 pprInstr (ADDE reg1 reg2 reg3) = pprLogic SLIT("adde") reg1 reg2 (RIReg reg3)
2197 pprInstr (SUBF reg1 reg2 reg3) = pprLogic SLIT("subf") reg1 reg2 (RIReg reg3)
2198 pprInstr (MULLW reg1 reg2 ri@(RIReg _)) = pprLogic SLIT("mullw") reg1 reg2 ri
2199 pprInstr (MULLW reg1 reg2 ri@(RIImm _)) = pprLogic SLIT("mull") reg1 reg2 ri
2200 pprInstr (DIVW reg1 reg2 reg3) = pprLogic SLIT("divw") reg1 reg2 (RIReg reg3)
2201 pprInstr (DIVWU reg1 reg2 reg3) = pprLogic SLIT("divwu") reg1 reg2 (RIReg reg3)
2202
2203 pprInstr (MULLW_MayOflo reg1 reg2 reg3) = vcat [
2204          hcat [ ptext SLIT("\tmullwo\t"), pprReg reg1, ptext SLIT(", "),
2205                                           pprReg reg2, ptext SLIT(", "),
2206                                           pprReg reg3 ],
2207          hcat [ ptext SLIT("\tmfxer\t"),  pprReg reg1 ],
2208          hcat [ ptext SLIT("\trlwinm\t"), pprReg reg1, ptext SLIT(", "),
2209                                           pprReg reg1, ptext SLIT(", "),
2210                                           ptext SLIT("2, 31, 31") ]
2211     ]
2212
2213         -- for some reason, "andi" doesn't exist.
2214         -- we'll use "andi." instead.
2215 pprInstr (AND reg1 reg2 (RIImm imm)) = hcat [
2216         char '\t',
2217         ptext SLIT("andi."),
2218         char '\t',
2219         pprReg reg1,
2220         ptext SLIT(", "),
2221         pprReg reg2,
2222         ptext SLIT(", "),
2223         pprImm imm
2224     ]
2225 pprInstr (AND reg1 reg2 ri) = pprLogic SLIT("and") reg1 reg2 ri
2226
2227 pprInstr (OR reg1 reg2 ri) = pprLogic SLIT("or") reg1 reg2 ri
2228 pprInstr (XOR reg1 reg2 ri) = pprLogic SLIT("xor") reg1 reg2 ri
2229
2230 pprInstr (XORIS reg1 reg2 imm) = hcat [
2231         char '\t',
2232         ptext SLIT("xoris"),
2233         char '\t',
2234         pprReg reg1,
2235         ptext SLIT(", "),
2236         pprReg reg2,
2237         ptext SLIT(", "),
2238         pprImm imm
2239     ]
2240
2241 pprInstr (EXTS sz reg1 reg2) = hcat [
2242         char '\t',
2243         ptext SLIT("exts"),
2244         pprSize sz,
2245         char '\t',
2246         pprReg reg1,
2247         ptext SLIT(", "),
2248         pprReg reg2
2249     ]
2250
2251 pprInstr (NEG reg1 reg2) = pprUnary SLIT("neg") reg1 reg2
2252 pprInstr (NOT reg1 reg2) = pprUnary SLIT("not") reg1 reg2
2253
2254 pprInstr (SLW reg1 reg2 ri) = pprLogic SLIT("slw") reg1 reg2 (limitShiftRI ri)
2255 pprInstr (SRW reg1 reg2 ri) = pprLogic SLIT("srw") reg1 reg2 (limitShiftRI ri)
2256 pprInstr (SRAW reg1 reg2 ri) = pprLogic SLIT("sraw") reg1 reg2 (limitShiftRI ri)
2257 pprInstr (RLWINM reg1 reg2 sh mb me) = hcat [
2258         ptext SLIT("\trlwinm\t"),
2259         pprReg reg1,
2260         ptext SLIT(", "),
2261         pprReg reg2,
2262         ptext SLIT(", "),
2263         int sh,
2264         ptext SLIT(", "),
2265         int mb,
2266         ptext SLIT(", "),
2267         int me
2268     ]
2269
2270 pprInstr (FADD sz reg1 reg2 reg3) = pprBinaryF SLIT("fadd") sz reg1 reg2 reg3
2271 pprInstr (FSUB sz reg1 reg2 reg3) = pprBinaryF SLIT("fsub") sz reg1 reg2 reg3
2272 pprInstr (FMUL sz reg1 reg2 reg3) = pprBinaryF SLIT("fmul") sz reg1 reg2 reg3
2273 pprInstr (FDIV sz reg1 reg2 reg3) = pprBinaryF SLIT("fdiv") sz reg1 reg2 reg3
2274 pprInstr (FNEG reg1 reg2) = pprUnary SLIT("fneg") reg1 reg2
2275
2276 pprInstr (FCMP reg1 reg2) = hcat [
2277         char '\t',
2278         ptext SLIT("fcmpu\tcr0, "),
2279             -- Note: we're using fcmpu, not fcmpo
2280             -- The difference is with fcmpo, compare with NaN is an invalid operation.
2281             -- We don't handle invalid fp ops, so we don't care
2282         pprReg reg1,
2283         ptext SLIT(", "),
2284         pprReg reg2
2285     ]
2286
2287 pprInstr (FCTIWZ reg1 reg2) = pprUnary SLIT("fctiwz") reg1 reg2
2288 pprInstr (FRSP reg1 reg2) = pprUnary SLIT("frsp") reg1 reg2
2289
2290 pprInstr (CRNOR dst src1 src2) = hcat [
2291         ptext SLIT("\tcrnor\t"),
2292         int dst,
2293         ptext SLIT(", "),
2294         int src1,
2295         ptext SLIT(", "),
2296         int src2
2297     ]
2298
2299 pprInstr (MFCR reg) = hcat [
2300         char '\t',
2301         ptext SLIT("mfcr"),
2302         char '\t',
2303         pprReg reg
2304     ]
2305
2306 pprInstr (MFLR reg) = hcat [
2307         char '\t',
2308         ptext SLIT("mflr"),
2309         char '\t',
2310         pprReg reg
2311     ]
2312
2313 pprInstr (FETCHPC reg) = vcat [
2314         ptext SLIT("\tbcl\t20,31,1f"),
2315         hcat [ ptext SLIT("1:\tmflr\t"), pprReg reg ]
2316     ]
2317
2318 pprInstr _ = panic "pprInstr (ppc)"
2319
2320 pprLogic op reg1 reg2 ri = hcat [
2321         char '\t',
2322         ptext op,
2323         case ri of
2324             RIReg _ -> empty
2325             RIImm _ -> char 'i',
2326         char '\t',
2327         pprReg reg1,
2328         ptext SLIT(", "),
2329         pprReg reg2,
2330         ptext SLIT(", "),
2331         pprRI ri
2332     ]
2333
2334 pprUnary op reg1 reg2 = hcat [
2335         char '\t',
2336         ptext op,
2337         char '\t',
2338         pprReg reg1,
2339         ptext SLIT(", "),
2340         pprReg reg2
2341     ]
2342
2343 pprBinaryF op sz reg1 reg2 reg3 = hcat [
2344         char '\t',
2345         ptext op,
2346         pprFSize sz,
2347         char '\t',
2348         pprReg reg1,
2349         ptext SLIT(", "),
2350         pprReg reg2,
2351         ptext SLIT(", "),
2352         pprReg reg3
2353     ]
2354
2355 pprRI :: RI -> Doc
2356 pprRI (RIReg r) = pprReg r
2357 pprRI (RIImm r) = pprImm r
2358
2359 pprFSize F64 = empty
2360 pprFSize F32 = char 's'
2361
2362     -- limit immediate argument for shift instruction to range 0..32
2363     -- (yes, the maximum is really 32, not 31)
2364 limitShiftRI :: RI -> RI
2365 limitShiftRI (RIImm (ImmInt i)) | i > 32 || i < 0 = RIImm (ImmInt 32)
2366 limitShiftRI x = x
2367
2368 #endif /* powerpc_TARGET_ARCH */
2369
2370
2371 -- -----------------------------------------------------------------------------
2372 -- Converting floating-point literals to integrals for printing
2373
2374 #if __GLASGOW_HASKELL__ >= 504
2375 newFloatArray :: (Int,Int) -> ST s (STUArray s Int Float)
2376 newFloatArray = newArray_
2377
2378 newDoubleArray :: (Int,Int) -> ST s (STUArray s Int Double)
2379 newDoubleArray = newArray_
2380
2381 castFloatToCharArray :: STUArray s Int Float -> ST s (STUArray s Int Word8)
2382 castFloatToCharArray = castSTUArray
2383
2384 castDoubleToCharArray :: STUArray s Int Double -> ST s (STUArray s Int Word8)
2385 castDoubleToCharArray = castSTUArray
2386
2387 writeFloatArray :: STUArray s Int Float -> Int -> Float -> ST s ()
2388 writeFloatArray = writeArray
2389
2390 writeDoubleArray :: STUArray s Int Double -> Int -> Double -> ST s ()
2391 writeDoubleArray = writeArray
2392
2393 readCharArray :: STUArray s Int Word8 -> Int -> ST s Char
2394 readCharArray arr i = do
2395   w <- readArray arr i
2396   return $! (chr (fromIntegral w))
2397
2398 #else
2399
2400 castFloatToCharArray :: MutableByteArray s t -> ST s (MutableByteArray s t)
2401 castFloatToCharArray = return
2402
2403 castDoubleToCharArray :: MutableByteArray s t -> ST s (MutableByteArray s t)
2404
2405
2406 castDoubleToCharArray = return
2407
2408 #endif
2409
2410 -- floatToBytes and doubleToBytes convert to the host's byte
2411 -- order.  Providing that we're not cross-compiling for a
2412 -- target with the opposite endianness, this should work ok
2413 -- on all targets.
2414
2415 -- ToDo: this stuff is very similar to the shenanigans in PprAbs,
2416 -- could they be merged?
2417
2418 floatToBytes :: Float -> [Int]
2419 floatToBytes f
2420    = runST (do
2421         arr <- newFloatArray ((0::Int),3)
2422         writeFloatArray arr 0 f
2423         arr <- castFloatToCharArray arr
2424         i0 <- readCharArray arr 0
2425         i1 <- readCharArray arr 1
2426         i2 <- readCharArray arr 2
2427         i3 <- readCharArray arr 3
2428         return (map ord [i0,i1,i2,i3])
2429      )
2430
2431 doubleToBytes :: Double -> [Int]
2432 doubleToBytes d
2433    = runST (do
2434         arr <- newDoubleArray ((0::Int),7)
2435         writeDoubleArray arr 0 d
2436         arr <- castDoubleToCharArray arr
2437         i0 <- readCharArray arr 0
2438         i1 <- readCharArray arr 1
2439         i2 <- readCharArray arr 2
2440         i3 <- readCharArray arr 3
2441         i4 <- readCharArray arr 4
2442         i5 <- readCharArray arr 5
2443         i6 <- readCharArray arr 6
2444         i7 <- readCharArray arr 7
2445         return (map ord [i0,i1,i2,i3,i4,i5,i6,i7])
2446      )