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 -- Assume we want to backslash-convert the string
 701 pprASCII str
 702   = vcat (map do1 (str ++ [chr 0]))
 703     where
 704        do1 :: Char -> Doc
 705        do1 c = ptext SLIT("\t.byte\t0x") <> hshow (ord c)
 706
 707        hshow :: Int -> Doc
 708        hshow n | n >= 0 && n <= 255
 709                = char (tab !! (n `div` 16)) <> char (tab !! (n `mod` 16))
 710        tab = "0123456789ABCDEF"
 711
 712 pprAlign bytes =
 713         IF_ARCH_alpha(ptextSLIT(".align ") <> int pow2,
 714         IF_ARCH_i386(ptext SLIT(".align ") <> int IF_OS_darwin(pow2,bytes),
 715         IF_ARCH_x86_64(ptext SLIT(".align ") <> int bytes,
 716         IF_ARCH_sparc(ptext SLIT(".align ") <> int bytes,
 717         IF_ARCH_powerpc(ptext SLIT(".align ") <> int pow2,)))))
 718   where
 719         pow2 = log2 bytes
 720
 721         log2 :: Int -> Int  -- cache the common ones
 722         log2 1 = 0
 723         log2 2 = 1
 724         log2 4 = 2
 725         log2 8 = 3
 726         log2 n = 1 + log2 (n `quot` 2)
 727
 728
 729 pprDataItem :: CmmLit -> Doc
 730 pprDataItem lit
 731   = vcat (ppr_item (cmmLitRep lit) lit)
 732     where
 733         imm = litToImm lit
 734
 735         -- These seem to be common:
 736         ppr_item I8   x = [ptext SLIT("\t.byte\t") <> pprImm imm]
 737         ppr_item I32  x = [ptext SLIT("\t.long\t") <> pprImm imm]
 738         ppr_item F32  (CmmFloat r _)
 739            = let bs = floatToBytes (fromRational r)
 740              in  map (\b -> ptext SLIT("\t.byte\t") <> pprImm (ImmInt b)) bs
 741         ppr_item F64 (CmmFloat r _)
 742            = let bs = doubleToBytes (fromRational r)
 743              in  map (\b -> ptext SLIT("\t.byte\t") <> pprImm (ImmInt b)) bs
 744
 745 #if sparc_TARGET_ARCH
 746         -- copy n paste of x86 version
 747         ppr_item I16  x = [ptext SLIT("\t.short\t") <> pprImm imm]
 748         ppr_item I64  x = [ptext SLIT("\t.quad\t") <> pprImm imm]
 749 #endif
 750 #if i386_TARGET_ARCH || x86_64_TARGET_ARCH
 751         ppr_item I16  x = [ptext SLIT("\t.word\t") <> pprImm imm]
 752 #endif
 753 #if i386_TARGET_ARCH
 754         ppr_item I64  x = [ptext SLIT("\t.quad\t") <> pprImm imm]
 755 #endif
 756 #if x86_64_TARGET_ARCH
 757         -- x86_64: binutils can't handle the R_X86_64_PC64 relocation
 758         -- type, which means we can't do pc-relative 64-bit addresses.
 759         -- Fortunately we're assuming the small memory model, in which
 760         -- all such offsets will fit into 32 bits, so we have to stick
 761         -- to 32-bit offset fields and modify the RTS appropriately
 762         -- (see InfoTables.h).
 763         --
 764         ppr_item I64  x
 765            | isRelativeReloc x =
 766                 [ptext SLIT("\t.long\t") <> pprImm imm,
 767                  ptext SLIT("\t.long\t0")]
 768            | otherwise =
 769                 [ptext SLIT("\t.quad\t") <> pprImm imm]
 770            where
 771                 isRelativeReloc (CmmLabelOff _ _)       = True
 772                 isRelativeReloc (CmmLabelDiffOff _ _ _) = True
 773                 isRelativeReloc _ = False
 774 #endif
 775 #if powerpc_TARGET_ARCH
 776         ppr_item I16 x = [ptext SLIT("\t.short\t") <> pprImm imm]
 777         ppr_item I64 (CmmInt x _)  =
 778                 [ptext SLIT("\t.long\t")
 779                     <> int (fromIntegral
 780                         (fromIntegral (x `shiftR` 32) :: Word32)),
 781                  ptext SLIT("\t.long\t")
 782                     <> int (fromIntegral (fromIntegral x :: Word32))]
 783 #endif
 784
 785 -- fall through to rest of (machine-specific) pprInstr...
 786
 787 -- -----------------------------------------------------------------------------
 788 -- pprInstr: print an 'Instr'
 789
 790 pprInstr :: Instr -> Doc
 791
 792 --pprInstr (COMMENT s) = empty -- nuke 'em
 793 pprInstr (COMMENT s)
 794    =  IF_ARCH_alpha( ((<>) (ptext SLIT("\t# ")) (ftext s))
 795      ,IF_ARCH_sparc( ((<>) (ptext SLIT("! "))   (ftext s))
 796      ,IF_ARCH_i386( ((<>) (ptext SLIT("# "))   (ftext s))
 797      ,IF_ARCH_x86_64( ((<>) (ptext SLIT("# "))   (ftext s))
 798      ,IF_ARCH_powerpc( IF_OS_linux(
 799         ((<>) (ptext SLIT("# ")) (ftext s)),
 800         ((<>) (ptext SLIT("; ")) (ftext s)))
 801      ,)))))
 802
 803 pprInstr (DELTA d)
 804    = pprInstr (COMMENT (mkFastString ("\tdelta = " ++ show d)))
 805
 806 pprInstr (NEWBLOCK _)
 807    = panic "PprMach.pprInstr: NEWBLOCK"
 808
 809 pprInstr (LDATA _ _)
 810    = panic "PprMach.pprInstr: LDATA"
 811
 812 -- -----------------------------------------------------------------------------
 813 -- pprInstr for an Alpha
 814
 815 #if alpha_TARGET_ARCH
 816
 817 pprInstr (LD size reg addr)
 818   = hcat [
 819         ptext SLIT("\tld"),
 820         pprSize size,
 821         char '\t',
 822         pprReg reg,
 823         comma,
 824         pprAddr addr
 825     ]
 826
 827 pprInstr (LDA reg addr)
 828   = hcat [
 829         ptext SLIT("\tlda\t"),
 830         pprReg reg,
 831         comma,
 832         pprAddr addr
 833     ]
 834
 835 pprInstr (LDAH reg addr)
 836   = hcat [
 837         ptext SLIT("\tldah\t"),
 838         pprReg reg,
 839         comma,
 840         pprAddr addr
 841     ]
 842
 843 pprInstr (LDGP reg addr)
 844   = hcat [
 845         ptext SLIT("\tldgp\t"),
 846         pprReg reg,
 847         comma,
 848         pprAddr addr
 849     ]
 850
 851 pprInstr (LDI size reg imm)
 852   = hcat [
 853         ptext SLIT("\tldi"),
 854         pprSize size,
 855         char '\t',
 856         pprReg reg,
 857         comma,
 858         pprImm imm
 859     ]
 860
 861 pprInstr (ST size reg addr)
 862   = hcat [
 863         ptext SLIT("\tst"),
 864         pprSize size,
 865         char '\t',
 866         pprReg reg,
 867         comma,
 868         pprAddr addr
 869     ]
 870
 871 pprInstr (CLR reg)
 872   = hcat [
 873         ptext SLIT("\tclr\t"),
 874         pprReg reg
 875     ]
 876
 877 pprInstr (ABS size ri reg)
 878   = hcat [
 879         ptext SLIT("\tabs"),
 880         pprSize size,
 881         char '\t',
 882         pprRI ri,
 883         comma,
 884         pprReg reg
 885     ]
 886
 887 pprInstr (NEG size ov ri reg)
 888   = hcat [
 889         ptext SLIT("\tneg"),
 890         pprSize size,
 891         if ov then ptext SLIT("v\t") else char '\t',
 892         pprRI ri,
 893         comma,
 894         pprReg reg
 895     ]
 896
 897 pprInstr (ADD size ov reg1 ri reg2)
 898   = hcat [
 899         ptext SLIT("\tadd"),
 900         pprSize size,
 901         if ov then ptext SLIT("v\t") else char '\t',
 902         pprReg reg1,
 903         comma,
 904         pprRI ri,
 905         comma,
 906         pprReg reg2
 907     ]
 908
 909 pprInstr (SADD size scale reg1 ri reg2)
 910   = hcat [
 911         ptext (case scale of {{-UNUSED:L -> SLIT("\ts4");-} Q -> SLIT("\ts8")}),
 912         ptext SLIT("add"),
 913         pprSize size,
 914         char '\t',
 915         pprReg reg1,
 916         comma,
 917         pprRI ri,
 918         comma,
 919         pprReg reg2
 920     ]
 921
 922 pprInstr (SUB size ov reg1 ri reg2)
 923   = hcat [
 924         ptext SLIT("\tsub"),
 925         pprSize size,
 926         if ov then ptext SLIT("v\t") else char '\t',
 927         pprReg reg1,
 928         comma,
 929         pprRI ri,
 930         comma,
 931         pprReg reg2
 932     ]
 933
 934 pprInstr (SSUB size scale reg1 ri reg2)
 935   = hcat [
 936         ptext (case scale of {{-UNUSED:L -> SLIT("\ts4");-} Q -> SLIT("\ts8")}),
 937         ptext SLIT("sub"),
 938         pprSize size,
 939         char '\t',
 940         pprReg reg1,
 941         comma,
 942         pprRI ri,
 943         comma,
 944         pprReg reg2
 945     ]
 946
 947 pprInstr (MUL size ov reg1 ri reg2)
 948   = hcat [
 949         ptext SLIT("\tmul"),
 950         pprSize size,
 951         if ov then ptext SLIT("v\t") else char '\t',
 952         pprReg reg1,
 953         comma,
 954         pprRI ri,
 955         comma,
 956         pprReg reg2
 957     ]
 958
 959 pprInstr (DIV size uns reg1 ri reg2)
 960   = hcat [
 961         ptext SLIT("\tdiv"),
 962         pprSize size,
 963         if uns then ptext SLIT("u\t") else char '\t',
 964         pprReg reg1,
 965         comma,
 966         pprRI ri,
 967         comma,
 968         pprReg reg2
 969     ]
 970
 971 pprInstr (REM size uns reg1 ri reg2)
 972   = hcat [
 973         ptext SLIT("\trem"),
 974         pprSize size,
 975         if uns then ptext SLIT("u\t") else char '\t',
 976         pprReg reg1,
 977         comma,
 978         pprRI ri,
 979         comma,
 980         pprReg reg2
 981     ]
 982
 983 pprInstr (NOT ri reg)
 984   = hcat [
 985         ptext SLIT("\tnot"),
 986         char '\t',
 987         pprRI ri,
 988         comma,
 989         pprReg reg
 990     ]
 991
 992 pprInstr (AND reg1 ri reg2) = pprRegRIReg SLIT("and") reg1 ri reg2
 993 pprInstr (ANDNOT reg1 ri reg2) = pprRegRIReg SLIT("andnot") reg1 ri reg2
 994 pprInstr (OR reg1 ri reg2) = pprRegRIReg SLIT("or") reg1 ri reg2
 995 pprInstr (ORNOT reg1 ri reg2) = pprRegRIReg SLIT("ornot") reg1 ri reg2
 996 pprInstr (XOR reg1 ri reg2) = pprRegRIReg SLIT("xor") reg1 ri reg2
 997 pprInstr (XORNOT reg1 ri reg2) = pprRegRIReg SLIT("xornot") reg1 ri reg2
 998
 999 pprInstr (SLL reg1 ri reg2) = pprRegRIReg SLIT("sll") reg1 ri reg2
1000 pprInstr (SRL reg1 ri reg2) = pprRegRIReg SLIT("srl") reg1 ri reg2
1001 pprInstr (SRA reg1 ri reg2) = pprRegRIReg SLIT("sra") reg1 ri reg2
1002
1003 pprInstr (ZAP reg1 ri reg2) = pprRegRIReg SLIT("zap") reg1 ri reg2
1004 pprInstr (ZAPNOT reg1 ri reg2) = pprRegRIReg SLIT("zapnot") reg1 ri reg2
1005
1006 pprInstr (NOP) = ptext SLIT("\tnop")
1007
1008 pprInstr (CMP cond reg1 ri reg2)
1009   = hcat [
1010         ptext SLIT("\tcmp"),
1011         pprCond cond,
1012         char '\t',
1013         pprReg reg1,
1014         comma,
1015         pprRI ri,
1016         comma,
1017         pprReg reg2
1018     ]
1019
1020 pprInstr (FCLR reg)
1021   = hcat [
1022         ptext SLIT("\tfclr\t"),
1023         pprReg reg
1024     ]
1025
1026 pprInstr (FABS reg1 reg2)
1027   = hcat [
1028         ptext SLIT("\tfabs\t"),
1029         pprReg reg1,
1030         comma,
1031         pprReg reg2
1032     ]
1033
1034 pprInstr (FNEG size reg1 reg2)
1035   = hcat [
1036         ptext SLIT("\tneg"),
1037         pprSize size,
1038         char '\t',
1039         pprReg reg1,
1040         comma,
1041         pprReg reg2
1042     ]
1043
1044 pprInstr (FADD size reg1 reg2 reg3) = pprSizeRegRegReg SLIT("add") size reg1 reg2 reg3
1045 pprInstr (FDIV size reg1 reg2 reg3) = pprSizeRegRegReg SLIT("div") size reg1 reg2 reg3
1046 pprInstr (FMUL size reg1 reg2 reg3) = pprSizeRegRegReg SLIT("mul") size reg1 reg2 reg3
1047 pprInstr (FSUB size reg1 reg2 reg3) = pprSizeRegRegReg SLIT("sub") size reg1 reg2 reg3
1048
1049 pprInstr (CVTxy size1 size2 reg1 reg2)
1050   = hcat [
1051         ptext SLIT("\tcvt"),
1052         pprSize size1,
1053         case size2 of {Q -> ptext SLIT("qc"); _ -> pprSize size2},
1054         char '\t',
1055         pprReg reg1,
1056         comma,
1057         pprReg reg2
1058     ]
1059
1060 pprInstr (FCMP size cond reg1 reg2 reg3)
1061   = hcat [
1062         ptext SLIT("\tcmp"),
1063         pprSize size,
1064         pprCond cond,
1065         char '\t',
1066         pprReg reg1,
1067         comma,
1068         pprReg reg2,
1069         comma,
1070         pprReg reg3
1071     ]
1072
1073 pprInstr (FMOV reg1 reg2)
1074   = hcat [
1075         ptext SLIT("\tfmov\t"),
1076         pprReg reg1,
1077         comma,
1078         pprReg reg2
1079     ]
1080
1081 pprInstr (BI ALWAYS reg lab) = pprInstr (BR lab)
1082
1083 pprInstr (BI NEVER reg lab) = empty
1084
1085 pprInstr (BI cond reg lab)
1086   = hcat [
1087         ptext SLIT("\tb"),
1088         pprCond cond,
1089         char '\t',
1090         pprReg reg,
1091         comma,
1092         pprImm lab
1093     ]
1094
1095 pprInstr (BF cond reg lab)
1096   = hcat [
1097         ptext SLIT("\tfb"),
1098         pprCond cond,
1099         char '\t',
1100         pprReg reg,
1101         comma,
1102         pprImm lab
1103     ]
1104
1105 pprInstr (BR lab)
1106   = (<>) (ptext SLIT("\tbr\t")) (pprImm lab)
1107
1108 pprInstr (JMP reg addr hint)
1109   = hcat [
1110         ptext SLIT("\tjmp\t"),
1111         pprReg reg,
1112         comma,
1113         pprAddr addr,
1114         comma,
1115         int hint
1116     ]
1117
1118 pprInstr (BSR imm n)
1119   = (<>) (ptext SLIT("\tbsr\t")) (pprImm imm)
1120
1121 pprInstr (JSR reg addr n)
1122   = hcat [
1123         ptext SLIT("\tjsr\t"),
1124         pprReg reg,
1125         comma,
1126         pprAddr addr
1127     ]
1128
1129 pprInstr (FUNBEGIN clab)
1130   = hcat [
1131         if (externallyVisibleCLabel clab) then
1132             hcat [ptext SLIT("\t.globl\t"), pp_lab, char '\n']
1133         else
1134             empty,
1135         ptext SLIT("\t.ent "),
1136         pp_lab,
1137         char '\n',
1138         pp_lab,
1139         pp_ldgp,
1140         pp_lab,
1141         pp_frame
1142     ]
1143     where
1144         pp_lab = pprCLabel_asm clab
1145
1146         -- NEVER use commas within those string literals, cpp will ruin your day
1147         pp_ldgp  = hcat [ ptext SLIT(":\n\tldgp $29"), char ',', ptext SLIT("0($27)\n") ]
1148         pp_frame = hcat [ ptext SLIT("..ng:\n\t.frame $30"), char ',',
1149                           ptext SLIT("4240"), char ',',
1150                           ptext SLIT("$26"), char ',',
1151                           ptext SLIT("0\n\t.prologue 1") ]
1152
1153 pprInstr (FUNEND clab)
1154   = (<>) (ptext SLIT("\t.align 4\n\t.end ")) (pprCLabel_asm clab)
1155 \end{code}
1156
1157 Continue with Alpha-only printing bits and bobs:
1158 \begin{code}
1159 pprRI :: RI -> Doc
1160
1161 pprRI (RIReg r) = pprReg r
1162 pprRI (RIImm r) = pprImm r
1163
1164 pprRegRIReg :: LitString -> Reg -> RI -> Reg -> Doc
1165 pprRegRIReg name reg1 ri reg2
1166   = hcat [
1167         char '\t',
1168         ptext name,
1169         char '\t',
1170         pprReg reg1,
1171         comma,
1172         pprRI ri,
1173         comma,
1174         pprReg reg2
1175     ]
1176
1177 pprSizeRegRegReg :: LitString -> Size -> Reg -> Reg -> Reg -> Doc
1178 pprSizeRegRegReg name size reg1 reg2 reg3
1179   = hcat [
1180         char '\t',
1181         ptext name,
1182         pprSize size,
1183         char '\t',
1184         pprReg reg1,
1185         comma,
1186         pprReg reg2,
1187         comma,
1188         pprReg reg3
1189     ]
1190
1191 #endif /* alpha_TARGET_ARCH */
1192
1193
1194 -- -----------------------------------------------------------------------------
1195 -- pprInstr for an x86
1196
1197 #if i386_TARGET_ARCH || x86_64_TARGET_ARCH
1198
1199 pprInstr v@(MOV size s@(OpReg src) d@(OpReg dst)) -- hack
1200   | src == dst
1201   =
1202 #if 0 /* #ifdef DEBUG */
1203     (<>) (ptext SLIT("# warning: ")) (pprSizeOpOp SLIT("mov") size s d)
1204 #else
1205     empty
1206 #endif
1207
1208 pprInstr (MOV size src dst)
1209   = pprSizeOpOp SLIT("mov") size src dst
1210
1211 pprInstr (MOVZxL I32 src dst) = pprSizeOpOp SLIT("mov") I32 src dst
1212         -- 32-to-64 bit zero extension on x86_64 is accomplished by a simple
1213         -- movl.  But we represent it as a MOVZxL instruction, because
1214         -- the reg alloc would tend to throw away a plain reg-to-reg
1215         -- move, and we still want it to do that.
1216
1217 pprInstr (MOVZxL sizes src dst) = pprSizeOpOpCoerce SLIT("movz") sizes I32 src dst
1218         -- zero-extension only needs to extend to 32 bits: on x86_64,
1219         -- the remaining zero-extension to 64 bits is automatic, and the 32-bit
1220         -- instruction is shorter.
1221
1222 pprInstr (MOVSxL sizes src dst) = pprSizeOpOpCoerce SLIT("movs") sizes wordRep src dst
1223
1224 -- here we do some patching, since the physical registers are only set late
1225 -- in the code generation.
1226 pprInstr (LEA size (OpAddr (AddrBaseIndex src1@(EABaseReg reg1) (EAIndex reg2 1) (ImmInt 0))) dst@(OpReg reg3))
1227   | reg1 == reg3
1228   = pprSizeOpOp SLIT("add") size (OpReg reg2) dst
1229 pprInstr (LEA size (OpAddr (AddrBaseIndex src1@(EABaseReg reg1) (EAIndex reg2 1) (ImmInt 0))) dst@(OpReg reg3))
1230   | reg2 == reg3
1231   = pprSizeOpOp SLIT("add") size (OpReg reg1) dst
1232 pprInstr (LEA size (OpAddr (AddrBaseIndex src1@(EABaseReg reg1) EAIndexNone displ)) dst@(OpReg reg3))
1233   | reg1 == reg3
1234   = pprInstr (ADD size (OpImm displ) dst)
1235 pprInstr (LEA size src dst) = pprSizeOpOp SLIT("lea") size src dst
1236
1237 pprInstr (ADD size (OpImm (ImmInt (-1))) dst)
1238   = pprSizeOp SLIT("dec") size dst
1239 pprInstr (ADD size (OpImm (ImmInt 1)) dst)
1240   = pprSizeOp SLIT("inc") size dst
1241 pprInstr (ADD size src dst)
1242   = pprSizeOpOp SLIT("add") size src dst
1243 pprInstr (ADC size src dst)
1244   = pprSizeOpOp SLIT("adc") size src dst
1245 pprInstr (SUB size src dst) = pprSizeOpOp SLIT("sub") size src dst
1246 pprInstr (IMUL size op1 op2) = pprSizeOpOp SLIT("imul") size op1 op2
1247
1248 {- A hack.  The Intel documentation says that "The two and three
1249    operand forms [of IMUL] may also be used with unsigned operands
1250    because the lower half of the product is the same regardless if
1251    (sic) the operands are signed or unsigned.  The CF and OF flags,
1252    however, cannot be used to determine if the upper half of the
1253    result is non-zero."  So there.
1254 -}
1255 pprInstr (AND size src dst) = pprSizeOpOp SLIT("and") size src dst
1256 pprInstr (OR  size src dst) = pprSizeOpOp SLIT("or")  size src dst
1257
1258 pprInstr (XOR F32 src dst)  = pprOpOp SLIT("xorps") F32 src dst
1259 pprInstr (XOR F64 src dst)  = pprOpOp SLIT("xorpd") F64 src dst
1260 pprInstr (XOR size src dst) = pprSizeOpOp SLIT("xor")  size src dst
1261
1262 pprInstr (NOT size op) = pprSizeOp SLIT("not") size op
1263 pprInstr (NEGI size op) = pprSizeOp SLIT("neg") size op
1264
1265 pprInstr (SHL size src dst) = pprShift SLIT("shl") size src dst
1266 pprInstr (SAR size src dst) = pprShift SLIT("sar") size src dst
1267 pprInstr (SHR size src dst) = pprShift SLIT("shr") size src dst
1268
1269 pprInstr (BT  size imm src) = pprSizeImmOp SLIT("bt") size imm src
1270
1271 pprInstr (CMP size src dst)
1272   | isFloatingRep size =  pprSizeOpOp SLIT("ucomi")  size src dst -- SSE2
1273   | otherwise          =  pprSizeOpOp SLIT("cmp")  size src dst
1274
1275 pprInstr (TEST size src dst) = pprSizeOpOp SLIT("test")  size src dst
1276 pprInstr (PUSH size op) = pprSizeOp SLIT("push") size op
1277 pprInstr (POP size op) = pprSizeOp SLIT("pop") size op
1278
1279 -- both unused (SDM):
1280 -- pprInstr PUSHA = ptext SLIT("\tpushal")
1281 -- pprInstr POPA = ptext SLIT("\tpopal")
1282
1283 pprInstr NOP = ptext SLIT("\tnop")
1284 pprInstr (CLTD I32) = ptext SLIT("\tcltd")
1285 pprInstr (CLTD I64) = ptext SLIT("\tcqto")
1286
1287 pprInstr (SETCC cond op) = pprCondInstr SLIT("set") cond (pprOperand I8 op)
1288
1289 pprInstr (JXX cond (BlockId id))
1290   = pprCondInstr SLIT("j") cond (pprCLabel_asm lab)
1291   where lab = mkAsmTempLabel id
1292
1293 pprInstr (JMP (OpImm imm)) = (<>) (ptext SLIT("\tjmp ")) (pprImm imm)
1294 pprInstr (JMP op)          = (<>) (ptext SLIT("\tjmp *")) (pprOperand wordRep op)
1295 pprInstr (JMP_TBL op ids)  = pprInstr (JMP op)
1296 pprInstr (CALL (Left imm) _)    = (<>) (ptext SLIT("\tcall ")) (pprImm imm)
1297 pprInstr (CALL (Right reg) _)   = (<>) (ptext SLIT("\tcall *")) (pprReg wordRep reg)
1298
1299 pprInstr (IDIV sz op)   = pprSizeOp SLIT("idiv") sz op
1300 pprInstr (DIV sz op)    = pprSizeOp SLIT("div")  sz op
1301 pprInstr (IMUL2 sz op)  = pprSizeOp SLIT("imul") sz op
1302
1303 #if x86_64_TARGET_ARCH
1304 pprInstr (MUL size op1 op2) = pprSizeOpOp SLIT("mul") size op1 op2
1305
1306 pprInstr (FDIV size op1 op2) = pprSizeOpOp SLIT("div") size op1 op2
1307
1308 pprInstr (CVTSS2SD from to) = pprRegReg SLIT("cvtss2sd") from to
1309 pprInstr (CVTSD2SS from to) = pprRegReg SLIT("cvtsd2ss") from to
1310 pprInstr (CVTSS2SI from to) = pprOpReg  SLIT("cvtss2si") from to
1311 pprInstr (CVTSD2SI from to) = pprOpReg  SLIT("cvtsd2si") from to
1312 pprInstr (CVTSI2SS from to) = pprOpReg  SLIT("cvtsi2ss") from to
1313 pprInstr (CVTSI2SD from to) = pprOpReg  SLIT("cvtsi2sd") from to
1314 #endif
1315
1316     -- FETCHGOT for PIC on ELF platforms
1317 pprInstr (FETCHGOT reg)
1318    = vcat [ ptext SLIT("\tcall 1f"),
1319             hcat [ ptext SLIT("1:\tpopl\t"), pprReg I32 reg ],
1320             hcat [ ptext SLIT("\taddl\t$_GLOBAL_OFFSET_TABLE_+(.-1b), "),
1321                    pprReg I32 reg ]
1322           ]
1323
1324     -- FETCHPC for PIC on Darwin/x86
1325     -- get the instruction pointer into a register
1326     -- (Terminology note: the IP is called Program Counter on PPC,
1327     --  and it's a good thing to use the same name on both platforms)
1328 pprInstr (FETCHPC reg)
1329    = vcat [ ptext SLIT("\tcall 1f"),
1330             hcat [ ptext SLIT("1:\tpopl\t"), pprReg I32 reg ]
1331           ]
1332
1333
1334
1335 #endif
1336
1337 -- -----------------------------------------------------------------------------
1338 -- i386 floating-point
1339
1340 #if i386_TARGET_ARCH
1341 -- Simulating a flat register set on the x86 FP stack is tricky.
1342 -- you have to free %st(7) before pushing anything on the FP reg stack
1343 -- so as to preclude the possibility of a FP stack overflow exception.
1344 pprInstr g@(GMOV src dst)
1345    | src == dst
1346    = empty
1347    | otherwise
1348    = pprG g (hcat [gtab, gpush src 0, gsemi, gpop dst 1])
1349
1350 -- GLD sz addr dst ==> FFREE %st(7) ; FLDsz addr ; FSTP (dst+1)
1351 pprInstr g@(GLD sz addr dst)
1352  = pprG g (hcat [gtab, text "ffree %st(7) ; fld", pprSize sz, gsp,
1353                  pprAddr addr, gsemi, gpop dst 1])
1354
1355 -- GST sz src addr ==> FFREE %st(7) ; FLD dst ; FSTPsz addr
1356 pprInstr g@(GST sz src addr)
1357  = pprG g (hcat [gtab, gpush src 0, gsemi,
1358                  text "fstp", pprSize sz, gsp, pprAddr addr])
1359
1360 pprInstr g@(GLDZ dst)
1361  = pprG g (hcat [gtab, text "ffree %st(7) ; fldz ; ", gpop dst 1])
1362 pprInstr g@(GLD1 dst)
1363  = pprG g (hcat [gtab, text "ffree %st(7) ; fld1 ; ", gpop dst 1])
1364
1365 pprInstr g@(GFTOI src dst)
1366    = pprInstr (GDTOI src dst)
1367 pprInstr g@(GDTOI src dst)
1368    = pprG g (hcat [gtab, text "subl $4, %esp ; ",
1369                    gpush src 0, gsemi, text "fistpl 0(%esp) ; popl ",
1370                    pprReg I32 dst])
1371
1372 pprInstr g@(GITOF src dst)
1373    = pprInstr (GITOD src dst)
1374 pprInstr g@(GITOD src dst)
1375    = pprG g (hcat [gtab, text "pushl ", pprReg I32 src,
1376                    text " ; ffree %st(7); fildl (%esp) ; ",
1377                    gpop dst 1, text " ; addl $4,%esp"])
1378
1379 {- Gruesome swamp follows.  If you're unfortunate enough to have ventured
1380    this far into the jungle AND you give a Rat's Ass (tm) what's going
1381    on, here's the deal.  Generate code to do a floating point comparison
1382    of src1 and src2, of kind cond, and set the Zero flag if true.
1383
1384    The complications are to do with handling NaNs correctly.  We want the
1385    property that if either argument is NaN, then the result of the
1386    comparison is False ... except if we're comparing for inequality,
1387    in which case the answer is True.
1388
1389    Here's how the general (non-inequality) case works.  As an
1390    example, consider generating the an equality test:
1391
1392      pushl %eax         -- we need to mess with this
1393      <get src1 to top of FPU stack>
1394      fcomp <src2 location in FPU stack> and pop pushed src1
1395                 -- Result of comparison is in FPU Status Register bits
1396                 -- C3 C2 and C0
1397      fstsw %ax  -- Move FPU Status Reg to %ax
1398      sahf       -- move C3 C2 C0 from %ax to integer flag reg
1399      -- now the serious magic begins
1400      setpo %ah     -- %ah = if comparable(neither arg was NaN) then 1 else 0
1401      sete  %al     -- %al = if arg1 == arg2 then 1 else 0
1402      andb %ah,%al  -- %al &= %ah
1403                    -- so %al == 1 iff (comparable && same); else it holds 0
1404      decb %al      -- %al == 0, ZeroFlag=1  iff (comparable && same);
1405                       else %al == 0xFF, ZeroFlag=0
1406      -- the zero flag is now set as we desire.
1407      popl %eax
1408
1409    The special case of inequality differs thusly:
1410
1411      setpe %ah     -- %ah = if incomparable(either arg was NaN) then 1 else 0
1412      setne %al     -- %al = if arg1 /= arg2 then 1 else 0
1413      orb %ah,%al   -- %al = if (incomparable || different) then 1 else 0
1414      decb %al      -- if (incomparable || different) then (%al == 0, ZF=1)
1415                                                      else (%al == 0xFF, ZF=0)
1416 -}
1417 pprInstr g@(GCMP cond src1 src2)
1418    | case cond of { NE -> True; other -> False }
1419    = pprG g (vcat [
1420         hcat [gtab, text "pushl %eax ; ",gpush src1 0],
1421         hcat [gtab, text "fcomp ", greg src2 1,
1422                     text "; fstsw %ax ; sahf ;  setpe %ah"],
1423         hcat [gtab, text "setne %al ;  ",
1424               text "orb %ah,%al ;  decb %al ;  popl %eax"]
1425     ])
1426    | otherwise
1427    = pprG g (vcat [
1428         hcat [gtab, text "pushl %eax ; ",gpush src1 0],
1429         hcat [gtab, text "fcomp ", greg src2 1,
1430                     text "; fstsw %ax ; sahf ;  setpo %ah"],
1431         hcat [gtab, text "set", pprCond (fix_FP_cond cond), text " %al ;  ",
1432               text "andb %ah,%al ;  decb %al ;  popl %eax"]
1433     ])
1434     where
1435         {- On the 486, the flags set by FP compare are the unsigned ones!
1436            (This looks like a HACK to me.  WDP 96/03)
1437         -}
1438         fix_FP_cond :: Cond -> Cond
1439         fix_FP_cond GE   = GEU
1440         fix_FP_cond GTT  = GU
1441         fix_FP_cond LTT  = LU
1442         fix_FP_cond LE   = LEU
1443         fix_FP_cond EQQ  = EQQ
1444         fix_FP_cond NE   = NE
1445         -- there should be no others
1446
1447
1448 pprInstr g@(GABS sz src dst)
1449    = pprG g (hcat [gtab, gpush src 0, text " ; fabs ; ", gpop dst 1])
1450 pprInstr g@(GNEG sz src dst)
1451    = pprG g (hcat [gtab, gpush src 0, text " ; fchs ; ", gpop dst 1])
1452
1453 pprInstr g@(GSQRT sz src dst)
1454    = pprG g (hcat [gtab, gpush src 0, text " ; fsqrt"] $$
1455              hcat [gtab, gcoerceto sz, gpop dst 1])
1456 pprInstr g@(GSIN sz src dst)
1457    = pprG g (hcat [gtab, gpush src 0, text " ; fsin"] $$
1458              hcat [gtab, gcoerceto sz, gpop dst 1])
1459 pprInstr g@(GCOS sz src dst)
1460    = pprG g (hcat [gtab, gpush src 0, text " ; fcos"] $$
1461              hcat [gtab, gcoerceto sz, gpop dst 1])
1462 pprInstr g@(GTAN sz src dst)
1463    = pprG g (hcat [gtab, text "ffree %st(6) ; ",
1464                    gpush src 0, text " ; fptan ; ",
1465                    text " fstp %st(0)"] $$
1466              hcat [gtab, gcoerceto sz, gpop dst 1])
1467
1468 -- In the translations for GADD, GMUL, GSUB and GDIV,
1469 -- the first two cases are mere optimisations.  The otherwise clause
1470 -- generates correct code under all circumstances.
1471
1472 pprInstr g@(GADD sz src1 src2 dst)
1473    | src1 == dst
1474    = pprG g (text "\t#GADD-xxxcase1" $$
1475              hcat [gtab, gpush src2 0,
1476                    text " ; faddp %st(0),", greg src1 1])
1477    | src2 == dst
1478    = pprG g (text "\t#GADD-xxxcase2" $$
1479              hcat [gtab, gpush src1 0,
1480                    text " ; faddp %st(0),", greg src2 1])
1481    | otherwise
1482    = pprG g (hcat [gtab, gpush src1 0,
1483                    text " ; fadd ", greg src2 1, text ",%st(0)",
1484                    gsemi, gpop dst 1])
1485
1486
1487 pprInstr g@(GMUL sz src1 src2 dst)
1488    | src1 == dst
1489    = pprG g (text "\t#GMUL-xxxcase1" $$
1490              hcat [gtab, gpush src2 0,
1491                    text " ; fmulp %st(0),", greg src1 1])
1492    | src2 == dst
1493    = pprG g (text "\t#GMUL-xxxcase2" $$
1494              hcat [gtab, gpush src1 0,
1495                    text " ; fmulp %st(0),", greg src2 1])
1496    | otherwise
1497    = pprG g (hcat [gtab, gpush src1 0,
1498                    text " ; fmul ", greg src2 1, text ",%st(0)",
1499                    gsemi, gpop dst 1])
1500
1501
1502 pprInstr g@(GSUB sz src1 src2 dst)
1503    | src1 == dst
1504    = pprG g (text "\t#GSUB-xxxcase1" $$
1505              hcat [gtab, gpush src2 0,
1506                    text " ; fsubrp %st(0),", greg src1 1])
1507    | src2 == dst
1508    = pprG g (text "\t#GSUB-xxxcase2" $$
1509              hcat [gtab, gpush src1 0,
1510                    text " ; fsubp %st(0),", greg src2 1])
1511    | otherwise
1512    = pprG g (hcat [gtab, gpush src1 0,
1513                    text " ; fsub ", greg src2 1, text ",%st(0)",
1514                    gsemi, gpop dst 1])
1515
1516
1517 pprInstr g@(GDIV sz src1 src2 dst)
1518    | src1 == dst
1519    = pprG g (text "\t#GDIV-xxxcase1" $$
1520              hcat [gtab, gpush src2 0,
1521                    text " ; fdivrp %st(0),", greg src1 1])
1522    | src2 == dst
1523    = pprG g (text "\t#GDIV-xxxcase2" $$
1524              hcat [gtab, gpush src1 0,
1525                    text " ; fdivp %st(0),", greg src2 1])
1526    | otherwise
1527    = pprG g (hcat [gtab, gpush src1 0,
1528                    text " ; fdiv ", greg src2 1, text ",%st(0)",
1529                    gsemi, gpop dst 1])
1530
1531
1532 pprInstr GFREE
1533    = vcat [ ptext SLIT("\tffree %st(0) ;ffree %st(1) ;ffree %st(2) ;ffree %st(3)"),
1534             ptext SLIT("\tffree %st(4) ;ffree %st(5) ;ffree %st(6) ;ffree %st(7)")
1535           ]
1536
1537 --------------------------
1538
1539 -- coerce %st(0) to the specified size
1540 gcoerceto F64 = empty
1541 gcoerceto F32 = empty --text "subl $4,%esp ; fstps (%esp) ; flds (%esp) ; addl $4,%esp ; "
1542
1543 gpush reg offset
1544    = hcat [text "ffree %st(7) ; fld ", greg reg offset]
1545 gpop reg offset
1546    = hcat [text "fstp ", greg reg offset]
1547
1548 greg reg offset = text "%st(" <> int (gregno reg - 8+offset) <> char ')'
1549 gsemi = text " ; "
1550 gtab  = char '\t'
1551 gsp   = char ' '
1552
1553 gregno (RealReg i) = i
1554 gregno other       = --pprPanic "gregno" (ppr other)
1555                      999   -- bogus; only needed for debug printing
1556
1557 pprG :: Instr -> Doc -> Doc
1558 pprG fake actual
1559    = (char '#' <> pprGInstr fake) $$ actual
1560
1561 pprGInstr (GMOV src dst)   = pprSizeRegReg SLIT("gmov") F64 src dst
1562 pprGInstr (GLD sz src dst) = pprSizeAddrReg SLIT("gld") sz src dst
1563 pprGInstr (GST sz src dst) = pprSizeRegAddr SLIT("gst") sz src dst
1564
1565 pprGInstr (GLDZ dst) = pprSizeReg SLIT("gldz") F64 dst
1566 pprGInstr (GLD1 dst) = pprSizeReg SLIT("gld1") F64 dst
1567
1568 pprGInstr (GFTOI src dst) = pprSizeSizeRegReg SLIT("gftoi") F32 I32  src dst
1569 pprGInstr (GDTOI src dst) = pprSizeSizeRegReg SLIT("gdtoi") F64 I32 src dst
1570
1571 pprGInstr (GITOF src dst) = pprSizeSizeRegReg SLIT("gitof") I32 F32  src dst
1572 pprGInstr (GITOD src dst) = pprSizeSizeRegReg SLIT("gitod") I32 F64 src dst
1573
1574 pprGInstr (GCMP co src dst) = pprCondRegReg SLIT("gcmp_") F64 co src dst
1575 pprGInstr (GABS sz src dst) = pprSizeRegReg SLIT("gabs") sz src dst
1576 pprGInstr (GNEG sz src dst) = pprSizeRegReg SLIT("gneg") sz src dst
1577 pprGInstr (GSQRT sz src dst) = pprSizeRegReg SLIT("gsqrt") sz src dst
1578 pprGInstr (GSIN sz src dst) = pprSizeRegReg SLIT("gsin") sz src dst
1579 pprGInstr (GCOS sz src dst) = pprSizeRegReg SLIT("gcos") sz src dst
1580 pprGInstr (GTAN sz src dst) = pprSizeRegReg SLIT("gtan") sz src dst
1581
1582 pprGInstr (GADD sz src1 src2 dst) = pprSizeRegRegReg SLIT("gadd") sz src1 src2 dst
1583 pprGInstr (GSUB sz src1 src2 dst) = pprSizeRegRegReg SLIT("gsub") sz src1 src2 dst
1584 pprGInstr (GMUL sz src1 src2 dst) = pprSizeRegRegReg SLIT("gmul") sz src1 src2 dst
1585 pprGInstr (GDIV sz src1 src2 dst) = pprSizeRegRegReg SLIT("gdiv") sz src1 src2 dst
1586 #endif
1587
1588 #if i386_TARGET_ARCH || x86_64_TARGET_ARCH
1589
1590 -- Continue with I386-only printing bits and bobs:
1591
1592 pprDollImm :: Imm -> Doc
1593
1594 pprDollImm i =  ptext SLIT("$") <> pprImm i
1595
1596 pprOperand :: MachRep -> Operand -> Doc
1597 pprOperand s (OpReg r)   = pprReg s r
1598 pprOperand s (OpImm i)   = pprDollImm i
1599 pprOperand s (OpAddr ea) = pprAddr ea
1600
1601 pprMnemonic_  :: LitString -> Doc
1602 pprMnemonic_ name =
1603    char '\t' <> ptext name <> space
1604
1605 pprMnemonic  :: LitString -> MachRep -> Doc
1606 pprMnemonic name size =
1607    char '\t' <> ptext name <> pprSize size <> space
1608
1609 pprSizeImmOp :: LitString -> MachRep -> Imm -> Operand -> Doc
1610 pprSizeImmOp name size imm op1
1611   = hcat [
1612         pprMnemonic name size,
1613         char '$',
1614         pprImm imm,
1615         comma,
1616         pprOperand size op1
1617     ]
1618
1619 pprSizeOp :: LitString -> MachRep -> Operand -> Doc
1620 pprSizeOp name size op1
1621   = hcat [
1622         pprMnemonic name size,
1623         pprOperand size op1
1624     ]
1625
1626 pprSizeOpOp :: LitString -> MachRep -> Operand -> Operand -> Doc
1627 pprSizeOpOp name size op1 op2
1628   = hcat [
1629         pprMnemonic name size,
1630         pprOperand size op1,
1631         comma,
1632         pprOperand size op2
1633     ]
1634
1635 pprOpOp :: LitString -> MachRep -> Operand -> Operand -> Doc
1636 pprOpOp name size op1 op2
1637   = hcat [
1638         pprMnemonic_ name,
1639         pprOperand size op1,
1640         comma,
1641         pprOperand size op2
1642     ]
1643
1644 pprSizeReg :: LitString -> MachRep -> Reg -> Doc
1645 pprSizeReg name size reg1
1646   = hcat [
1647         pprMnemonic name size,
1648         pprReg size reg1
1649     ]
1650
1651 pprSizeRegReg :: LitString -> MachRep -> Reg -> Reg -> Doc
1652 pprSizeRegReg name size reg1 reg2
1653   = hcat [
1654         pprMnemonic name size,
1655         pprReg size reg1,
1656         comma,
1657         pprReg size reg2
1658     ]
1659
1660 pprRegReg :: LitString -> Reg -> Reg -> Doc
1661 pprRegReg name reg1 reg2
1662   = hcat [
1663         pprMnemonic_ name,
1664         pprReg wordRep reg1,
1665         comma,
1666         pprReg wordRep reg2
1667     ]
1668
1669 pprOpReg :: LitString -> Operand -> Reg -> Doc
1670 pprOpReg name op1 reg2
1671   = hcat [
1672         pprMnemonic_ name,
1673         pprOperand wordRep op1,
1674         comma,
1675         pprReg wordRep reg2
1676     ]
1677
1678 pprCondRegReg :: LitString -> MachRep -> Cond -> Reg -> Reg -> Doc
1679 pprCondRegReg name size cond reg1 reg2
1680   = hcat [
1681         char '\t',
1682         ptext name,
1683         pprCond cond,
1684         space,
1685         pprReg size reg1,
1686         comma,
1687         pprReg size reg2
1688     ]
1689
1690 pprSizeSizeRegReg :: LitString -> MachRep -> MachRep -> Reg -> Reg -> Doc
1691 pprSizeSizeRegReg name size1 size2 reg1 reg2
1692   = hcat [
1693         char '\t',
1694         ptext name,
1695         pprSize size1,
1696         pprSize size2,
1697         space,
1698         pprReg size1 reg1,
1699
1700         comma,
1701         pprReg size2 reg2
1702     ]
1703
1704 pprSizeRegRegReg :: LitString -> MachRep -> Reg -> Reg -> Reg -> Doc
1705 pprSizeRegRegReg name size reg1 reg2 reg3
1706   = hcat [
1707         pprMnemonic name size,
1708         pprReg size reg1,
1709         comma,
1710         pprReg size reg2,
1711         comma,
1712         pprReg size reg3
1713     ]
1714
1715 pprSizeAddrReg :: LitString -> MachRep -> AddrMode -> Reg -> Doc
1716 pprSizeAddrReg name size op dst
1717   = hcat [
1718         pprMnemonic name size,
1719         pprAddr op,
1720         comma,
1721         pprReg size dst
1722     ]
1723
1724 pprSizeRegAddr :: LitString -> MachRep -> Reg -> AddrMode -> Doc
1725 pprSizeRegAddr name size src op
1726   = hcat [
1727         pprMnemonic name size,
1728         pprReg size src,
1729         comma,
1730         pprAddr op
1731     ]
1732
1733 pprShift :: LitString -> MachRep -> Operand -> Operand -> Doc
1734 pprShift name size src dest
1735   = hcat [
1736         pprMnemonic name size,
1737         pprOperand I8 src,  -- src is 8-bit sized
1738         comma,
1739         pprOperand size dest
1740     ]
1741
1742 pprSizeOpOpCoerce :: LitString -> MachRep -> MachRep -> Operand -> Operand -> Doc
1743 pprSizeOpOpCoerce name size1 size2 op1 op2
1744   = hcat [ char '\t', ptext name, pprSize size1, pprSize size2, space,
1745         pprOperand size1 op1,
1746         comma,
1747         pprOperand size2 op2
1748     ]
1749
1750 pprCondInstr :: LitString -> Cond -> Doc -> Doc
1751 pprCondInstr name cond arg
1752   = hcat [ char '\t', ptext name, pprCond cond, space, arg]
1753
1754 #endif /* i386_TARGET_ARCH */
1755
1756
1757 -- ------------------------------------------------------------------------------- pprInstr for a SPARC
1758
1759 #if sparc_TARGET_ARCH
1760
1761 -- a clumsy hack for now, to handle possible double alignment problems
1762
1763 -- even clumsier, to allow for RegReg regs that show when doing indexed
1764 -- reads (bytearrays).
1765 --
1766
1767 -- Translate to the following:
1768 --    add g1,g2,g1
1769 --    ld  [g1],%fn
1770 --    ld  [g1+4],%f(n+1)
1771 --    sub g1,g2,g1           -- to restore g1
1772
1773 pprInstr (LD F64 (AddrRegReg g1 g2) reg)
1774   = vcat [
1775        hcat [ptext SLIT("\tadd\t"), pprReg g1,comma,pprReg g2,comma,pprReg g1],
1776        hcat [pp_ld_lbracket, pprReg g1, pp_rbracket_comma, pprReg reg],
1777        hcat [pp_ld_lbracket, pprReg g1, ptext SLIT("+4]"), comma, pprReg (fPair reg)],
1778        hcat [ptext SLIT("\tsub\t"), pprReg g1,comma,pprReg g2,comma,pprReg g1]
1779     ]
1780
1781 -- Translate to
1782 --    ld  [addr],%fn
1783 --    ld  [addr+4],%f(n+1)
1784 pprInstr (LD F64 addr reg) | isJust off_addr
1785   = vcat [
1786        hcat [pp_ld_lbracket, pprAddr addr, pp_rbracket_comma, pprReg reg],
1787        hcat [pp_ld_lbracket, pprAddr addr2, pp_rbracket_comma,pprReg (fPair reg)]
1788     ]
1789   where
1790     off_addr = addrOffset addr 4
1791     addr2 = case off_addr of Just x -> x
1792
1793
1794 pprInstr (LD size addr reg)
1795   = hcat [
1796        ptext SLIT("\tld"),
1797        pprSize size,
1798        char '\t',
1799        lbrack,
1800        pprAddr addr,
1801        pp_rbracket_comma,
1802        pprReg reg
1803     ]
1804
1805 -- The same clumsy hack as above
1806
1807 -- Translate to the following:
1808 --    add g1,g2,g1
1809 --    st  %fn,[g1]
1810 --    st  %f(n+1),[g1+4]
1811 --    sub g1,g2,g1           -- to restore g1
1812 pprInstr (ST F64 reg (AddrRegReg g1 g2))
1813  = vcat [
1814        hcat [ptext SLIT("\tadd\t"), pprReg g1,comma,pprReg g2,comma,pprReg g1],
1815        hcat [ptext SLIT("\tst\t"), pprReg reg, pp_comma_lbracket,
1816              pprReg g1, rbrack],
1817        hcat [ptext SLIT("\tst\t"), pprReg (fPair reg), pp_comma_lbracket,
1818              pprReg g1, ptext SLIT("+4]")],
1819        hcat [ptext SLIT("\tsub\t"), pprReg g1,comma,pprReg g2,comma,pprReg g1]
1820     ]
1821
1822 -- Translate to
1823 --    st  %fn,[addr]
1824 --    st  %f(n+1),[addr+4]
1825 pprInstr (ST F64 reg addr) | isJust off_addr
1826  = vcat [
1827       hcat [ptext SLIT("\tst\t"), pprReg reg, pp_comma_lbracket,
1828             pprAddr addr, rbrack],
1829       hcat [ptext SLIT("\tst\t"), pprReg (fPair reg), pp_comma_lbracket,
1830             pprAddr addr2, rbrack]
1831     ]
1832   where
1833     off_addr = addrOffset addr 4
1834     addr2 = case off_addr of Just x -> x
1835
1836 -- no distinction is made between signed and unsigned bytes on stores for the
1837 -- Sparc opcodes (at least I cannot see any, and gas is nagging me --SOF),
1838 -- so we call a special-purpose pprSize for ST..
1839
1840 pprInstr (ST size reg addr)
1841   = hcat [
1842        ptext SLIT("\tst"),
1843        pprStSize size,
1844        char '\t',
1845        pprReg reg,
1846        pp_comma_lbracket,
1847        pprAddr addr,
1848        rbrack
1849     ]
1850
1851 pprInstr (ADD x cc reg1 ri reg2)
1852   | not x && not cc && riZero ri
1853   = hcat [ ptext SLIT("\tmov\t"), pprReg reg1, comma, pprReg reg2 ]
1854   | otherwise
1855   = pprRegRIReg (if x then SLIT("addx") else SLIT("add")) cc reg1 ri reg2
1856
1857 pprInstr (SUB x cc reg1 ri reg2)
1858   | not x && cc && reg2 == g0
1859   = hcat [ ptext SLIT("\tcmp\t"), pprReg reg1, comma, pprRI ri ]
1860   | not x && not cc && riZero ri
1861   = hcat [ ptext SLIT("\tmov\t"), pprReg reg1, comma, pprReg reg2 ]
1862   | otherwise
1863   = pprRegRIReg (if x then SLIT("subx") else SLIT("sub")) cc reg1 ri reg2
1864
1865 pprInstr (AND  b reg1 ri reg2) = pprRegRIReg SLIT("and")  b reg1 ri reg2
1866 pprInstr (ANDN b reg1 ri reg2) = pprRegRIReg SLIT("andn") b reg1 ri reg2
1867
1868 pprInstr (OR b reg1 ri reg2)
1869   | not b && reg1 == g0
1870   = let doit = hcat [ ptext SLIT("\tmov\t"), pprRI ri, comma, pprReg reg2 ]
1871     in  case ri of
1872            RIReg rrr | rrr == reg2 -> empty
1873            other                   -> doit
1874   | otherwise
1875   = pprRegRIReg SLIT("or") b reg1 ri reg2
1876
1877 pprInstr (ORN b reg1 ri reg2) = pprRegRIReg SLIT("orn") b reg1 ri reg2
1878
1879 pprInstr (XOR  b reg1 ri reg2) = pprRegRIReg SLIT("xor")  b reg1 ri reg2
1880 pprInstr (XNOR b reg1 ri reg2) = pprRegRIReg SLIT("xnor") b reg1 ri reg2
1881
1882 pprInstr (SLL reg1 ri reg2) = pprRegRIReg SLIT("sll") False reg1 ri reg2
1883 pprInstr (SRL reg1 ri reg2) = pprRegRIReg SLIT("srl") False reg1 ri reg2
1884 pprInstr (SRA reg1 ri reg2) = pprRegRIReg SLIT("sra") False reg1 ri reg2
1885
1886 pprInstr (RDY rd) = ptext SLIT("\trd\t%y,") <> pprReg rd
1887 pprInstr (SMUL b reg1 ri reg2) = pprRegRIReg SLIT("smul")  b reg1 ri reg2
1888 pprInstr (UMUL b reg1 ri reg2) = pprRegRIReg SLIT("umul")  b reg1 ri reg2
1889
1890 pprInstr (SETHI imm reg)
1891   = hcat [
1892         ptext SLIT("\tsethi\t"),
1893         pprImm imm,
1894         comma,
1895         pprReg reg
1896     ]
1897
1898 pprInstr NOP = ptext SLIT("\tnop")
1899
1900 pprInstr (FABS F32 reg1 reg2) = pprSizeRegReg SLIT("fabs") F32 reg1 reg2
1901 pprInstr (FABS F64 reg1 reg2)
1902   = (<>) (pprSizeRegReg SLIT("fabs") F32 reg1 reg2)
1903     (if (reg1 == reg2) then empty
1904      else (<>) (char '\n')
1905           (pprSizeRegReg SLIT("fmov") F32 (fPair reg1) (fPair reg2)))
1906
1907 pprInstr (FADD size reg1 reg2 reg3)
1908   = pprSizeRegRegReg SLIT("fadd") size reg1 reg2 reg3
1909 pprInstr (FCMP e size reg1 reg2)
1910   = pprSizeRegReg (if e then SLIT("fcmpe") else SLIT("fcmp")) size reg1 reg2
1911 pprInstr (FDIV size reg1 reg2 reg3)
1912   = pprSizeRegRegReg SLIT("fdiv") size reg1 reg2 reg3
1913
1914 pprInstr (FMOV F32 reg1 reg2) = pprSizeRegReg SLIT("fmov") F32 reg1 reg2
1915 pprInstr (FMOV F64 reg1 reg2)
1916   = (<>) (pprSizeRegReg SLIT("fmov") F32 reg1 reg2)
1917     (if (reg1 == reg2) then empty
1918      else (<>) (char '\n')
1919           (pprSizeRegReg SLIT("fmov") F32 (fPair reg1) (fPair reg2)))
1920
1921 pprInstr (FMUL size reg1 reg2 reg3)
1922   = pprSizeRegRegReg SLIT("fmul") size reg1 reg2 reg3
1923
1924 pprInstr (FNEG F32 reg1 reg2) = pprSizeRegReg SLIT("fneg") F32 reg1 reg2
1925 pprInstr (FNEG F64 reg1 reg2)
1926   = (<>) (pprSizeRegReg SLIT("fneg") F32 reg1 reg2)
1927     (if (reg1 == reg2) then empty
1928      else (<>) (char '\n')
1929           (pprSizeRegReg SLIT("fmov") F32 (fPair reg1) (fPair reg2)))
1930
1931 pprInstr (FSQRT size reg1 reg2)     = pprSizeRegReg SLIT("fsqrt") size reg1 reg2
1932 pprInstr (FSUB size reg1 reg2 reg3) = pprSizeRegRegReg SLIT("fsub") size reg1 reg2 reg3
1933 pprInstr (FxTOy size1 size2 reg1 reg2)
1934   = hcat [
1935         ptext SLIT("\tf"),
1936         ptext
1937         (case size1 of
1938             I32  -> SLIT("ito")
1939             F32  -> SLIT("sto")
1940             F64  -> SLIT("dto")),
1941         ptext
1942         (case size2 of
1943             I32  -> SLIT("i\t")
1944             F32  -> SLIT("s\t")
1945             F64  -> SLIT("d\t")),
1946         pprReg reg1, comma, pprReg reg2
1947     ]
1948
1949
1950 pprInstr (BI cond b lab)
1951   = hcat [
1952         ptext SLIT("\tb"), pprCond cond,
1953         if b then pp_comma_a else empty,
1954         char '\t',
1955         pprImm lab
1956     ]
1957
1958 pprInstr (BF cond b lab)
1959   = hcat [
1960         ptext SLIT("\tfb"), pprCond cond,
1961         if b then pp_comma_a else empty,
1962         char '\t',
1963         pprImm lab
1964     ]
1965
1966 pprInstr (JMP addr) = (<>) (ptext SLIT("\tjmp\t")) (pprAddr addr)
1967
1968 pprInstr (CALL (Left imm) n _)
1969   = hcat [ ptext SLIT("\tcall\t"), pprImm imm, comma, int n ]
1970 pprInstr (CALL (Right reg) n _)
1971   = hcat [ ptext SLIT("\tcall\t"), pprReg reg, comma, int n ]
1972
1973 pprRI :: RI -> Doc
1974 pprRI (RIReg r) = pprReg r
1975 pprRI (RIImm r) = pprImm r
1976
1977 pprSizeRegReg :: LitString -> MachRep -> Reg -> Reg -> Doc
1978 pprSizeRegReg name size reg1 reg2
1979   = hcat [
1980         char '\t',
1981         ptext name,
1982         (case size of
1983             F32  -> ptext SLIT("s\t")
1984             F64 -> ptext SLIT("d\t")),
1985         pprReg reg1,
1986         comma,
1987         pprReg reg2
1988     ]
1989
1990 pprSizeRegRegReg :: LitString -> MachRep -> Reg -> Reg -> Reg -> Doc
1991 pprSizeRegRegReg name size reg1 reg2 reg3
1992   = hcat [
1993         char '\t',
1994         ptext name,
1995         (case size of
1996             F32  -> ptext SLIT("s\t")
1997             F64  -> ptext SLIT("d\t")),
1998         pprReg reg1,
1999         comma,
2000         pprReg reg2,
2001         comma,
2002         pprReg reg3
2003     ]
2004
2005 pprRegRIReg :: LitString -> Bool -> Reg -> RI -> Reg -> Doc
2006 pprRegRIReg name b reg1 ri reg2
2007   = hcat [
2008         char '\t',
2009         ptext name,
2010         if b then ptext SLIT("cc\t") else char '\t',
2011         pprReg reg1,
2012         comma,
2013         pprRI ri,
2014         comma,
2015         pprReg reg2
2016     ]
2017
2018 pprRIReg :: LitString -> Bool -> RI -> Reg -> Doc
2019 pprRIReg name b ri reg1
2020   = hcat [
2021         char '\t',
2022         ptext name,
2023         if b then ptext SLIT("cc\t") else char '\t',
2024         pprRI ri,
2025         comma,
2026         pprReg reg1
2027     ]
2028
2029 pp_ld_lbracket    = ptext SLIT("\tld\t[")
2030 pp_rbracket_comma = text "],"
2031 pp_comma_lbracket = text ",["
2032 pp_comma_a        = text ",a"
2033
2034 #endif /* sparc_TARGET_ARCH */
2035
2036
2037 -- -----------------------------------------------------------------------------
2038 -- pprInstr for PowerPC
2039
2040 #if powerpc_TARGET_ARCH
2041 pprInstr (LD sz reg addr) = hcat [
2042         char '\t',
2043         ptext SLIT("l"),
2044         ptext (case sz of
2045             I8  -> SLIT("bz")
2046             I16 -> SLIT("hz")
2047             I32 -> SLIT("wz")
2048             F32 -> SLIT("fs")
2049             F64 -> SLIT("fd")),
2050         case addr of AddrRegImm _ _ -> empty
2051                      AddrRegReg _ _ -> char 'x',
2052         char '\t',
2053         pprReg reg,
2054         ptext SLIT(", "),
2055         pprAddr addr
2056     ]
2057 pprInstr (LA sz reg addr) = hcat [
2058         char '\t',
2059         ptext SLIT("l"),
2060         ptext (case sz of
2061             I8  -> SLIT("ba")
2062             I16 -> SLIT("ha")
2063             I32 -> SLIT("wa")
2064             F32 -> SLIT("fs")
2065             F64 -> SLIT("fd")),
2066         case addr of AddrRegImm _ _ -> empty
2067                      AddrRegReg _ _ -> char 'x',
2068         char '\t',
2069         pprReg reg,
2070         ptext SLIT(", "),
2071         pprAddr addr
2072     ]
2073 pprInstr (ST sz reg addr) = hcat [
2074         char '\t',
2075         ptext SLIT("st"),
2076         pprSize sz,
2077         case addr of AddrRegImm _ _ -> empty
2078                      AddrRegReg _ _ -> char 'x',
2079         char '\t',
2080         pprReg reg,
2081         ptext SLIT(", "),
2082         pprAddr addr
2083     ]
2084 pprInstr (STU sz reg addr) = hcat [
2085         char '\t',
2086         ptext SLIT("st"),
2087         pprSize sz,
2088         ptext SLIT("u\t"),
2089         case addr of AddrRegImm _ _ -> empty
2090                      AddrRegReg _ _ -> char 'x',
2091         pprReg reg,
2092         ptext SLIT(", "),
2093         pprAddr addr
2094     ]
2095 pprInstr (LIS reg imm) = hcat [
2096         char '\t',
2097         ptext SLIT("lis"),
2098         char '\t',
2099         pprReg reg,
2100         ptext SLIT(", "),
2101         pprImm imm
2102     ]
2103 pprInstr (LI reg imm) = hcat [
2104         char '\t',
2105         ptext SLIT("li"),
2106         char '\t',
2107         pprReg reg,
2108         ptext SLIT(", "),
2109         pprImm imm
2110     ]
2111 pprInstr (MR reg1 reg2)
2112     | reg1 == reg2 = empty
2113     | otherwise = hcat [
2114         char '\t',
2115         case regClass reg1 of
2116             RcInteger -> ptext SLIT("mr")
2117             _ -> ptext SLIT("fmr"),
2118         char '\t',
2119         pprReg reg1,
2120         ptext SLIT(", "),
2121         pprReg reg2
2122     ]
2123 pprInstr (CMP sz reg ri) = hcat [
2124         char '\t',
2125         op,
2126         char '\t',
2127         pprReg reg,
2128         ptext SLIT(", "),
2129         pprRI ri
2130     ]
2131     where
2132         op = hcat [
2133                 ptext SLIT("cmp"),
2134                 pprSize sz,
2135                 case ri of
2136                     RIReg _ -> empty
2137                     RIImm _ -> char 'i'
2138             ]
2139 pprInstr (CMPL sz reg ri) = hcat [
2140         char '\t',
2141         op,
2142         char '\t',
2143         pprReg reg,
2144         ptext SLIT(", "),
2145         pprRI ri
2146     ]
2147     where
2148         op = hcat [
2149                 ptext SLIT("cmpl"),
2150                 pprSize sz,
2151                 case ri of
2152                     RIReg _ -> empty
2153                     RIImm _ -> char 'i'
2154             ]
2155 pprInstr (BCC cond (BlockId id)) = hcat [
2156         char '\t',
2157         ptext SLIT("b"),
2158         pprCond cond,
2159         char '\t',
2160         pprCLabel_asm lbl
2161     ]
2162     where lbl = mkAsmTempLabel id
2163
2164 pprInstr (JMP lbl) = hcat [ -- an alias for b that takes a CLabel
2165         char '\t',
2166         ptext SLIT("b"),
2167         char '\t',
2168         pprCLabel_asm lbl
2169     ]
2170
2171 pprInstr (MTCTR reg) = hcat [
2172         char '\t',
2173         ptext SLIT("mtctr"),
2174         char '\t',
2175         pprReg reg
2176     ]
2177 pprInstr (BCTR _) = hcat [
2178         char '\t',
2179         ptext SLIT("bctr")
2180     ]
2181 pprInstr (BL lbl _) = hcat [
2182         ptext SLIT("\tbl\t"),
2183         pprCLabel_asm lbl
2184     ]
2185 pprInstr (BCTRL _) = hcat [
2186         char '\t',
2187         ptext SLIT("bctrl")
2188     ]
2189 pprInstr (ADD reg1 reg2 ri) = pprLogic SLIT("add") reg1 reg2 ri
2190 pprInstr (ADDIS reg1 reg2 imm) = hcat [
2191         char '\t',
2192         ptext SLIT("addis"),
2193         char '\t',
2194         pprReg reg1,
2195         ptext SLIT(", "),
2196         pprReg reg2,
2197         ptext SLIT(", "),
2198         pprImm imm
2199     ]
2200
2201 pprInstr (ADDC reg1 reg2 reg3) = pprLogic SLIT("addc") reg1 reg2 (RIReg reg3)
2202 pprInstr (ADDE reg1 reg2 reg3) = pprLogic SLIT("adde") reg1 reg2 (RIReg reg3)
2203 pprInstr (SUBF reg1 reg2 reg3) = pprLogic SLIT("subf") reg1 reg2 (RIReg reg3)
2204 pprInstr (MULLW reg1 reg2 ri@(RIReg _)) = pprLogic SLIT("mullw") reg1 reg2 ri
2205 pprInstr (MULLW reg1 reg2 ri@(RIImm _)) = pprLogic SLIT("mull") reg1 reg2 ri
2206 pprInstr (DIVW reg1 reg2 reg3) = pprLogic SLIT("divw") reg1 reg2 (RIReg reg3)
2207 pprInstr (DIVWU reg1 reg2 reg3) = pprLogic SLIT("divwu") reg1 reg2 (RIReg reg3)
2208
2209 pprInstr (MULLW_MayOflo reg1 reg2 reg3) = vcat [
2210          hcat [ ptext SLIT("\tmullwo\t"), pprReg reg1, ptext SLIT(", "),
2211                                           pprReg reg2, ptext SLIT(", "),
2212                                           pprReg reg3 ],
2213          hcat [ ptext SLIT("\tmfxer\t"),  pprReg reg1 ],
2214          hcat [ ptext SLIT("\trlwinm\t"), pprReg reg1, ptext SLIT(", "),
2215                                           pprReg reg1, ptext SLIT(", "),
2216                                           ptext SLIT("2, 31, 31") ]
2217     ]
2218
2219         -- for some reason, "andi" doesn't exist.
2220         -- we'll use "andi." instead.
2221 pprInstr (AND reg1 reg2 (RIImm imm)) = hcat [
2222         char '\t',
2223         ptext SLIT("andi."),
2224         char '\t',
2225         pprReg reg1,
2226         ptext SLIT(", "),
2227         pprReg reg2,
2228         ptext SLIT(", "),
2229         pprImm imm
2230     ]
2231 pprInstr (AND reg1 reg2 ri) = pprLogic SLIT("and") reg1 reg2 ri
2232
2233 pprInstr (OR reg1 reg2 ri) = pprLogic SLIT("or") reg1 reg2 ri
2234 pprInstr (XOR reg1 reg2 ri) = pprLogic SLIT("xor") reg1 reg2 ri
2235
2236 pprInstr (XORIS reg1 reg2 imm) = hcat [
2237         char '\t',
2238         ptext SLIT("xoris"),
2239         char '\t',
2240         pprReg reg1,
2241         ptext SLIT(", "),
2242         pprReg reg2,
2243         ptext SLIT(", "),
2244         pprImm imm
2245     ]
2246
2247 pprInstr (EXTS sz reg1 reg2) = hcat [
2248         char '\t',
2249         ptext SLIT("exts"),
2250         pprSize sz,
2251         char '\t',
2252         pprReg reg1,
2253         ptext SLIT(", "),
2254         pprReg reg2
2255     ]
2256
2257 pprInstr (NEG reg1 reg2) = pprUnary SLIT("neg") reg1 reg2
2258 pprInstr (NOT reg1 reg2) = pprUnary SLIT("not") reg1 reg2
2259
2260 pprInstr (SLW reg1 reg2 ri) = pprLogic SLIT("slw") reg1 reg2 (limitShiftRI ri)
2261 pprInstr (SRW reg1 reg2 ri) = pprLogic SLIT("srw") reg1 reg2 (limitShiftRI ri)
2262 pprInstr (SRAW reg1 reg2 ri) = pprLogic SLIT("sraw") reg1 reg2 (limitShiftRI ri)
2263 pprInstr (RLWINM reg1 reg2 sh mb me) = hcat [
2264         ptext SLIT("\trlwinm\t"),
2265         pprReg reg1,
2266         ptext SLIT(", "),
2267         pprReg reg2,
2268         ptext SLIT(", "),
2269         int sh,
2270         ptext SLIT(", "),
2271         int mb,
2272         ptext SLIT(", "),
2273         int me
2274     ]
2275
2276 pprInstr (FADD sz reg1 reg2 reg3) = pprBinaryF SLIT("fadd") sz reg1 reg2 reg3
2277 pprInstr (FSUB sz reg1 reg2 reg3) = pprBinaryF SLIT("fsub") sz reg1 reg2 reg3
2278 pprInstr (FMUL sz reg1 reg2 reg3) = pprBinaryF SLIT("fmul") sz reg1 reg2 reg3
2279 pprInstr (FDIV sz reg1 reg2 reg3) = pprBinaryF SLIT("fdiv") sz reg1 reg2 reg3
2280 pprInstr (FNEG reg1 reg2) = pprUnary SLIT("fneg") reg1 reg2
2281
2282 pprInstr (FCMP reg1 reg2) = hcat [
2283         char '\t',
2284         ptext SLIT("fcmpu\tcr0, "),
2285             -- Note: we're using fcmpu, not fcmpo
2286             -- The difference is with fcmpo, compare with NaN is an invalid operation.
2287             -- We don't handle invalid fp ops, so we don't care
2288         pprReg reg1,
2289         ptext SLIT(", "),
2290         pprReg reg2
2291     ]
2292
2293 pprInstr (FCTIWZ reg1 reg2) = pprUnary SLIT("fctiwz") reg1 reg2
2294 pprInstr (FRSP reg1 reg2) = pprUnary SLIT("frsp") reg1 reg2
2295
2296 pprInstr (CRNOR dst src1 src2) = hcat [
2297         ptext SLIT("\tcrnor\t"),
2298         int dst,
2299         ptext SLIT(", "),
2300         int src1,
2301         ptext SLIT(", "),
2302         int src2
2303     ]
2304
2305 pprInstr (MFCR reg) = hcat [
2306         char '\t',
2307         ptext SLIT("mfcr"),
2308         char '\t',
2309         pprReg reg
2310     ]
2311
2312 pprInstr (MFLR reg) = hcat [
2313         char '\t',
2314         ptext SLIT("mflr"),
2315         char '\t',
2316         pprReg reg
2317     ]
2318
2319 pprInstr (FETCHPC reg) = vcat [
2320         ptext SLIT("\tbcl\t20,31,1f"),
2321         hcat [ ptext SLIT("1:\tmflr\t"), pprReg reg ]
2322     ]
2323
2324 pprInstr _ = panic "pprInstr (ppc)"
2325
2326 pprLogic op reg1 reg2 ri = hcat [
2327         char '\t',
2328         ptext op,
2329         case ri of
2330             RIReg _ -> empty
2331             RIImm _ -> char 'i',
2332         char '\t',
2333         pprReg reg1,
2334         ptext SLIT(", "),
2335         pprReg reg2,
2336         ptext SLIT(", "),
2337         pprRI ri
2338     ]
2339
2340 pprUnary op reg1 reg2 = hcat [
2341         char '\t',
2342         ptext op,
2343         char '\t',
2344         pprReg reg1,
2345         ptext SLIT(", "),
2346         pprReg reg2
2347     ]
2348
2349 pprBinaryF op sz reg1 reg2 reg3 = hcat [
2350         char '\t',
2351         ptext op,
2352         pprFSize sz,
2353         char '\t',
2354         pprReg reg1,
2355         ptext SLIT(", "),
2356         pprReg reg2,
2357         ptext SLIT(", "),
2358         pprReg reg3
2359     ]
2360
2361 pprRI :: RI -> Doc
2362 pprRI (RIReg r) = pprReg r
2363 pprRI (RIImm r) = pprImm r
2364
2365 pprFSize F64 = empty
2366 pprFSize F32 = char 's'
2367
2368     -- limit immediate argument for shift instruction to range 0..32
2369     -- (yes, the maximum is really 32, not 31)
2370 limitShiftRI :: RI -> RI
2371 limitShiftRI (RIImm (ImmInt i)) | i > 32 || i < 0 = RIImm (ImmInt 32)
2372 limitShiftRI x = x
2373
2374 #endif /* powerpc_TARGET_ARCH */
2375
2376
2377 -- -----------------------------------------------------------------------------
2378 -- Converting floating-point literals to integrals for printing
2379
2380 #if __GLASGOW_HASKELL__ >= 504
2381 newFloatArray :: (Int,Int) -> ST s (STUArray s Int Float)
2382 newFloatArray = newArray_
2383
2384 newDoubleArray :: (Int,Int) -> ST s (STUArray s Int Double)
2385 newDoubleArray = newArray_
2386
2387 castFloatToCharArray :: STUArray s Int Float -> ST s (STUArray s Int Word8)
2388 castFloatToCharArray = castSTUArray
2389
2390 castDoubleToCharArray :: STUArray s Int Double -> ST s (STUArray s Int Word8)
2391 castDoubleToCharArray = castSTUArray
2392
2393 writeFloatArray :: STUArray s Int Float -> Int -> Float -> ST s ()
2394 writeFloatArray = writeArray
2395
2396 writeDoubleArray :: STUArray s Int Double -> Int -> Double -> ST s ()
2397 writeDoubleArray = writeArray
2398
2399 readCharArray :: STUArray s Int Word8 -> Int -> ST s Char
2400 readCharArray arr i = do
2401   w <- readArray arr i
2402   return $! (chr (fromIntegral w))
2403
2404 #else
2405
2406 castFloatToCharArray :: MutableByteArray s t -> ST s (MutableByteArray s t)
2407 castFloatToCharArray = return
2408
2409 castDoubleToCharArray :: MutableByteArray s t -> ST s (MutableByteArray s t)
2410
2411
2412 castDoubleToCharArray = return
2413
2414 #endif
2415
2416 -- floatToBytes and doubleToBytes convert to the host's byte
2417 -- order.  Providing that we're not cross-compiling for a
2418 -- target with the opposite endianness, this should work ok
2419 -- on all targets.
2420
2421 -- ToDo: this stuff is very similar to the shenanigans in PprAbs,
2422 -- could they be merged?
2423
2424 floatToBytes :: Float -> [Int]
2425 floatToBytes f
2426    = runST (do
2427         arr <- newFloatArray ((0::Int),3)
2428         writeFloatArray arr 0 f
2429         arr <- castFloatToCharArray arr
2430         i0 <- readCharArray arr 0
2431         i1 <- readCharArray arr 1
2432         i2 <- readCharArray arr 2
2433         i3 <- readCharArray arr 3
2434         return (map ord [i0,i1,i2,i3])
2435      )
2436
2437 doubleToBytes :: Double -> [Int]
2438 doubleToBytes d
2439    = runST (do
2440         arr <- newDoubleArray ((0::Int),7)
2441         writeDoubleArray arr 0 d
2442         arr <- castDoubleToCharArray arr
2443         i0 <- readCharArray arr 0
2444         i1 <- readCharArray arr 1
2445         i2 <- readCharArray arr 2
2446         i3 <- readCharArray arr 3
2447         i4 <- readCharArray arr 4
2448         i5 <- readCharArray arr 5
2449         i6 <- readCharArray arr 6
2450         i7 <- readCharArray arr 7
2451         return (map ord [i0,i1,i2,i3,i4,i5,i6,i7])
2452      )