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 import Data.Array.ST
  43 import Data.Word        ( Word8 )
  44 import Control.Monad.ST
  45 import Data.Char        ( chr, ord )
  46 import Data.Maybe       ( isJust )
  47
  48 #if powerpc_TARGET_ARCH || darwin_TARGET_OS
  49 import Data.Word(Word32)
  50 import Data.Bits
  51 #endif
  52
  53 -- -----------------------------------------------------------------------------
  54 -- Printing this stuff out
  55
  56 asmSDoc d = Outputable.withPprStyleDoc (
  57               Outputable.mkCodeStyle Outputable.AsmStyle) d
  58 pprCLabel_asm l = asmSDoc (pprCLabel l)
  59
  60 pprNatCmmTop :: NatCmmTop -> Doc
  61 pprNatCmmTop (CmmData section dats) =
  62   pprSectionHeader section $$ vcat (map pprData dats)
  63
  64  -- special case for split markers:
  65 pprNatCmmTop (CmmProc [] lbl _ []) = pprLabel lbl
  66
  67 pprNatCmmTop (CmmProc info lbl params blocks) =
  68   pprSectionHeader Text $$
  69   (if not (null info)
  70         then
  71 #if HAVE_SUBSECTIONS_VIA_SYMBOLS
  72             pprCLabel_asm (mkDeadStripPreventer $ entryLblToInfoLbl lbl)
  73                 <> char ':' $$
  74 #endif
  75             vcat (map pprData info) $$
  76             pprLabel (entryLblToInfoLbl lbl)
  77         else empty) $$
  78   (case blocks of
  79         [] -> empty
  80         (BasicBlock _ instrs : rest) ->
  81                 (if null info then pprLabel lbl else empty) $$
  82                 -- the first block doesn't get a label:
  83                 vcat (map pprInstr instrs) $$
  84                 vcat (map pprBasicBlock rest)
  85   )
  86 #if HAVE_SUBSECTIONS_VIA_SYMBOLS
  87         -- If we are using the .subsections_via_symbols directive
  88         -- (available on recent versions of Darwin),
  89         -- we have to make sure that there is some kind of reference
  90         -- from the entry code to a label on the _top_ of of the info table,
  91         -- so that the linker will not think it is unreferenced and dead-strip
  92         -- it. That's why the label is called a DeadStripPreventer (_dsp).
  93   $$ if not (null info)
  94                     then text "\t.long "
  95                       <+> pprCLabel_asm (entryLblToInfoLbl lbl)
  96                       <+> char '-'
  97                       <+> pprCLabel_asm (mkDeadStripPreventer $ entryLblToInfoLbl lbl)
  98                     else empty
  99 #endif
 100
 101
 102 pprBasicBlock :: NatBasicBlock -> Doc
 103 pprBasicBlock (BasicBlock (BlockId id) instrs) =
 104   pprLabel (mkAsmTempLabel id) $$
 105   vcat (map pprInstr instrs)
 106
 107 -- -----------------------------------------------------------------------------
 108 -- pprReg: print a 'Reg'
 109
 110 -- For x86, the way we print a register name depends
 111 -- on which bit of it we care about.  Yurgh.
 112
 113 pprUserReg :: Reg -> Doc
 114 pprUserReg = pprReg IF_ARCH_i386(I32,) IF_ARCH_x86_64(I64,)
 115
 116 pprReg :: IF_ARCH_i386(MachRep ->,) IF_ARCH_x86_64(MachRep ->,) Reg -> Doc
 117
 118 pprReg IF_ARCH_i386(s,) IF_ARCH_x86_64(s,) r
 119   = case r of
 120       RealReg i      -> ppr_reg_no IF_ARCH_i386(s,) IF_ARCH_x86_64(s,) i
 121       VirtualRegI  u  -> text "%vI_" <> asmSDoc (pprUnique u)
 122       VirtualRegHi u  -> text "%vHi_" <> asmSDoc (pprUnique u)
 123       VirtualRegF  u  -> text "%vF_" <> asmSDoc (pprUnique u)
 124       VirtualRegD  u  -> text "%vD_" <> asmSDoc (pprUnique u)
 125   where
 126 #if alpha_TARGET_ARCH
 127     ppr_reg_no :: Int -> Doc
 128     ppr_reg_no i = ptext
 129       (case i of {
 130          0 -> SLIT("$0");    1 -> SLIT("$1");
 131          2 -> SLIT("$2");    3 -> SLIT("$3");
 132          4 -> SLIT("$4");    5 -> SLIT("$5");
 133          6 -> SLIT("$6");    7 -> SLIT("$7");
 134          8 -> SLIT("$8");    9 -> SLIT("$9");
 135         10 -> SLIT("$10");  11 -> SLIT("$11");
 136         12 -> SLIT("$12");  13 -> SLIT("$13");
 137         14 -> SLIT("$14");  15 -> SLIT("$15");
 138         16 -> SLIT("$16");  17 -> SLIT("$17");
 139         18 -> SLIT("$18");  19 -> SLIT("$19");
 140         20 -> SLIT("$20");  21 -> SLIT("$21");
 141         22 -> SLIT("$22");  23 -> SLIT("$23");
 142         24 -> SLIT("$24");  25 -> SLIT("$25");
 143         26 -> SLIT("$26");  27 -> SLIT("$27");
 144         28 -> SLIT("$28");  29 -> SLIT("$29");
 145         30 -> SLIT("$30");  31 -> SLIT("$31");
 146         32 -> SLIT("$f0");  33 -> SLIT("$f1");
 147         34 -> SLIT("$f2");  35 -> SLIT("$f3");
 148         36 -> SLIT("$f4");  37 -> SLIT("$f5");
 149         38 -> SLIT("$f6");  39 -> SLIT("$f7");
 150         40 -> SLIT("$f8");  41 -> SLIT("$f9");
 151         42 -> SLIT("$f10"); 43 -> SLIT("$f11");
 152         44 -> SLIT("$f12"); 45 -> SLIT("$f13");
 153         46 -> SLIT("$f14"); 47 -> SLIT("$f15");
 154         48 -> SLIT("$f16"); 49 -> SLIT("$f17");
 155         50 -> SLIT("$f18"); 51 -> SLIT("$f19");
 156         52 -> SLIT("$f20"); 53 -> SLIT("$f21");
 157         54 -> SLIT("$f22"); 55 -> SLIT("$f23");
 158         56 -> SLIT("$f24"); 57 -> SLIT("$f25");
 159         58 -> SLIT("$f26"); 59 -> SLIT("$f27");
 160         60 -> SLIT("$f28"); 61 -> SLIT("$f29");
 161         62 -> SLIT("$f30"); 63 -> SLIT("$f31");
 162         _  -> SLIT("very naughty alpha register")
 163       })
 164 #endif
 165 #if i386_TARGET_ARCH
 166     ppr_reg_no :: MachRep -> Int -> Doc
 167     ppr_reg_no I8   = ppr_reg_byte
 168     ppr_reg_no I16  = ppr_reg_word
 169     ppr_reg_no _    = ppr_reg_long
 170
 171     ppr_reg_byte i = ptext
 172       (case i of {
 173          0 -> SLIT("%al");     1 -> SLIT("%bl");
 174          2 -> SLIT("%cl");     3 -> SLIT("%dl");
 175         _  -> SLIT("very naughty I386 byte register")
 176       })
 177
 178     ppr_reg_word i = ptext
 179       (case i of {
 180          0 -> SLIT("%ax");     1 -> SLIT("%bx");
 181          2 -> SLIT("%cx");     3 -> SLIT("%dx");
 182          4 -> SLIT("%si");     5 -> SLIT("%di");
 183          6 -> SLIT("%bp");     7 -> SLIT("%sp");
 184         _  -> SLIT("very naughty I386 word register")
 185       })
 186
 187     ppr_reg_long i = ptext
 188       (case i of {
 189          0 -> SLIT("%eax");    1 -> SLIT("%ebx");
 190          2 -> SLIT("%ecx");    3 -> SLIT("%edx");
 191          4 -> SLIT("%esi");    5 -> SLIT("%edi");
 192          6 -> SLIT("%ebp");    7 -> SLIT("%esp");
 193          8 -> SLIT("%fake0");  9 -> SLIT("%fake1");
 194         10 -> SLIT("%fake2"); 11 -> SLIT("%fake3");
 195         12 -> SLIT("%fake4"); 13 -> SLIT("%fake5");
 196         _  -> SLIT("very naughty I386 register")
 197       })
 198 #endif
 199
 200 #if x86_64_TARGET_ARCH
 201     ppr_reg_no :: MachRep -> Int -> Doc
 202     ppr_reg_no I8   = ppr_reg_byte
 203     ppr_reg_no I16  = ppr_reg_word
 204     ppr_reg_no I32  = ppr_reg_long
 205     ppr_reg_no _    = ppr_reg_quad
 206
 207     ppr_reg_byte i = ptext
 208       (case i of {
 209          0 -> SLIT("%al");     1 -> SLIT("%bl");
 210          2 -> SLIT("%cl");     3 -> SLIT("%dl");
 211          4 -> SLIT("%sil");    5 -> SLIT("%dil"); -- new 8-bit regs!
 212          6 -> SLIT("%bpl");    7 -> SLIT("%spl");
 213          8 -> SLIT("%r8b");    9  -> SLIT("%r9b");
 214         10 -> SLIT("%r10b");   11 -> SLIT("%r11b");
 215         12 -> SLIT("%r12b");   13 -> SLIT("%r13b");
 216         14 -> SLIT("%r14b");   15 -> SLIT("%r15b");
 217         _  -> SLIT("very naughty x86_64 byte register")
 218       })
 219
 220     ppr_reg_word i = ptext
 221       (case i of {
 222          0 -> SLIT("%ax");     1 -> SLIT("%bx");
 223          2 -> SLIT("%cx");     3 -> SLIT("%dx");
 224          4 -> SLIT("%si");     5 -> SLIT("%di");
 225          6 -> SLIT("%bp");     7 -> SLIT("%sp");
 226          8 -> SLIT("%r8w");    9  -> SLIT("%r9w");
 227         10 -> SLIT("%r10w");   11 -> SLIT("%r11w");
 228         12 -> SLIT("%r12w");   13 -> SLIT("%r13w");
 229         14 -> SLIT("%r14w");   15 -> SLIT("%r15w");
 230         _  -> SLIT("very naughty x86_64 word register")
 231       })
 232
 233     ppr_reg_long i = ptext
 234       (case i of {
 235          0 -> SLIT("%eax");    1  -> SLIT("%ebx");
 236          2 -> SLIT("%ecx");    3  -> SLIT("%edx");
 237          4 -> SLIT("%esi");    5  -> SLIT("%edi");
 238          6 -> SLIT("%ebp");    7  -> SLIT("%esp");
 239          8 -> SLIT("%r8d");    9  -> SLIT("%r9d");
 240         10 -> SLIT("%r10d");   11 -> SLIT("%r11d");
 241         12 -> SLIT("%r12d");   13 -> SLIT("%r13d");
 242         14 -> SLIT("%r14d");   15 -> SLIT("%r15d");
 243         _  -> SLIT("very naughty x86_64 register")
 244       })
 245
 246     ppr_reg_quad i = ptext
 247       (case i of {
 248          0 -> SLIT("%rax");     1 -> SLIT("%rbx");
 249          2 -> SLIT("%rcx");     3 -> SLIT("%rdx");
 250          4 -> SLIT("%rsi");     5 -> SLIT("%rdi");
 251          6 -> SLIT("%rbp");     7 -> SLIT("%rsp");
 252          8 -> SLIT("%r8");      9 -> SLIT("%r9");
 253         10 -> SLIT("%r10");    11 -> SLIT("%r11");
 254         12 -> SLIT("%r12");    13 -> SLIT("%r13");
 255         14 -> SLIT("%r14");    15 -> SLIT("%r15");
 256         16 -> SLIT("%xmm0");   17 -> SLIT("%xmm1");
 257         18 -> SLIT("%xmm2");   19 -> SLIT("%xmm3");
 258         20 -> SLIT("%xmm4");   21 -> SLIT("%xmm5");
 259         22 -> SLIT("%xmm6");   23 -> SLIT("%xmm7");
 260         24 -> SLIT("%xmm8");   25 -> SLIT("%xmm9");
 261         26 -> SLIT("%xmm10");  27 -> SLIT("%xmm11");
 262         28 -> SLIT("%xmm12");  29 -> SLIT("%xmm13");
 263         30 -> SLIT("%xmm14");  31 -> SLIT("%xmm15");
 264         _  -> SLIT("very naughty x86_64 register")
 265       })
 266 #endif
 267
 268 #if sparc_TARGET_ARCH
 269     ppr_reg_no :: Int -> Doc
 270     ppr_reg_no i = ptext
 271       (case i of {
 272          0 -> SLIT("%g0");   1 -> SLIT("%g1");
 273          2 -> SLIT("%g2");   3 -> SLIT("%g3");
 274          4 -> SLIT("%g4");   5 -> SLIT("%g5");
 275          6 -> SLIT("%g6");   7 -> SLIT("%g7");
 276          8 -> SLIT("%o0");   9 -> SLIT("%o1");
 277         10 -> SLIT("%o2");  11 -> SLIT("%o3");
 278         12 -> SLIT("%o4");  13 -> SLIT("%o5");
 279         14 -> SLIT("%o6");  15 -> SLIT("%o7");
 280         16 -> SLIT("%l0");  17 -> SLIT("%l1");
 281         18 -> SLIT("%l2");  19 -> SLIT("%l3");
 282         20 -> SLIT("%l4");  21 -> SLIT("%l5");
 283         22 -> SLIT("%l6");  23 -> SLIT("%l7");
 284         24 -> SLIT("%i0");  25 -> SLIT("%i1");
 285         26 -> SLIT("%i2");  27 -> SLIT("%i3");
 286         28 -> SLIT("%i4");  29 -> SLIT("%i5");
 287         30 -> SLIT("%i6");  31 -> SLIT("%i7");
 288         32 -> SLIT("%f0");  33 -> SLIT("%f1");
 289         34 -> SLIT("%f2");  35 -> SLIT("%f3");
 290         36 -> SLIT("%f4");  37 -> SLIT("%f5");
 291         38 -> SLIT("%f6");  39 -> SLIT("%f7");
 292         40 -> SLIT("%f8");  41 -> SLIT("%f9");
 293         42 -> SLIT("%f10"); 43 -> SLIT("%f11");
 294         44 -> SLIT("%f12"); 45 -> SLIT("%f13");
 295         46 -> SLIT("%f14"); 47 -> SLIT("%f15");
 296         48 -> SLIT("%f16"); 49 -> SLIT("%f17");
 297         50 -> SLIT("%f18"); 51 -> SLIT("%f19");
 298         52 -> SLIT("%f20"); 53 -> SLIT("%f21");
 299         54 -> SLIT("%f22"); 55 -> SLIT("%f23");
 300         56 -> SLIT("%f24"); 57 -> SLIT("%f25");
 301         58 -> SLIT("%f26"); 59 -> SLIT("%f27");
 302         60 -> SLIT("%f28"); 61 -> SLIT("%f29");
 303         62 -> SLIT("%f30"); 63 -> SLIT("%f31");
 304         _  -> SLIT("very naughty sparc register")
 305       })
 306 #endif
 307 #if powerpc_TARGET_ARCH
 308 #if darwin_TARGET_OS
 309     ppr_reg_no :: Int -> Doc
 310     ppr_reg_no i = ptext
 311       (case i of {
 312          0 -> SLIT("r0");   1 -> SLIT("r1");
 313          2 -> SLIT("r2");   3 -> SLIT("r3");
 314          4 -> SLIT("r4");   5 -> SLIT("r5");
 315          6 -> SLIT("r6");   7 -> SLIT("r7");
 316          8 -> SLIT("r8");   9 -> SLIT("r9");
 317         10 -> SLIT("r10");  11 -> SLIT("r11");
 318         12 -> SLIT("r12");  13 -> SLIT("r13");
 319         14 -> SLIT("r14");  15 -> SLIT("r15");
 320         16 -> SLIT("r16");  17 -> SLIT("r17");
 321         18 -> SLIT("r18");  19 -> SLIT("r19");
 322         20 -> SLIT("r20");  21 -> SLIT("r21");
 323         22 -> SLIT("r22");  23 -> SLIT("r23");
 324         24 -> SLIT("r24");  25 -> SLIT("r25");
 325         26 -> SLIT("r26");  27 -> SLIT("r27");
 326         28 -> SLIT("r28");  29 -> SLIT("r29");
 327         30 -> SLIT("r30");  31 -> SLIT("r31");
 328         32 -> SLIT("f0");  33 -> SLIT("f1");
 329         34 -> SLIT("f2");  35 -> SLIT("f3");
 330         36 -> SLIT("f4");  37 -> SLIT("f5");
 331         38 -> SLIT("f6");  39 -> SLIT("f7");
 332         40 -> SLIT("f8");  41 -> SLIT("f9");
 333         42 -> SLIT("f10"); 43 -> SLIT("f11");
 334         44 -> SLIT("f12"); 45 -> SLIT("f13");
 335         46 -> SLIT("f14"); 47 -> SLIT("f15");
 336         48 -> SLIT("f16"); 49 -> SLIT("f17");
 337         50 -> SLIT("f18"); 51 -> SLIT("f19");
 338         52 -> SLIT("f20"); 53 -> SLIT("f21");
 339         54 -> SLIT("f22"); 55 -> SLIT("f23");
 340         56 -> SLIT("f24"); 57 -> SLIT("f25");
 341         58 -> SLIT("f26"); 59 -> SLIT("f27");
 342         60 -> SLIT("f28"); 61 -> SLIT("f29");
 343         62 -> SLIT("f30"); 63 -> SLIT("f31");
 344         _  -> SLIT("very naughty powerpc register")
 345       })
 346 #else
 347     ppr_reg_no :: Int -> Doc
 348     ppr_reg_no i | i <= 31 = int i      -- GPRs
 349                  | i <= 63 = int (i-32) -- FPRs
 350                  | otherwise = ptext SLIT("very naughty powerpc register")
 351 #endif
 352 #endif
 353
 354
 355 -- -----------------------------------------------------------------------------
 356 -- pprSize: print a 'Size'
 357
 358 #if powerpc_TARGET_ARCH || i386_TARGET_ARCH || x86_64_TARGET_ARCH || sparc_TARGET_ARCH
 359 pprSize :: MachRep -> Doc
 360 #else
 361 pprSize :: Size -> Doc
 362 #endif
 363
 364 pprSize x = ptext (case x of
 365 #if alpha_TARGET_ARCH
 366          B  -> SLIT("b")
 367          Bu -> SLIT("bu")
 368 --       W  -> SLIT("w") UNUSED
 369 --       Wu -> SLIT("wu") UNUSED
 370          L  -> SLIT("l")
 371          Q  -> SLIT("q")
 372 --       FF -> SLIT("f") UNUSED
 373 --       DF -> SLIT("d") UNUSED
 374 --       GF -> SLIT("g") UNUSED
 375 --       SF -> SLIT("s") UNUSED
 376          TF -> SLIT("t")
 377 #endif
 378 #if i386_TARGET_ARCH || x86_64_TARGET_ARCH
 379         I8   -> SLIT("b")
 380         I16  -> SLIT("w")
 381         I32  -> SLIT("l")
 382         I64  -> SLIT("q")
 383 #endif
 384 #if i386_TARGET_ARCH
 385         F32  -> SLIT("s")
 386         F64  -> SLIT("l")
 387         F80  -> SLIT("t")
 388 #endif
 389 #if x86_64_TARGET_ARCH
 390         F32  -> SLIT("ss")      -- "scalar single-precision float" (SSE2)
 391         F64  -> SLIT("sd")      -- "scalar double-precision float" (SSE2)
 392 #endif
 393 #if sparc_TARGET_ARCH
 394         I8   -> SLIT("sb")
 395         I16   -> SLIT("sh")
 396         I32   -> SLIT("")
 397         F32   -> SLIT("")
 398         F64  -> SLIT("d")
 399     )
 400 pprStSize :: MachRep -> Doc
 401 pprStSize x = ptext (case x of
 402         I8   -> SLIT("b")
 403         I16  -> SLIT("h")
 404         I32  -> SLIT("")
 405         F32  -> SLIT("")
 406         F64  -> SLIT("d")
 407 #endif
 408 #if powerpc_TARGET_ARCH
 409         I8   -> SLIT("b")
 410         I16  -> SLIT("h")
 411         I32  -> SLIT("w")
 412         F32  -> SLIT("fs")
 413         F64  -> SLIT("fd")
 414 #endif
 415     )
 416
 417 -- -----------------------------------------------------------------------------
 418 -- pprCond: print a 'Cond'
 419
 420 pprCond :: Cond -> Doc
 421
 422 pprCond c = ptext (case c of {
 423 #if alpha_TARGET_ARCH
 424         EQQ  -> SLIT("eq");
 425         LTT  -> SLIT("lt");
 426         LE  -> SLIT("le");
 427         ULT -> SLIT("ult");
 428         ULE -> SLIT("ule");
 429         NE  -> SLIT("ne");
 430         GTT  -> SLIT("gt");
 431         GE  -> SLIT("ge")
 432 #endif
 433 #if i386_TARGET_ARCH || x86_64_TARGET_ARCH
 434         GEU     -> SLIT("ae");  LU    -> SLIT("b");
 435         EQQ     -> SLIT("e");   GTT   -> SLIT("g");
 436         GE      -> SLIT("ge");  GU    -> SLIT("a");
 437         LTT     -> SLIT("l");   LE    -> SLIT("le");
 438         LEU     -> SLIT("be");  NE    -> SLIT("ne");
 439         NEG     -> SLIT("s");   POS   -> SLIT("ns");
 440         CARRY   -> SLIT("c");   OFLO  -> SLIT("o");
 441         PARITY  -> SLIT("p");   NOTPARITY -> SLIT("np");
 442         ALWAYS  -> SLIT("mp")   -- hack
 443 #endif
 444 #if sparc_TARGET_ARCH
 445         ALWAYS  -> SLIT("");    NEVER -> SLIT("n");
 446         GEU     -> SLIT("geu"); LU    -> SLIT("lu");
 447         EQQ     -> SLIT("e");   GTT   -> SLIT("g");
 448         GE      -> SLIT("ge");  GU    -> SLIT("gu");
 449         LTT     -> SLIT("l");   LE    -> SLIT("le");
 450         LEU     -> SLIT("leu"); NE    -> SLIT("ne");
 451         NEG     -> SLIT("neg"); POS   -> SLIT("pos");
 452         VC      -> SLIT("vc");  VS    -> SLIT("vs")
 453 #endif
 454 #if powerpc_TARGET_ARCH
 455         ALWAYS  -> SLIT("");
 456         EQQ     -> SLIT("eq");  NE    -> SLIT("ne");
 457         LTT     -> SLIT("lt");  GE    -> SLIT("ge");
 458         GTT     -> SLIT("gt");  LE    -> SLIT("le");
 459         LU      -> SLIT("lt");  GEU   -> SLIT("ge");
 460         GU      -> SLIT("gt");  LEU   -> SLIT("le");
 461 #endif
 462     })
 463
 464
 465 -- -----------------------------------------------------------------------------
 466 -- pprImm: print an 'Imm'
 467
 468 pprImm :: Imm -> Doc
 469
 470 pprImm (ImmInt i)     = int i
 471 pprImm (ImmInteger i) = integer i
 472 pprImm (ImmCLbl l)    = pprCLabel_asm l
 473 pprImm (ImmIndex l i) = pprCLabel_asm l <> char '+' <> int i
 474 pprImm (ImmLit s)     = s
 475
 476 pprImm (ImmFloat _) = ptext SLIT("naughty float immediate")
 477 pprImm (ImmDouble _) = ptext SLIT("naughty double immediate")
 478
 479 pprImm (ImmConstantSum a b) = pprImm a <> char '+' <> pprImm b
 480 #if sparc_TARGET_ARCH
 481 -- ToDo: This should really be fixed in the PIC support, but only
 482 -- print a for now.
 483 pprImm (ImmConstantDiff a b) = pprImm a
 484 #else
 485 pprImm (ImmConstantDiff a b) = pprImm a <> char '-'
 486                             <> lparen <> pprImm b <> rparen
 487 #endif
 488
 489 #if sparc_TARGET_ARCH
 490 pprImm (LO i)
 491   = hcat [ pp_lo, pprImm i, rparen ]
 492   where
 493     pp_lo = text "%lo("
 494
 495 pprImm (HI i)
 496   = hcat [ pp_hi, pprImm i, rparen ]
 497   where
 498     pp_hi = text "%hi("
 499 #endif
 500 #if powerpc_TARGET_ARCH
 501 #if darwin_TARGET_OS
 502 pprImm (LO i)
 503   = hcat [ pp_lo, pprImm i, rparen ]
 504   where
 505     pp_lo = text "lo16("
 506
 507 pprImm (HI i)
 508   = hcat [ pp_hi, pprImm i, rparen ]
 509   where
 510     pp_hi = text "hi16("
 511
 512 pprImm (HA i)
 513   = hcat [ pp_ha, pprImm i, rparen ]
 514   where
 515     pp_ha = text "ha16("
 516
 517 #else
 518 pprImm (LO i)
 519   = pprImm i <> text "@l"
 520
 521 pprImm (HI i)
 522   = pprImm i <> text "@h"
 523
 524 pprImm (HA i)
 525   = pprImm i <> text "@ha"
 526 #endif
 527 #endif
 528
 529
 530 -- -----------------------------------------------------------------------------
 531 -- @pprAddr: print an 'AddrMode'
 532
 533 pprAddr :: AddrMode -> Doc
 534
 535 #if alpha_TARGET_ARCH
 536 pprAddr (AddrReg r) = parens (pprReg r)
 537 pprAddr (AddrImm i) = pprImm i
 538 pprAddr (AddrRegImm r1 i)
 539   = (<>) (pprImm i) (parens (pprReg r1))
 540 #endif
 541
 542 -------------------
 543
 544 #if i386_TARGET_ARCH || x86_64_TARGET_ARCH
 545 pprAddr (ImmAddr imm off)
 546   = let pp_imm = pprImm imm
 547     in
 548     if (off == 0) then
 549         pp_imm
 550     else if (off < 0) then
 551         pp_imm <> int off
 552     else
 553         pp_imm <> char '+' <> int off
 554
 555 pprAddr (AddrBaseIndex base index displacement)
 556   = let
 557         pp_disp  = ppr_disp displacement
 558         pp_off p = pp_disp <> char '(' <> p <> char ')'
 559         pp_reg r = pprReg wordRep r
 560     in
 561     case (base,index) of
 562       (EABaseNone,  EAIndexNone) -> pp_disp
 563       (EABaseReg b, EAIndexNone) -> pp_off (pp_reg b)
 564       (EABaseRip,   EAIndexNone) -> pp_off (ptext SLIT("%rip"))
 565       (EABaseNone,  EAIndex r i) -> pp_off (comma <> pp_reg r <> comma <> int i)
 566       (EABaseReg b, EAIndex r i) -> pp_off (pp_reg b <> comma <> pp_reg r
 567                                        <> comma <> int i)
 568   where
 569     ppr_disp (ImmInt 0) = empty
 570     ppr_disp imm        = pprImm imm
 571 #endif
 572
 573 -------------------
 574
 575 #if sparc_TARGET_ARCH
 576 pprAddr (AddrRegReg r1 (RealReg 0)) = pprReg r1
 577
 578 pprAddr (AddrRegReg r1 r2)
 579   = hcat [ pprReg r1, char '+', pprReg r2 ]
 580
 581 pprAddr (AddrRegImm r1 (ImmInt i))
 582   | i == 0 = pprReg r1
 583   | not (fits13Bits i) = largeOffsetError i
 584   | otherwise = hcat [ pprReg r1, pp_sign, int i ]
 585   where
 586     pp_sign = if i > 0 then char '+' else empty
 587
 588 pprAddr (AddrRegImm r1 (ImmInteger i))
 589   | i == 0 = pprReg r1
 590   | not (fits13Bits i) = largeOffsetError i
 591   | otherwise  = hcat [ pprReg r1, pp_sign, integer i ]
 592   where
 593     pp_sign = if i > 0 then char '+' else empty
 594
 595 pprAddr (AddrRegImm r1 imm)
 596   = hcat [ pprReg r1, char '+', pprImm imm ]
 597 #endif
 598
 599 -------------------
 600
 601 #if powerpc_TARGET_ARCH
 602 pprAddr (AddrRegReg r1 r2)
 603   = pprReg r1 <+> ptext SLIT(", ") <+> pprReg r2
 604
 605 pprAddr (AddrRegImm r1 (ImmInt i)) = hcat [ int i, char '(', pprReg r1, char ')' ]
 606 pprAddr (AddrRegImm r1 (ImmInteger i)) = hcat [ integer i, char '(', pprReg r1, char ')' ]
 607 pprAddr (AddrRegImm r1 imm) = hcat [ pprImm imm, char '(', pprReg r1, char ')' ]
 608 #endif
 609
 610
 611 -- -----------------------------------------------------------------------------
 612 -- pprData: print a 'CmmStatic'
 613
 614 pprSectionHeader Text
 615     = ptext
 616         IF_ARCH_alpha(SLIT("\t.text\n\t.align 3") {-word boundary-}
 617        ,IF_ARCH_sparc(SLIT(".text\n\t.align 4") {-word boundary-}
 618        ,IF_ARCH_i386(IF_OS_darwin(SLIT(".text\n\t.align 2"),
 619                                   SLIT(".text\n\t.align 4,0x90"))
 620                                   {-needs per-OS variation!-}
 621        ,IF_ARCH_x86_64(SLIT(".text\n\t.align 8") {-needs per-OS variation!-}
 622        ,IF_ARCH_powerpc(SLIT(".text\n.align 2")
 623        ,)))))
 624 pprSectionHeader Data
 625     = ptext
 626          IF_ARCH_alpha(SLIT("\t.data\n\t.align 3")
 627         ,IF_ARCH_sparc(SLIT(".data\n\t.align 8") {-<8 will break double constants -}
 628         ,IF_ARCH_i386(IF_OS_darwin(SLIT(".data\n\t.align 2"),
 629                                    SLIT(".data\n\t.align 4"))
 630         ,IF_ARCH_x86_64(SLIT(".data\n\t.align 8")
 631         ,IF_ARCH_powerpc(SLIT(".data\n.align 2")
 632         ,)))))
 633 pprSectionHeader ReadOnlyData
 634     = ptext
 635          IF_ARCH_alpha(SLIT("\t.data\n\t.align 3")
 636         ,IF_ARCH_sparc(SLIT(".data\n\t.align 8") {-<8 will break double constants -}
 637         ,IF_ARCH_i386(IF_OS_darwin(SLIT(".const\n.align 2"),
 638                                    SLIT(".section .rodata\n\t.align 4"))
 639         ,IF_ARCH_x86_64(SLIT(".section .rodata\n\t.align 8")
 640         ,IF_ARCH_powerpc(IF_OS_darwin(SLIT(".const\n.align 2"),
 641                                       SLIT(".section .rodata\n\t.align 2"))
 642         ,)))))
 643 pprSectionHeader RelocatableReadOnlyData
 644     = ptext
 645          IF_ARCH_alpha(SLIT("\t.data\n\t.align 3")
 646         ,IF_ARCH_sparc(SLIT(".data\n\t.align 8") {-<8 will break double constants -}
 647         ,IF_ARCH_i386(IF_OS_darwin(SLIT(".const_data\n.align 2"),
 648                                    SLIT(".section .rodata\n\t.align 4"))
 649         ,IF_ARCH_x86_64(SLIT(".section .rodata\n\t.align 8")
 650         ,IF_ARCH_powerpc(IF_OS_darwin(SLIT(".const_data\n.align 2"),
 651                                       SLIT(".data\n\t.align 2"))
 652         ,)))))
 653 pprSectionHeader UninitialisedData
 654     = ptext
 655          IF_ARCH_alpha(SLIT("\t.bss\n\t.align 3")
 656         ,IF_ARCH_sparc(SLIT(".bss\n\t.align 8") {-<8 will break double constants -}
 657         ,IF_ARCH_i386(IF_OS_darwin(SLIT(".const_data\n\t.align 2"),
 658                                    SLIT(".section .bss\n\t.align 4"))
 659         ,IF_ARCH_x86_64(SLIT(".section .bss\n\t.align 8")
 660         ,IF_ARCH_powerpc(IF_OS_darwin(SLIT(".const_data\n.align 2"),
 661                                       SLIT(".section .bss\n\t.align 2"))
 662         ,)))))
 663 pprSectionHeader ReadOnlyData16
 664     = ptext
 665          IF_ARCH_alpha(SLIT("\t.data\n\t.align 4")
 666         ,IF_ARCH_sparc(SLIT(".data\n\t.align 16")
 667         ,IF_ARCH_i386(IF_OS_darwin(SLIT(".const\n.align 4"),
 668                                    SLIT(".section .rodata\n\t.align 16"))
 669         ,IF_ARCH_x86_64(SLIT(".section .rodata.cst16\n\t.align 16")
 670         ,IF_ARCH_powerpc(IF_OS_darwin(SLIT(".const\n.align 4"),
 671                                       SLIT(".section .rodata\n\t.align 4"))
 672         ,)))))
 673
 674 pprSectionHeader (OtherSection sec)
 675     = panic "PprMach.pprSectionHeader: unknown section"
 676
 677 pprData :: CmmStatic -> Doc
 678 pprData (CmmAlign bytes)         = pprAlign bytes
 679 pprData (CmmDataLabel lbl)       = pprLabel lbl
 680 pprData (CmmString str)          = pprASCII str
 681 pprData (CmmUninitialised bytes) = ptext SLIT(".space ") <> int bytes
 682 pprData (CmmStaticLit lit)       = pprDataItem lit
 683
 684 pprGloblDecl :: CLabel -> Doc
 685 pprGloblDecl lbl
 686   | not (externallyVisibleCLabel lbl) = empty
 687   | otherwise = ptext IF_ARCH_sparc(SLIT(".global "),
 688                                     SLIT(".globl ")) <>
 689                 pprCLabel_asm lbl
 690
 691 pprLabel :: CLabel -> Doc
 692 pprLabel lbl = pprGloblDecl lbl $$ (pprCLabel_asm lbl <> char ':')
 693
 694
 695 pprASCII str
 696   = vcat (map do1 str) $$ do1 0
 697     where
 698        do1 :: Word8 -> Doc
 699        do1 w = ptext SLIT("\t.byte\t") <> int (fromIntegral w)
 700
 701 pprAlign bytes =
 702         IF_ARCH_alpha(ptextSLIT(".align ") <> int pow2,
 703         IF_ARCH_i386(ptext SLIT(".align ") <> int IF_OS_darwin(pow2,bytes),
 704         IF_ARCH_x86_64(ptext SLIT(".align ") <> int bytes,
 705         IF_ARCH_sparc(ptext SLIT(".align ") <> int bytes,
 706         IF_ARCH_powerpc(ptext SLIT(".align ") <> int pow2,)))))
 707   where
 708         pow2 = log2 bytes
 709
 710         log2 :: Int -> Int  -- cache the common ones
 711         log2 1 = 0
 712         log2 2 = 1
 713         log2 4 = 2
 714         log2 8 = 3
 715         log2 n = 1 + log2 (n `quot` 2)
 716
 717
 718 pprDataItem :: CmmLit -> Doc
 719 pprDataItem lit
 720   = vcat (ppr_item (cmmLitRep lit) lit)
 721     where
 722         imm = litToImm lit
 723
 724         -- These seem to be common:
 725         ppr_item I8   x = [ptext SLIT("\t.byte\t") <> pprImm imm]
 726         ppr_item I32  x = [ptext SLIT("\t.long\t") <> pprImm imm]
 727         ppr_item F32  (CmmFloat r _)
 728            = let bs = floatToBytes (fromRational r)
 729              in  map (\b -> ptext SLIT("\t.byte\t") <> pprImm (ImmInt b)) bs
 730         ppr_item F64 (CmmFloat r _)
 731            = let bs = doubleToBytes (fromRational r)
 732              in  map (\b -> ptext SLIT("\t.byte\t") <> pprImm (ImmInt b)) bs
 733
 734 #if sparc_TARGET_ARCH
 735         -- copy n paste of x86 version
 736         ppr_item I16  x = [ptext SLIT("\t.short\t") <> pprImm imm]
 737         ppr_item I64  x = [ptext SLIT("\t.quad\t") <> pprImm imm]
 738 #endif
 739 #if i386_TARGET_ARCH || x86_64_TARGET_ARCH
 740         ppr_item I16  x = [ptext SLIT("\t.word\t") <> pprImm imm]
 741 #endif
 742 #if i386_TARGET_ARCH && darwin_TARGET_OS
 743         ppr_item I64 (CmmInt x _)  =
 744                 [ptext SLIT("\t.long\t")
 745                     <> int (fromIntegral (fromIntegral x :: Word32)),
 746                  ptext SLIT("\t.long\t")
 747                     <> int (fromIntegral
 748                         (fromIntegral (x `shiftR` 32) :: Word32))]
 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("cvtss2siq") from to
1308 pprInstr (CVTSD2SI from to) = pprOpReg  SLIT("cvtsd2siq") from to
1309 pprInstr (CVTSI2SS from to) = pprOpReg  SLIT("cvtsi2ssq") from to
1310 pprInstr (CVTSI2SD from to) = pprOpReg  SLIT("cvtsi2sdq") 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
1770 pprInstr (LD F64 (AddrRegReg g1 g2) reg)
1771   = vcat [
1772        hcat [ptext SLIT("\tadd\t"), pprReg g1,comma,pprReg g2,comma,pprReg g1],
1773        hcat [pp_ld_lbracket, pprReg g1, pp_rbracket_comma, pprReg reg],
1774        hcat [pp_ld_lbracket, pprReg g1, ptext SLIT("+4]"), comma, pprReg (fPair reg)],
1775        hcat [ptext SLIT("\tsub\t"), pprReg g1,comma,pprReg g2,comma,pprReg g1]
1776     ]
1777
1778 -- Translate to
1779 --    ld  [addr],%fn
1780 --    ld  [addr+4],%f(n+1)
1781 pprInstr (LD F64 addr reg) | isJust off_addr
1782   = vcat [
1783        hcat [pp_ld_lbracket, pprAddr addr, pp_rbracket_comma, pprReg reg],
1784        hcat [pp_ld_lbracket, pprAddr addr2, pp_rbracket_comma,pprReg (fPair reg)]
1785     ]
1786   where
1787     off_addr = addrOffset addr 4
1788     addr2 = case off_addr of Just x -> x
1789
1790
1791 pprInstr (LD size addr reg)
1792   = hcat [
1793        ptext SLIT("\tld"),
1794        pprSize size,
1795        char '\t',
1796        lbrack,
1797        pprAddr addr,
1798        pp_rbracket_comma,
1799        pprReg reg
1800     ]
1801
1802 -- The same clumsy hack as above
1803
1804 -- Translate to the following:
1805 --    add g1,g2,g1
1806 --    st  %fn,[g1]
1807 --    st  %f(n+1),[g1+4]
1808 --    sub g1,g2,g1           -- to restore g1
1809 pprInstr (ST F64 reg (AddrRegReg g1 g2))
1810  = vcat [
1811        hcat [ptext SLIT("\tadd\t"), pprReg g1,comma,pprReg g2,comma,pprReg g1],
1812        hcat [ptext SLIT("\tst\t"), pprReg reg, pp_comma_lbracket,
1813              pprReg g1, rbrack],
1814        hcat [ptext SLIT("\tst\t"), pprReg (fPair reg), pp_comma_lbracket,
1815              pprReg g1, ptext SLIT("+4]")],
1816        hcat [ptext SLIT("\tsub\t"), pprReg g1,comma,pprReg g2,comma,pprReg g1]
1817     ]
1818
1819 -- Translate to
1820 --    st  %fn,[addr]
1821 --    st  %f(n+1),[addr+4]
1822 pprInstr (ST F64 reg addr) | isJust off_addr
1823  = vcat [
1824       hcat [ptext SLIT("\tst\t"), pprReg reg, pp_comma_lbracket,
1825             pprAddr addr, rbrack],
1826       hcat [ptext SLIT("\tst\t"), pprReg (fPair reg), pp_comma_lbracket,
1827             pprAddr addr2, rbrack]
1828     ]
1829   where
1830     off_addr = addrOffset addr 4
1831     addr2 = case off_addr of Just x -> x
1832
1833 -- no distinction is made between signed and unsigned bytes on stores for the
1834 -- Sparc opcodes (at least I cannot see any, and gas is nagging me --SOF),
1835 -- so we call a special-purpose pprSize for ST..
1836
1837 pprInstr (ST size reg addr)
1838   = hcat [
1839        ptext SLIT("\tst"),
1840        pprStSize size,
1841        char '\t',
1842        pprReg reg,
1843        pp_comma_lbracket,
1844        pprAddr addr,
1845        rbrack
1846     ]
1847
1848 pprInstr (ADD x cc reg1 ri reg2)
1849   | not x && not cc && riZero ri
1850   = hcat [ ptext SLIT("\tmov\t"), pprReg reg1, comma, pprReg reg2 ]
1851   | otherwise
1852   = pprRegRIReg (if x then SLIT("addx") else SLIT("add")) cc reg1 ri reg2
1853
1854 pprInstr (SUB x cc reg1 ri reg2)
1855   | not x && cc && reg2 == g0
1856   = hcat [ ptext SLIT("\tcmp\t"), pprReg reg1, comma, pprRI ri ]
1857   | not x && not cc && riZero ri
1858   = hcat [ ptext SLIT("\tmov\t"), pprReg reg1, comma, pprReg reg2 ]
1859   | otherwise
1860   = pprRegRIReg (if x then SLIT("subx") else SLIT("sub")) cc reg1 ri reg2
1861
1862 pprInstr (AND  b reg1 ri reg2) = pprRegRIReg SLIT("and")  b reg1 ri reg2
1863 pprInstr (ANDN b reg1 ri reg2) = pprRegRIReg SLIT("andn") b reg1 ri reg2
1864
1865 pprInstr (OR b reg1 ri reg2)
1866   | not b && reg1 == g0
1867   = let doit = hcat [ ptext SLIT("\tmov\t"), pprRI ri, comma, pprReg reg2 ]
1868     in  case ri of
1869            RIReg rrr | rrr == reg2 -> empty
1870            other                   -> doit
1871   | otherwise
1872   = pprRegRIReg SLIT("or") b reg1 ri reg2
1873
1874 pprInstr (ORN b reg1 ri reg2) = pprRegRIReg SLIT("orn") b reg1 ri reg2
1875
1876 pprInstr (XOR  b reg1 ri reg2) = pprRegRIReg SLIT("xor")  b reg1 ri reg2
1877 pprInstr (XNOR b reg1 ri reg2) = pprRegRIReg SLIT("xnor") b reg1 ri reg2
1878
1879 pprInstr (SLL reg1 ri reg2) = pprRegRIReg SLIT("sll") False reg1 ri reg2
1880 pprInstr (SRL reg1 ri reg2) = pprRegRIReg SLIT("srl") False reg1 ri reg2
1881 pprInstr (SRA reg1 ri reg2) = pprRegRIReg SLIT("sra") False reg1 ri reg2
1882
1883 pprInstr (RDY rd) = ptext SLIT("\trd\t%y,") <> pprReg rd
1884 pprInstr (SMUL b reg1 ri reg2) = pprRegRIReg SLIT("smul")  b reg1 ri reg2
1885 pprInstr (UMUL b reg1 ri reg2) = pprRegRIReg SLIT("umul")  b reg1 ri reg2
1886
1887 pprInstr (SETHI imm reg)
1888   = hcat [
1889         ptext SLIT("\tsethi\t"),
1890         pprImm imm,
1891         comma,
1892         pprReg reg
1893     ]
1894
1895 pprInstr NOP = ptext SLIT("\tnop")
1896
1897 pprInstr (FABS F32 reg1 reg2) = pprSizeRegReg SLIT("fabs") F32 reg1 reg2
1898 pprInstr (FABS F64 reg1 reg2)
1899   = (<>) (pprSizeRegReg SLIT("fabs") F32 reg1 reg2)
1900     (if (reg1 == reg2) then empty
1901      else (<>) (char '\n')
1902           (pprSizeRegReg SLIT("fmov") F32 (fPair reg1) (fPair reg2)))
1903
1904 pprInstr (FADD size reg1 reg2 reg3)
1905   = pprSizeRegRegReg SLIT("fadd") size reg1 reg2 reg3
1906 pprInstr (FCMP e size reg1 reg2)
1907   = pprSizeRegReg (if e then SLIT("fcmpe") else SLIT("fcmp")) size reg1 reg2
1908 pprInstr (FDIV size reg1 reg2 reg3)
1909   = pprSizeRegRegReg SLIT("fdiv") size reg1 reg2 reg3
1910
1911 pprInstr (FMOV F32 reg1 reg2) = pprSizeRegReg SLIT("fmov") F32 reg1 reg2
1912 pprInstr (FMOV F64 reg1 reg2)
1913   = (<>) (pprSizeRegReg SLIT("fmov") F32 reg1 reg2)
1914     (if (reg1 == reg2) then empty
1915      else (<>) (char '\n')
1916           (pprSizeRegReg SLIT("fmov") F32 (fPair reg1) (fPair reg2)))
1917
1918 pprInstr (FMUL size reg1 reg2 reg3)
1919   = pprSizeRegRegReg SLIT("fmul") size reg1 reg2 reg3
1920
1921 pprInstr (FNEG F32 reg1 reg2) = pprSizeRegReg SLIT("fneg") F32 reg1 reg2
1922 pprInstr (FNEG F64 reg1 reg2)
1923   = (<>) (pprSizeRegReg SLIT("fneg") F32 reg1 reg2)
1924     (if (reg1 == reg2) then empty
1925      else (<>) (char '\n')
1926           (pprSizeRegReg SLIT("fmov") F32 (fPair reg1) (fPair reg2)))
1927
1928 pprInstr (FSQRT size reg1 reg2)     = pprSizeRegReg SLIT("fsqrt") size reg1 reg2
1929 pprInstr (FSUB size reg1 reg2 reg3) = pprSizeRegRegReg SLIT("fsub") size reg1 reg2 reg3
1930 pprInstr (FxTOy size1 size2 reg1 reg2)
1931   = hcat [
1932         ptext SLIT("\tf"),
1933         ptext
1934         (case size1 of
1935             I32  -> SLIT("ito")
1936             F32  -> SLIT("sto")
1937             F64  -> SLIT("dto")),
1938         ptext
1939         (case size2 of
1940             I32  -> SLIT("i\t")
1941             F32  -> SLIT("s\t")
1942             F64  -> SLIT("d\t")),
1943         pprReg reg1, comma, pprReg reg2
1944     ]
1945
1946
1947 pprInstr (BI cond b lab)
1948   = hcat [
1949         ptext SLIT("\tb"), pprCond cond,
1950         if b then pp_comma_a else empty,
1951         char '\t',
1952         pprImm lab
1953     ]
1954
1955 pprInstr (BF cond b lab)
1956   = hcat [
1957         ptext SLIT("\tfb"), pprCond cond,
1958         if b then pp_comma_a else empty,
1959         char '\t',
1960         pprImm lab
1961     ]
1962
1963 pprInstr (JMP addr) = (<>) (ptext SLIT("\tjmp\t")) (pprAddr addr)
1964
1965 pprInstr (CALL (Left imm) n _)
1966   = hcat [ ptext SLIT("\tcall\t"), pprImm imm, comma, int n ]
1967 pprInstr (CALL (Right reg) n _)
1968   = hcat [ ptext SLIT("\tcall\t"), pprReg reg, comma, int n ]
1969
1970 pprRI :: RI -> Doc
1971 pprRI (RIReg r) = pprReg r
1972 pprRI (RIImm r) = pprImm r
1973
1974 pprSizeRegReg :: LitString -> MachRep -> Reg -> Reg -> Doc
1975 pprSizeRegReg name size reg1 reg2
1976   = hcat [
1977         char '\t',
1978         ptext name,
1979         (case size of
1980             F32  -> ptext SLIT("s\t")
1981             F64 -> ptext SLIT("d\t")),
1982         pprReg reg1,
1983         comma,
1984         pprReg reg2
1985     ]
1986
1987 pprSizeRegRegReg :: LitString -> MachRep -> Reg -> Reg -> Reg -> Doc
1988 pprSizeRegRegReg name size reg1 reg2 reg3
1989   = hcat [
1990         char '\t',
1991         ptext name,
1992         (case size of
1993             F32  -> ptext SLIT("s\t")
1994             F64  -> ptext SLIT("d\t")),
1995         pprReg reg1,
1996         comma,
1997         pprReg reg2,
1998         comma,
1999         pprReg reg3
2000     ]
2001
2002 pprRegRIReg :: LitString -> Bool -> Reg -> RI -> Reg -> Doc
2003 pprRegRIReg name b reg1 ri reg2
2004   = hcat [
2005         char '\t',
2006         ptext name,
2007         if b then ptext SLIT("cc\t") else char '\t',
2008         pprReg reg1,
2009         comma,
2010         pprRI ri,
2011         comma,
2012         pprReg reg2
2013     ]
2014
2015 pprRIReg :: LitString -> Bool -> RI -> Reg -> Doc
2016 pprRIReg name b ri reg1
2017   = hcat [
2018         char '\t',
2019         ptext name,
2020         if b then ptext SLIT("cc\t") else char '\t',
2021         pprRI ri,
2022         comma,
2023         pprReg reg1
2024     ]
2025
2026 pp_ld_lbracket    = ptext SLIT("\tld\t[")
2027 pp_rbracket_comma = text "],"
2028 pp_comma_lbracket = text ",["
2029 pp_comma_a        = text ",a"
2030
2031 #endif /* sparc_TARGET_ARCH */
2032
2033
2034 -- -----------------------------------------------------------------------------
2035 -- pprInstr for PowerPC
2036
2037 #if powerpc_TARGET_ARCH
2038 pprInstr (LD sz reg addr) = hcat [
2039         char '\t',
2040         ptext SLIT("l"),
2041         ptext (case sz of
2042             I8  -> SLIT("bz")
2043             I16 -> SLIT("hz")
2044             I32 -> SLIT("wz")
2045             F32 -> SLIT("fs")
2046             F64 -> SLIT("fd")),
2047         case addr of AddrRegImm _ _ -> empty
2048                      AddrRegReg _ _ -> char 'x',
2049         char '\t',
2050         pprReg reg,
2051         ptext SLIT(", "),
2052         pprAddr addr
2053     ]
2054 pprInstr (LA sz reg addr) = hcat [
2055         char '\t',
2056         ptext SLIT("l"),
2057         ptext (case sz of
2058             I8  -> SLIT("ba")
2059             I16 -> SLIT("ha")
2060             I32 -> SLIT("wa")
2061             F32 -> SLIT("fs")
2062             F64 -> SLIT("fd")),
2063         case addr of AddrRegImm _ _ -> empty
2064                      AddrRegReg _ _ -> char 'x',
2065         char '\t',
2066         pprReg reg,
2067         ptext SLIT(", "),
2068         pprAddr addr
2069     ]
2070 pprInstr (ST sz reg addr) = hcat [
2071         char '\t',
2072         ptext SLIT("st"),
2073         pprSize sz,
2074         case addr of AddrRegImm _ _ -> empty
2075                      AddrRegReg _ _ -> char 'x',
2076         char '\t',
2077         pprReg reg,
2078         ptext SLIT(", "),
2079         pprAddr addr
2080     ]
2081 pprInstr (STU sz reg addr) = hcat [
2082         char '\t',
2083         ptext SLIT("st"),
2084         pprSize sz,
2085         ptext SLIT("u\t"),
2086         case addr of AddrRegImm _ _ -> empty
2087                      AddrRegReg _ _ -> char 'x',
2088         pprReg reg,
2089         ptext SLIT(", "),
2090         pprAddr addr
2091     ]
2092 pprInstr (LIS reg imm) = hcat [
2093         char '\t',
2094         ptext SLIT("lis"),
2095         char '\t',
2096         pprReg reg,
2097         ptext SLIT(", "),
2098         pprImm imm
2099     ]
2100 pprInstr (LI reg imm) = hcat [
2101         char '\t',
2102         ptext SLIT("li"),
2103         char '\t',
2104         pprReg reg,
2105         ptext SLIT(", "),
2106         pprImm imm
2107     ]
2108 pprInstr (MR reg1 reg2)
2109     | reg1 == reg2 = empty
2110     | otherwise = hcat [
2111         char '\t',
2112         case regClass reg1 of
2113             RcInteger -> ptext SLIT("mr")
2114             _ -> ptext SLIT("fmr"),
2115         char '\t',
2116         pprReg reg1,
2117         ptext SLIT(", "),
2118         pprReg reg2
2119     ]
2120 pprInstr (CMP sz reg ri) = hcat [
2121         char '\t',
2122         op,
2123         char '\t',
2124         pprReg reg,
2125         ptext SLIT(", "),
2126         pprRI ri
2127     ]
2128     where
2129         op = hcat [
2130                 ptext SLIT("cmp"),
2131                 pprSize sz,
2132                 case ri of
2133                     RIReg _ -> empty
2134                     RIImm _ -> char 'i'
2135             ]
2136 pprInstr (CMPL sz reg ri) = hcat [
2137         char '\t',
2138         op,
2139         char '\t',
2140         pprReg reg,
2141         ptext SLIT(", "),
2142         pprRI ri
2143     ]
2144     where
2145         op = hcat [
2146                 ptext SLIT("cmpl"),
2147                 pprSize sz,
2148                 case ri of
2149                     RIReg _ -> empty
2150                     RIImm _ -> char 'i'
2151             ]
2152 pprInstr (BCC cond (BlockId id)) = hcat [
2153         char '\t',
2154         ptext SLIT("b"),
2155         pprCond cond,
2156         char '\t',
2157         pprCLabel_asm lbl
2158     ]
2159     where lbl = mkAsmTempLabel id
2160
2161 pprInstr (JMP lbl) = hcat [ -- an alias for b that takes a CLabel
2162         char '\t',
2163         ptext SLIT("b"),
2164         char '\t',
2165         pprCLabel_asm lbl
2166     ]
2167
2168 pprInstr (MTCTR reg) = hcat [
2169         char '\t',
2170         ptext SLIT("mtctr"),
2171         char '\t',
2172         pprReg reg
2173     ]
2174 pprInstr (BCTR _) = hcat [
2175         char '\t',
2176         ptext SLIT("bctr")
2177     ]
2178 pprInstr (BL lbl _) = hcat [
2179         ptext SLIT("\tbl\t"),
2180         pprCLabel_asm lbl
2181     ]
2182 pprInstr (BCTRL _) = hcat [
2183         char '\t',
2184         ptext SLIT("bctrl")
2185     ]
2186 pprInstr (ADD reg1 reg2 ri) = pprLogic SLIT("add") reg1 reg2 ri
2187 pprInstr (ADDIS reg1 reg2 imm) = hcat [
2188         char '\t',
2189         ptext SLIT("addis"),
2190         char '\t',
2191         pprReg reg1,
2192         ptext SLIT(", "),
2193         pprReg reg2,
2194         ptext SLIT(", "),
2195         pprImm imm
2196     ]
2197
2198 pprInstr (ADDC reg1 reg2 reg3) = pprLogic SLIT("addc") reg1 reg2 (RIReg reg3)
2199 pprInstr (ADDE reg1 reg2 reg3) = pprLogic SLIT("adde") reg1 reg2 (RIReg reg3)
2200 pprInstr (SUBF reg1 reg2 reg3) = pprLogic SLIT("subf") reg1 reg2 (RIReg reg3)
2201 pprInstr (MULLW reg1 reg2 ri@(RIReg _)) = pprLogic SLIT("mullw") reg1 reg2 ri
2202 pprInstr (MULLW reg1 reg2 ri@(RIImm _)) = pprLogic SLIT("mull") reg1 reg2 ri
2203 pprInstr (DIVW reg1 reg2 reg3) = pprLogic SLIT("divw") reg1 reg2 (RIReg reg3)
2204 pprInstr (DIVWU reg1 reg2 reg3) = pprLogic SLIT("divwu") reg1 reg2 (RIReg reg3)
2205
2206 pprInstr (MULLW_MayOflo reg1 reg2 reg3) = vcat [
2207          hcat [ ptext SLIT("\tmullwo\t"), pprReg reg1, ptext SLIT(", "),
2208                                           pprReg reg2, ptext SLIT(", "),
2209                                           pprReg reg3 ],
2210          hcat [ ptext SLIT("\tmfxer\t"),  pprReg reg1 ],
2211          hcat [ ptext SLIT("\trlwinm\t"), pprReg reg1, ptext SLIT(", "),
2212                                           pprReg reg1, ptext SLIT(", "),
2213                                           ptext SLIT("2, 31, 31") ]
2214     ]
2215
2216         -- for some reason, "andi" doesn't exist.
2217         -- we'll use "andi." instead.
2218 pprInstr (AND reg1 reg2 (RIImm imm)) = hcat [
2219         char '\t',
2220         ptext SLIT("andi."),
2221         char '\t',
2222         pprReg reg1,
2223         ptext SLIT(", "),
2224         pprReg reg2,
2225         ptext SLIT(", "),
2226         pprImm imm
2227     ]
2228 pprInstr (AND reg1 reg2 ri) = pprLogic SLIT("and") reg1 reg2 ri
2229
2230 pprInstr (OR reg1 reg2 ri) = pprLogic SLIT("or") reg1 reg2 ri
2231 pprInstr (XOR reg1 reg2 ri) = pprLogic SLIT("xor") reg1 reg2 ri
2232
2233 pprInstr (XORIS reg1 reg2 imm) = hcat [
2234         char '\t',
2235         ptext SLIT("xoris"),
2236         char '\t',
2237         pprReg reg1,
2238         ptext SLIT(", "),
2239         pprReg reg2,
2240         ptext SLIT(", "),
2241         pprImm imm
2242     ]
2243
2244 pprInstr (EXTS sz reg1 reg2) = hcat [
2245         char '\t',
2246         ptext SLIT("exts"),
2247         pprSize sz,
2248         char '\t',
2249         pprReg reg1,
2250         ptext SLIT(", "),
2251         pprReg reg2
2252     ]
2253
2254 pprInstr (NEG reg1 reg2) = pprUnary SLIT("neg") reg1 reg2
2255 pprInstr (NOT reg1 reg2) = pprUnary SLIT("not") reg1 reg2
2256
2257 pprInstr (SLW reg1 reg2 ri) = pprLogic SLIT("slw") reg1 reg2 (limitShiftRI ri)
2258 pprInstr (SRW reg1 reg2 ri) = pprLogic SLIT("srw") reg1 reg2 (limitShiftRI ri)
2259 pprInstr (SRAW reg1 reg2 ri) = pprLogic SLIT("sraw") reg1 reg2 (limitShiftRI ri)
2260 pprInstr (RLWINM reg1 reg2 sh mb me) = hcat [
2261         ptext SLIT("\trlwinm\t"),
2262         pprReg reg1,
2263         ptext SLIT(", "),
2264         pprReg reg2,
2265         ptext SLIT(", "),
2266         int sh,
2267         ptext SLIT(", "),
2268         int mb,
2269         ptext SLIT(", "),
2270         int me
2271     ]
2272
2273 pprInstr (FADD sz reg1 reg2 reg3) = pprBinaryF SLIT("fadd") sz reg1 reg2 reg3
2274 pprInstr (FSUB sz reg1 reg2 reg3) = pprBinaryF SLIT("fsub") sz reg1 reg2 reg3
2275 pprInstr (FMUL sz reg1 reg2 reg3) = pprBinaryF SLIT("fmul") sz reg1 reg2 reg3
2276 pprInstr (FDIV sz reg1 reg2 reg3) = pprBinaryF SLIT("fdiv") sz reg1 reg2 reg3
2277 pprInstr (FNEG reg1 reg2) = pprUnary SLIT("fneg") reg1 reg2
2278
2279 pprInstr (FCMP reg1 reg2) = hcat [
2280         char '\t',
2281         ptext SLIT("fcmpu\tcr0, "),
2282             -- Note: we're using fcmpu, not fcmpo
2283             -- The difference is with fcmpo, compare with NaN is an invalid operation.
2284             -- We don't handle invalid fp ops, so we don't care
2285         pprReg reg1,
2286         ptext SLIT(", "),
2287         pprReg reg2
2288     ]
2289
2290 pprInstr (FCTIWZ reg1 reg2) = pprUnary SLIT("fctiwz") reg1 reg2
2291 pprInstr (FRSP reg1 reg2) = pprUnary SLIT("frsp") reg1 reg2
2292
2293 pprInstr (CRNOR dst src1 src2) = hcat [
2294         ptext SLIT("\tcrnor\t"),
2295         int dst,
2296         ptext SLIT(", "),
2297         int src1,
2298         ptext SLIT(", "),
2299         int src2
2300     ]
2301
2302 pprInstr (MFCR reg) = hcat [
2303         char '\t',
2304         ptext SLIT("mfcr"),
2305         char '\t',
2306         pprReg reg
2307     ]
2308
2309 pprInstr (MFLR reg) = hcat [
2310         char '\t',
2311         ptext SLIT("mflr"),
2312         char '\t',
2313         pprReg reg
2314     ]
2315
2316 pprInstr (FETCHPC reg) = vcat [
2317         ptext SLIT("\tbcl\t20,31,1f"),
2318         hcat [ ptext SLIT("1:\tmflr\t"), pprReg reg ]
2319     ]
2320
2321 pprInstr _ = panic "pprInstr (ppc)"
2322
2323 pprLogic op reg1 reg2 ri = hcat [
2324         char '\t',
2325         ptext op,
2326         case ri of
2327             RIReg _ -> empty
2328             RIImm _ -> char 'i',
2329         char '\t',
2330         pprReg reg1,
2331         ptext SLIT(", "),
2332         pprReg reg2,
2333         ptext SLIT(", "),
2334         pprRI ri
2335     ]
2336
2337 pprUnary op reg1 reg2 = hcat [
2338         char '\t',
2339         ptext op,
2340         char '\t',
2341         pprReg reg1,
2342         ptext SLIT(", "),
2343         pprReg reg2
2344     ]
2345
2346 pprBinaryF op sz reg1 reg2 reg3 = hcat [
2347         char '\t',
2348         ptext op,
2349         pprFSize sz,
2350         char '\t',
2351         pprReg reg1,
2352         ptext SLIT(", "),
2353         pprReg reg2,
2354         ptext SLIT(", "),
2355         pprReg reg3
2356     ]
2357
2358 pprRI :: RI -> Doc
2359 pprRI (RIReg r) = pprReg r
2360 pprRI (RIImm r) = pprImm r
2361
2362 pprFSize F64 = empty
2363 pprFSize F32 = char 's'
2364
2365     -- limit immediate argument for shift instruction to range 0..32
2366     -- (yes, the maximum is really 32, not 31)
2367 limitShiftRI :: RI -> RI
2368 limitShiftRI (RIImm (ImmInt i)) | i > 32 || i < 0 = RIImm (ImmInt 32)
2369 limitShiftRI x = x
2370
2371 #endif /* powerpc_TARGET_ARCH */
2372
2373
2374 -- -----------------------------------------------------------------------------
2375 -- Converting floating-point literals to integrals for printing
2376
2377 #if __GLASGOW_HASKELL__ >= 504
2378 newFloatArray :: (Int,Int) -> ST s (STUArray s Int Float)
2379 newFloatArray = newArray_
2380
2381 newDoubleArray :: (Int,Int) -> ST s (STUArray s Int Double)
2382 newDoubleArray = newArray_
2383
2384 castFloatToCharArray :: STUArray s Int Float -> ST s (STUArray s Int Word8)
2385 castFloatToCharArray = castSTUArray
2386
2387 castDoubleToCharArray :: STUArray s Int Double -> ST s (STUArray s Int Word8)
2388 castDoubleToCharArray = castSTUArray
2389
2390 writeFloatArray :: STUArray s Int Float -> Int -> Float -> ST s ()
2391 writeFloatArray = writeArray
2392
2393 writeDoubleArray :: STUArray s Int Double -> Int -> Double -> ST s ()
2394 writeDoubleArray = writeArray
2395
2396 readCharArray :: STUArray s Int Word8 -> Int -> ST s Char
2397 readCharArray arr i = do
2398   w <- readArray arr i
2399   return $! (chr (fromIntegral w))
2400
2401 #else
2402
2403 castFloatToCharArray :: MutableByteArray s t -> ST s (MutableByteArray s t)
2404 castFloatToCharArray = return
2405
2406 castDoubleToCharArray :: MutableByteArray s t -> ST s (MutableByteArray s t)
2407
2408
2409 castDoubleToCharArray = return
2410
2411 #endif
2412
2413 -- floatToBytes and doubleToBytes convert to the host's byte
2414 -- order.  Providing that we're not cross-compiling for a
2415 -- target with the opposite endianness, this should work ok
2416 -- on all targets.
2417
2418 -- ToDo: this stuff is very similar to the shenanigans in PprAbs,
2419 -- could they be merged?
2420
2421 floatToBytes :: Float -> [Int]
2422 floatToBytes f
2423    = runST (do
2424         arr <- newFloatArray ((0::Int),3)
2425         writeFloatArray arr 0 f
2426         arr <- castFloatToCharArray arr
2427         i0 <- readCharArray arr 0
2428         i1 <- readCharArray arr 1
2429         i2 <- readCharArray arr 2
2430         i3 <- readCharArray arr 3
2431         return (map ord [i0,i1,i2,i3])
2432      )
2433
2434 doubleToBytes :: Double -> [Int]
2435 doubleToBytes d
2436    = runST (do
2437         arr <- newDoubleArray ((0::Int),7)
2438         writeDoubleArray arr 0 d
2439         arr <- castDoubleToCharArray arr
2440         i0 <- readCharArray arr 0
2441         i1 <- readCharArray arr 1
2442         i2 <- readCharArray arr 2
2443         i3 <- readCharArray arr 3
2444         i4 <- readCharArray arr 4
2445         i5 <- readCharArray arr 5
2446         i6 <- readCharArray arr 6
2447         i7 <- readCharArray arr 7
2448         return (map ord [i0,i1,i2,i3,i4,i5,i6,i7])
2449      )