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