ghc/compiler/nativeGen/PprMach.hs

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