compiler/nativeGen/PprMach.hs

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