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