compiler/nativeGen/PprMach.hs

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