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