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