ghc/compiler/nativeGen/PprMach.hs

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