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 s) <> int bytes
 697     where s =
 698 #if defined(solaris2_TARGET_OS)
 699               ".skip "
 700 #else
 701               ".space "
 702 #endif
 703 pprData (CmmStaticLit lit)       = pprDataItem lit
 704
 705 pprGloblDecl :: CLabel -> Doc
 706 pprGloblDecl lbl
 707   | not (externallyVisibleCLabel lbl) = empty
 708   | otherwise = ptext IF_ARCH_sparc((sLit ".global "),
 709                                     (sLit ".globl ")) <>
 710                 pprCLabel_asm lbl
 711
 712 pprTypeAndSizeDecl :: CLabel -> Doc
 713 pprTypeAndSizeDecl lbl
 714 #if linux_TARGET_OS
 715   | not (externallyVisibleCLabel lbl) = empty
 716   | otherwise = ptext (sLit ".type ") <>
 717                 pprCLabel_asm lbl <> ptext (sLit ", @object")
 718 #else
 719   = empty
 720 #endif
 721
 722 pprLabel :: CLabel -> Doc
 723 pprLabel lbl = pprGloblDecl lbl $$ pprTypeAndSizeDecl lbl $$ (pprCLabel_asm lbl <> char ':')
 724
 725
 726 pprASCII str
 727   = vcat (map do1 str) $$ do1 0
 728     where
 729        do1 :: Word8 -> Doc
 730        do1 w = ptext (sLit "\t.byte\t") <> int (fromIntegral w)
 731
 732 pprAlign bytes =
 733         IF_ARCH_alpha(ptext (sLit ".align ") <> int pow2,
 734         IF_ARCH_i386(ptext (sLit ".align ") <> int IF_OS_darwin(pow2,bytes),
 735         IF_ARCH_x86_64(ptext (sLit ".align ") <> int IF_OS_darwin(pow2,bytes),
 736         IF_ARCH_sparc(ptext (sLit ".align ") <> int bytes,
 737         IF_ARCH_powerpc(ptext (sLit ".align ") <> int pow2,)))))
 738   where
 739         pow2 = log2 bytes
 740
 741         log2 :: Int -> Int  -- cache the common ones
 742         log2 1 = 0
 743         log2 2 = 1
 744         log2 4 = 2
 745         log2 8 = 3
 746         log2 n = 1 + log2 (n `quot` 2)
 747
 748
 749 pprDataItem :: CmmLit -> Doc
 750 pprDataItem lit
 751   = vcat (ppr_item (cmmTypeSize $ cmmLitType lit) lit)
 752     where
 753         imm = litToImm lit
 754
 755         -- These seem to be common:
 756         ppr_item II8   x = [ptext (sLit "\t.byte\t") <> pprImm imm]
 757         ppr_item II32  x = [ptext (sLit "\t.long\t") <> pprImm imm]
 758         ppr_item FF32  (CmmFloat r _)
 759            = let bs = floatToBytes (fromRational r)
 760              in  map (\b -> ptext (sLit "\t.byte\t") <> pprImm (ImmInt b)) bs
 761         ppr_item FF64 (CmmFloat r _)
 762            = let bs = doubleToBytes (fromRational r)
 763              in  map (\b -> ptext (sLit "\t.byte\t") <> pprImm (ImmInt b)) bs
 764
 765 #if sparc_TARGET_ARCH
 766         -- copy n paste of x86 version
 767         ppr_item II16  x = [ptext (sLit "\t.short\t") <> pprImm imm]
 768         ppr_item II64  x = [ptext (sLit "\t.quad\t") <> pprImm imm]
 769 #endif
 770 #if i386_TARGET_ARCH || x86_64_TARGET_ARCH
 771         ppr_item II16  x = [ptext (sLit "\t.word\t") <> pprImm imm]
 772 #endif
 773 #if i386_TARGET_ARCH && darwin_TARGET_OS
 774         ppr_item II64 (CmmInt x _)  =
 775                 [ptext (sLit "\t.long\t")
 776                     <> int (fromIntegral (fromIntegral x :: Word32)),
 777                  ptext (sLit "\t.long\t")
 778                     <> int (fromIntegral
 779                         (fromIntegral (x `shiftR` 32) :: Word32))]
 780 #endif
 781 #if i386_TARGET_ARCH || (darwin_TARGET_OS && x86_64_TARGET_ARCH)
 782         ppr_item II64  x = [ptext (sLit "\t.quad\t") <> pprImm imm]
 783 #endif
 784 #if x86_64_TARGET_ARCH && !darwin_TARGET_OS
 785         -- x86_64: binutils can't handle the R_X86_64_PC64 relocation
 786         -- type, which means we can't do pc-relative 64-bit addresses.
 787         -- Fortunately we're assuming the small memory model, in which
 788         -- all such offsets will fit into 32 bits, so we have to stick
 789         -- to 32-bit offset fields and modify the RTS appropriately
 790         --
 791         -- See Note [x86-64-relative] in includes/InfoTables.h
 792         --
 793         ppr_item II64  x
 794            | isRelativeReloc x =
 795                 [ptext (sLit "\t.long\t") <> pprImm imm,
 796                  ptext (sLit "\t.long\t0")]
 797            | otherwise =
 798                 [ptext (sLit "\t.quad\t") <> pprImm imm]
 799            where
 800                 isRelativeReloc (CmmLabelDiffOff _ _ _) = True
 801                 isRelativeReloc _ = False
 802 #endif
 803 #if powerpc_TARGET_ARCH
 804         ppr_item II16 x = [ptext (sLit "\t.short\t") <> pprImm imm]
 805         ppr_item II64 (CmmInt x _)  =
 806                 [ptext (sLit "\t.long\t")
 807                     <> int (fromIntegral
 808                         (fromIntegral (x `shiftR` 32) :: Word32)),
 809                  ptext (sLit "\t.long\t")
 810                     <> int (fromIntegral (fromIntegral x :: Word32))]
 811 #endif
 812
 813 -- fall through to rest of (machine-specific) pprInstr...
 814
 815 -- -----------------------------------------------------------------------------
 816 -- pprInstr: print an 'Instr'
 817
 818 instance Outputable Instr where
 819     ppr  instr  = Outputable.docToSDoc $ pprInstr instr
 820
 821 pprInstr :: Instr -> Doc
 822
 823 pprInstr (COMMENT s) = empty -- nuke 'em
 824 {-
 825 pprInstr (COMMENT s)
 826    =  IF_ARCH_alpha( ((<>) (ptext (sLit "\t# ")) (ftext s))
 827      ,IF_ARCH_sparc( ((<>) (ptext (sLit "# "))   (ftext s))
 828      ,IF_ARCH_i386( ((<>) (ptext (sLit "# "))   (ftext s))
 829      ,IF_ARCH_x86_64( ((<>) (ptext (sLit "# "))   (ftext s))
 830      ,IF_ARCH_powerpc( IF_OS_linux(
 831         ((<>) (ptext (sLit "# ")) (ftext s)),
 832         ((<>) (ptext (sLit "; ")) (ftext s)))
 833      ,)))))
 834 -}
 835 pprInstr (DELTA d)
 836    = pprInstr (COMMENT (mkFastString ("\tdelta = " ++ show d)))
 837
 838 pprInstr (NEWBLOCK _)
 839    = panic "PprMach.pprInstr: NEWBLOCK"
 840
 841 pprInstr (LDATA _ _)
 842    = panic "PprMach.pprInstr: LDATA"
 843
 844 -- -----------------------------------------------------------------------------
 845 -- pprInstr for an Alpha
 846
 847 #if alpha_TARGET_ARCH
 848
 849 pprInstr (SPILL reg slot)
 850    = hcat [
 851         ptext (sLit "\tSPILL"),
 852         char '\t',
 853         pprReg reg,
 854         comma,
 855         ptext (sLit "SLOT") <> parens (int slot)]
 856
 857 pprInstr (RELOAD slot reg)
 858    = hcat [
 859         ptext (sLit "\tRELOAD"),
 860         char '\t',
 861         ptext (sLit "SLOT") <> parens (int slot),
 862         comma,
 863         pprReg reg]
 864
 865 pprInstr (LD size reg addr)
 866   = hcat [
 867         ptext (sLit "\tld"),
 868         pprSize size,
 869         char '\t',
 870         pprReg reg,
 871         comma,
 872         pprAddr addr
 873     ]
 874
 875 pprInstr (LDA reg addr)
 876   = hcat [
 877         ptext (sLit "\tlda\t"),
 878         pprReg reg,
 879         comma,
 880         pprAddr addr
 881     ]
 882
 883 pprInstr (LDAH reg addr)
 884   = hcat [
 885         ptext (sLit "\tldah\t"),
 886         pprReg reg,
 887         comma,
 888         pprAddr addr
 889     ]
 890
 891 pprInstr (LDGP reg addr)
 892   = hcat [
 893         ptext (sLit "\tldgp\t"),
 894         pprReg reg,
 895         comma,
 896         pprAddr addr
 897     ]
 898
 899 pprInstr (LDI size reg imm)
 900   = hcat [
 901         ptext (sLit "\tldi"),
 902         pprSize size,
 903         char '\t',
 904         pprReg reg,
 905         comma,
 906         pprImm imm
 907     ]
 908
 909 pprInstr (ST size reg addr)
 910   = hcat [
 911         ptext (sLit "\tst"),
 912         pprSize size,
 913         char '\t',
 914         pprReg reg,
 915         comma,
 916         pprAddr addr
 917     ]
 918
 919 pprInstr (CLR reg)
 920   = hcat [
 921         ptext (sLit "\tclr\t"),
 922         pprReg reg
 923     ]
 924
 925 pprInstr (ABS size ri reg)
 926   = hcat [
 927         ptext (sLit "\tabs"),
 928         pprSize size,
 929         char '\t',
 930         pprRI ri,
 931         comma,
 932         pprReg reg
 933     ]
 934
 935 pprInstr (NEG size ov ri reg)
 936   = hcat [
 937         ptext (sLit "\tneg"),
 938         pprSize size,
 939         if ov then ptext (sLit "v\t") else char '\t',
 940         pprRI ri,
 941         comma,
 942         pprReg reg
 943     ]
 944
 945 pprInstr (ADD size ov reg1 ri reg2)
 946   = hcat [
 947         ptext (sLit "\tadd"),
 948         pprSize size,
 949         if ov then ptext (sLit "v\t") else char '\t',
 950         pprReg reg1,
 951         comma,
 952         pprRI ri,
 953         comma,
 954         pprReg reg2
 955     ]
 956
 957 pprInstr (SADD size scale reg1 ri reg2)
 958   = hcat [
 959         ptext (case scale of {{-UNUSED:L -> (sLit "\ts4");-} Q -> (sLit "\ts8")}),
 960         ptext (sLit "add"),
 961         pprSize size,
 962         char '\t',
 963         pprReg reg1,
 964         comma,
 965         pprRI ri,
 966         comma,
 967         pprReg reg2
 968     ]
 969
 970 pprInstr (SUB size ov reg1 ri reg2)
 971   = hcat [
 972         ptext (sLit "\tsub"),
 973         pprSize size,
 974         if ov then ptext (sLit "v\t") else char '\t',
 975         pprReg reg1,
 976         comma,
 977         pprRI ri,
 978         comma,
 979         pprReg reg2
 980     ]
 981
 982 pprInstr (SSUB size scale reg1 ri reg2)
 983   = hcat [
 984         ptext (case scale of {{-UNUSED:L -> (sLit "\ts4");-} Q -> (sLit "\ts8")}),
 985         ptext (sLit "sub"),
 986         pprSize size,
 987         char '\t',
 988         pprReg reg1,
 989         comma,
 990         pprRI ri,
 991         comma,
 992         pprReg reg2
 993     ]
 994
 995 pprInstr (MUL size ov reg1 ri reg2)
 996   = hcat [
 997         ptext (sLit "\tmul"),
 998         pprSize size,
 999         if ov then ptext (sLit "v\t") else char '\t',
1000         pprReg reg1,
1001         comma,
1002         pprRI ri,
1003         comma,
1004         pprReg reg2
1005     ]
1006
1007 pprInstr (DIV size uns reg1 ri reg2)
1008   = hcat [
1009         ptext (sLit "\tdiv"),
1010         pprSize size,
1011         if uns then ptext (sLit "u\t") else char '\t',
1012         pprReg reg1,
1013         comma,
1014         pprRI ri,
1015         comma,
1016         pprReg reg2
1017     ]
1018
1019 pprInstr (REM size uns reg1 ri reg2)
1020   = hcat [
1021         ptext (sLit "\trem"),
1022         pprSize size,
1023         if uns then ptext (sLit "u\t") else char '\t',
1024         pprReg reg1,
1025         comma,
1026         pprRI ri,
1027         comma,
1028         pprReg reg2
1029     ]
1030
1031 pprInstr (NOT ri reg)
1032   = hcat [
1033         ptext (sLit "\tnot"),
1034         char '\t',
1035         pprRI ri,
1036         comma,
1037         pprReg reg
1038     ]
1039
1040 pprInstr (AND reg1 ri reg2) = pprRegRIReg (sLit "and") reg1 ri reg2
1041 pprInstr (ANDNOT reg1 ri reg2) = pprRegRIReg (sLit "andnot") reg1 ri reg2
1042 pprInstr (OR reg1 ri reg2) = pprRegRIReg (sLit "or") reg1 ri reg2
1043 pprInstr (ORNOT reg1 ri reg2) = pprRegRIReg (sLit "ornot") reg1 ri reg2
1044 pprInstr (XOR reg1 ri reg2) = pprRegRIReg (sLit "xor") reg1 ri reg2
1045 pprInstr (XORNOT reg1 ri reg2) = pprRegRIReg (sLit "xornot") reg1 ri reg2
1046
1047 pprInstr (SLL reg1 ri reg2) = pprRegRIReg (sLit "sll") reg1 ri reg2
1048 pprInstr (SRL reg1 ri reg2) = pprRegRIReg (sLit "srl") reg1 ri reg2
1049 pprInstr (SRA reg1 ri reg2) = pprRegRIReg (sLit "sra") reg1 ri reg2
1050
1051 pprInstr (ZAP reg1 ri reg2) = pprRegRIReg (sLit "zap") reg1 ri reg2
1052 pprInstr (ZAPNOT reg1 ri reg2) = pprRegRIReg (sLit "zapnot") reg1 ri reg2
1053
1054 pprInstr (NOP) = ptext (sLit "\tnop")
1055
1056 pprInstr (CMP cond reg1 ri reg2)
1057   = hcat [
1058         ptext (sLit "\tcmp"),
1059         pprCond cond,
1060         char '\t',
1061         pprReg reg1,
1062         comma,
1063         pprRI ri,
1064         comma,
1065         pprReg reg2
1066     ]
1067
1068 pprInstr (FCLR reg)
1069   = hcat [
1070         ptext (sLit "\tfclr\t"),
1071         pprReg reg
1072     ]
1073
1074 pprInstr (FABS reg1 reg2)
1075   = hcat [
1076         ptext (sLit "\tfabs\t"),
1077         pprReg reg1,
1078         comma,
1079         pprReg reg2
1080     ]
1081
1082 pprInstr (FNEG size reg1 reg2)
1083   = hcat [
1084         ptext (sLit "\tneg"),
1085         pprSize size,
1086         char '\t',
1087         pprReg reg1,
1088         comma,
1089         pprReg reg2
1090     ]
1091
1092 pprInstr (FADD size reg1 reg2 reg3) = pprSizeRegRegReg (sLit "add") size reg1 reg2 reg3
1093 pprInstr (FDIV size reg1 reg2 reg3) = pprSizeRegRegReg (sLit "div") size reg1 reg2 reg3
1094 pprInstr (FMUL size reg1 reg2 reg3) = pprSizeRegRegReg (sLit "mul") size reg1 reg2 reg3
1095 pprInstr (FSUB size reg1 reg2 reg3) = pprSizeRegRegReg (sLit "sub") size reg1 reg2 reg3
1096
1097 pprInstr (CVTxy size1 size2 reg1 reg2)
1098   = hcat [
1099         ptext (sLit "\tcvt"),
1100         pprSize size1,
1101         case size2 of {Q -> ptext (sLit "qc"); _ -> pprSize size2},
1102         char '\t',
1103         pprReg reg1,
1104         comma,
1105         pprReg reg2
1106     ]
1107
1108 pprInstr (FCMP size cond reg1 reg2 reg3)
1109   = hcat [
1110         ptext (sLit "\tcmp"),
1111         pprSize size,
1112         pprCond cond,
1113         char '\t',
1114         pprReg reg1,
1115         comma,
1116         pprReg reg2,
1117         comma,
1118         pprReg reg3
1119     ]
1120
1121 pprInstr (FMOV reg1 reg2)
1122   = hcat [
1123         ptext (sLit "\tfmov\t"),
1124         pprReg reg1,
1125         comma,
1126         pprReg reg2
1127     ]
1128
1129 pprInstr (BI ALWAYS reg lab) = pprInstr (BR lab)
1130
1131 pprInstr (BI NEVER reg lab) = empty
1132
1133 pprInstr (BI cond reg lab)
1134   = hcat [
1135         ptext (sLit "\tb"),
1136         pprCond cond,
1137         char '\t',
1138         pprReg reg,
1139         comma,
1140         pprImm lab
1141     ]
1142
1143 pprInstr (BF cond reg lab)
1144   = hcat [
1145         ptext (sLit "\tfb"),
1146         pprCond cond,
1147         char '\t',
1148         pprReg reg,
1149         comma,
1150         pprImm lab
1151     ]
1152
1153 pprInstr (BR lab)
1154   = (<>) (ptext (sLit "\tbr\t")) (pprImm lab)
1155
1156 pprInstr (JMP reg addr hint)
1157   = hcat [
1158         ptext (sLit "\tjmp\t"),
1159         pprReg reg,
1160         comma,
1161         pprAddr addr,
1162         comma,
1163         int hint
1164     ]
1165
1166 pprInstr (BSR imm n)
1167   = (<>) (ptext (sLit "\tbsr\t")) (pprImm imm)
1168
1169 pprInstr (JSR reg addr n)
1170   = hcat [
1171         ptext (sLit "\tjsr\t"),
1172         pprReg reg,
1173         comma,
1174         pprAddr addr
1175     ]
1176
1177 pprInstr (FUNBEGIN clab)
1178   = hcat [
1179         if (externallyVisibleCLabel clab) then
1180             hcat [ptext (sLit "\t.globl\t"), pp_lab, char '\n']
1181         else
1182             empty,
1183         ptext (sLit "\t.ent "),
1184         pp_lab,
1185         char '\n',
1186         pp_lab,
1187         pp_ldgp,
1188         pp_lab,
1189         pp_frame
1190     ]
1191     where
1192         pp_lab = pprCLabel_asm clab
1193
1194         -- NEVER use commas within those string literals, cpp will ruin your day
1195         pp_ldgp  = hcat [ ptext (sLit ":\n\tldgp $29"), char ',', ptext (sLit "0($27)\n") ]
1196         pp_frame = hcat [ ptext (sLit "..ng:\n\t.frame $30"), char ',',
1197                           ptext (sLit "4240"), char ',',
1198                           ptext (sLit "$26"), char ',',
1199                           ptext (sLit "0\n\t.prologue 1") ]
1200
1201 pprInstr (FUNEND clab)
1202   = (<>) (ptext (sLit "\t.align 4\n\t.end ")) (pprCLabel_asm clab)
1203 \end{code}
1204
1205 Continue with Alpha-only printing bits and bobs:
1206 \begin{code}
1207 pprRI :: RI -> Doc
1208
1209 pprRI (RIReg r) = pprReg r
1210 pprRI (RIImm r) = pprImm r
1211
1212 pprRegRIReg :: LitString -> Reg -> RI -> Reg -> Doc
1213 pprRegRIReg name reg1 ri reg2
1214   = hcat [
1215         char '\t',
1216         ptext name,
1217         char '\t',
1218         pprReg reg1,
1219         comma,
1220         pprRI ri,
1221         comma,
1222         pprReg reg2
1223     ]
1224
1225 pprSizeRegRegReg :: LitString -> Size -> Reg -> Reg -> Reg -> Doc
1226 pprSizeRegRegReg name size reg1 reg2 reg3
1227   = hcat [
1228         char '\t',
1229         ptext name,
1230         pprSize size,
1231         char '\t',
1232         pprReg reg1,
1233         comma,
1234         pprReg reg2,
1235         comma,
1236         pprReg reg3
1237     ]
1238
1239 #endif /* alpha_TARGET_ARCH */
1240
1241
1242 -- -----------------------------------------------------------------------------
1243 -- pprInstr for an x86
1244
1245 #if i386_TARGET_ARCH || x86_64_TARGET_ARCH
1246
1247 pprInstr (SPILL reg slot)
1248    = hcat [
1249         ptext (sLit "\tSPILL"),
1250         char ' ',
1251         pprUserReg reg,
1252         comma,
1253         ptext (sLit "SLOT") <> parens (int slot)]
1254
1255 pprInstr (RELOAD slot reg)
1256    = hcat [
1257         ptext (sLit "\tRELOAD"),
1258         char ' ',
1259         ptext (sLit "SLOT") <> parens (int slot),
1260         comma,
1261         pprUserReg reg]
1262
1263 pprInstr (MOV size src dst)
1264   = pprSizeOpOp (sLit "mov") size src dst
1265
1266 pprInstr (MOVZxL II32 src dst) = pprSizeOpOp (sLit "mov") II32 src dst
1267         -- 32-to-64 bit zero extension on x86_64 is accomplished by a simple
1268         -- movl.  But we represent it as a MOVZxL instruction, because
1269         -- the reg alloc would tend to throw away a plain reg-to-reg
1270         -- move, and we still want it to do that.
1271
1272 pprInstr (MOVZxL sizes src dst) = pprSizeOpOpCoerce (sLit "movz") sizes II32 src dst
1273         -- zero-extension only needs to extend to 32 bits: on x86_64,
1274         -- the remaining zero-extension to 64 bits is automatic, and the 32-bit
1275         -- instruction is shorter.
1276
1277 pprInstr (MOVSxL sizes src dst) = pprSizeOpOpCoerce (sLit "movs") sizes wordSize src dst
1278
1279 -- here we do some patching, since the physical registers are only set late
1280 -- in the code generation.
1281 pprInstr (LEA size (OpAddr (AddrBaseIndex src1@(EABaseReg reg1) (EAIndex reg2 1) (ImmInt 0))) dst@(OpReg reg3))
1282   | reg1 == reg3
1283   = pprSizeOpOp (sLit "add") size (OpReg reg2) dst
1284 pprInstr (LEA size (OpAddr (AddrBaseIndex src1@(EABaseReg reg1) (EAIndex reg2 1) (ImmInt 0))) dst@(OpReg reg3))
1285   | reg2 == reg3
1286   = pprSizeOpOp (sLit "add") size (OpReg reg1) dst
1287 pprInstr (LEA size (OpAddr (AddrBaseIndex src1@(EABaseReg reg1) EAIndexNone displ)) dst@(OpReg reg3))
1288   | reg1 == reg3
1289   = pprInstr (ADD size (OpImm displ) dst)
1290 pprInstr (LEA size src dst) = pprSizeOpOp (sLit "lea") size src dst
1291
1292 pprInstr (ADD size (OpImm (ImmInt (-1))) dst)
1293   = pprSizeOp (sLit "dec") size dst
1294 pprInstr (ADD size (OpImm (ImmInt 1)) dst)
1295   = pprSizeOp (sLit "inc") size dst
1296 pprInstr (ADD size src dst)
1297   = pprSizeOpOp (sLit "add") size src dst
1298 pprInstr (ADC size src dst)
1299   = pprSizeOpOp (sLit "adc") size src dst
1300 pprInstr (SUB size src dst) = pprSizeOpOp (sLit "sub") size src dst
1301 pprInstr (IMUL size op1 op2) = pprSizeOpOp (sLit "imul") size op1 op2
1302
1303 {- A hack.  The Intel documentation says that "The two and three
1304    operand forms [of IMUL] may also be used with unsigned operands
1305    because the lower half of the product is the same regardless if
1306    (sic) the operands are signed or unsigned.  The CF and OF flags,
1307    however, cannot be used to determine if the upper half of the
1308    result is non-zero."  So there.
1309 -}
1310 pprInstr (AND size src dst) = pprSizeOpOp (sLit "and") size src dst
1311 pprInstr (OR  size src dst) = pprSizeOpOp (sLit "or")  size src dst
1312
1313 pprInstr (XOR FF32 src dst) = pprOpOp (sLit "xorps") FF32 src dst
1314 pprInstr (XOR FF64 src dst) = pprOpOp (sLit "xorpd") FF64 src dst
1315 pprInstr (XOR size src dst) = pprSizeOpOp (sLit "xor")  size src dst
1316
1317 pprInstr (NOT size op) = pprSizeOp (sLit "not") size op
1318 pprInstr (NEGI size op) = pprSizeOp (sLit "neg") size op
1319
1320 pprInstr (SHL size src dst) = pprShift (sLit "shl") size src dst
1321 pprInstr (SAR size src dst) = pprShift (sLit "sar") size src dst
1322 pprInstr (SHR size src dst) = pprShift (sLit "shr") size src dst
1323
1324 pprInstr (BT  size imm src) = pprSizeImmOp (sLit "bt") size imm src
1325
1326 pprInstr (CMP size src dst)
1327   | is_float size =  pprSizeOpOp (sLit "ucomi") size src dst -- SSE2
1328   | otherwise     =  pprSizeOpOp (sLit "cmp")   size src dst
1329   where
1330         -- This predicate is needed here and nowhere else
1331     is_float FF32 = True
1332     is_float FF64 = True
1333     is_float FF80 = True
1334     is_float other = False
1335
1336 pprInstr (TEST size src dst) = pprSizeOpOp (sLit "test")  size src dst
1337 pprInstr (PUSH size op) = pprSizeOp (sLit "push") size op
1338 pprInstr (POP size op) = pprSizeOp (sLit "pop") size op
1339
1340 -- both unused (SDM):
1341 -- pprInstr PUSHA = ptext (sLit "\tpushal")
1342 -- pprInstr POPA = ptext (sLit "\tpopal")
1343
1344 pprInstr NOP = ptext (sLit "\tnop")
1345 pprInstr (CLTD II32) = ptext (sLit "\tcltd")
1346 pprInstr (CLTD II64) = ptext (sLit "\tcqto")
1347
1348 pprInstr (SETCC cond op) = pprCondInstr (sLit "set") cond (pprOperand II8 op)
1349
1350 pprInstr (JXX cond (BlockId id))
1351   = pprCondInstr (sLit "j") cond (pprCLabel_asm lab)
1352   where lab = mkAsmTempLabel id
1353
1354 pprInstr (JXX_GBL cond imm) = pprCondInstr (sLit "j") cond (pprImm imm)
1355
1356 pprInstr (JMP (OpImm imm)) = (<>) (ptext (sLit "\tjmp ")) (pprImm imm)
1357 pprInstr (JMP op)          = (<>) (ptext (sLit "\tjmp *")) (pprOperand wordSize op)
1358 pprInstr (JMP_TBL op ids)  = pprInstr (JMP op)
1359 pprInstr (CALL (Left imm) _)    = (<>) (ptext (sLit "\tcall ")) (pprImm imm)
1360 pprInstr (CALL (Right reg) _)   = (<>) (ptext (sLit "\tcall *")) (pprReg wordSize reg)
1361
1362 pprInstr (IDIV sz op)   = pprSizeOp (sLit "idiv") sz op
1363 pprInstr (DIV sz op)    = pprSizeOp (sLit "div")  sz op
1364 pprInstr (IMUL2 sz op)  = pprSizeOp (sLit "imul") sz op
1365
1366 #if x86_64_TARGET_ARCH
1367 pprInstr (MUL size op1 op2) = pprSizeOpOp (sLit "mul") size op1 op2
1368
1369 pprInstr (FDIV size op1 op2) = pprSizeOpOp (sLit "div") size op1 op2
1370
1371 pprInstr (CVTSS2SD from to)   = pprRegReg (sLit "cvtss2sd") from to
1372 pprInstr (CVTSD2SS from to)   = pprRegReg (sLit "cvtsd2ss") from to
1373 pprInstr (CVTTSS2SIQ from to) = pprOpReg  (sLit "cvttss2siq") from to
1374 pprInstr (CVTTSD2SIQ from to) = pprOpReg  (sLit "cvttsd2siq") from to
1375 pprInstr (CVTSI2SS from to)   = pprOpReg  (sLit "cvtsi2ssq") from to
1376 pprInstr (CVTSI2SD from to)   = pprOpReg  (sLit "cvtsi2sdq") from to
1377 #endif
1378
1379     -- FETCHGOT for PIC on ELF platforms
1380 pprInstr (FETCHGOT reg)
1381    = vcat [ ptext (sLit "\tcall 1f"),
1382             hcat [ ptext (sLit "1:\tpopl\t"), pprReg II32 reg ],
1383             hcat [ ptext (sLit "\taddl\t$_GLOBAL_OFFSET_TABLE_+(.-1b), "),
1384                    pprReg II32 reg ]
1385           ]
1386
1387     -- FETCHPC for PIC on Darwin/x86
1388     -- get the instruction pointer into a register
1389     -- (Terminology note: the IP is called Program Counter on PPC,
1390     --  and it's a good thing to use the same name on both platforms)
1391 pprInstr (FETCHPC reg)
1392    = vcat [ ptext (sLit "\tcall 1f"),
1393             hcat [ ptext (sLit "1:\tpopl\t"), pprReg II32 reg ]
1394           ]
1395
1396
1397
1398 #endif
1399
1400 -- -----------------------------------------------------------------------------
1401 -- i386 floating-point
1402
1403 #if i386_TARGET_ARCH
1404 -- Simulating a flat register set on the x86 FP stack is tricky.
1405 -- you have to free %st(7) before pushing anything on the FP reg stack
1406 -- so as to preclude the possibility of a FP stack overflow exception.
1407 pprInstr g@(GMOV src dst)
1408    | src == dst
1409    = empty
1410    | otherwise
1411    = pprG g (hcat [gtab, gpush src 0, gsemi, gpop dst 1])
1412
1413 -- GLD sz addr dst ==> FFREE %st(7) ; FLDsz addr ; FSTP (dst+1)
1414 pprInstr g@(GLD sz addr dst)
1415  = pprG g (hcat [gtab, text "ffree %st(7) ; fld", pprSize sz, gsp,
1416                  pprAddr addr, gsemi, gpop dst 1])
1417
1418 -- GST sz src addr ==> FFREE %st(7) ; FLD dst ; FSTPsz addr
1419 pprInstr g@(GST sz src addr)
1420  = pprG g (hcat [gtab, gpush src 0, gsemi,
1421                  text "fstp", pprSize sz, gsp, pprAddr addr])
1422
1423 pprInstr g@(GLDZ dst)
1424  = pprG g (hcat [gtab, text "ffree %st(7) ; fldz ; ", gpop dst 1])
1425 pprInstr g@(GLD1 dst)
1426  = pprG g (hcat [gtab, text "ffree %st(7) ; fld1 ; ", gpop dst 1])
1427
1428 pprInstr g@(GFTOI src dst)
1429    = pprInstr (GDTOI src dst)
1430 pprInstr g@(GDTOI src dst)
1431    = pprG g (vcat [
1432          hcat [gtab, text "subl $8, %esp ; fnstcw 4(%esp)"],
1433          hcat [gtab, gpush src 0],
1434          hcat [gtab, text "movzwl 4(%esp), ", reg,
1435                      text " ; orl $0xC00, ", reg],
1436          hcat [gtab, text "movl ", reg, text ", 0(%esp) ; fldcw 0(%esp)"],
1437          hcat [gtab, text "fistpl 0(%esp)"],
1438          hcat [gtab, text "fldcw 4(%esp) ; movl 0(%esp), ", reg],
1439          hcat [gtab, text "addl $8, %esp"]
1440      ])
1441    where
1442      reg = pprReg II32 dst
1443
1444 pprInstr g@(GITOF src dst)
1445    = pprInstr (GITOD src dst)
1446 pprInstr g@(GITOD src dst)
1447    = pprG g (hcat [gtab, text "pushl ", pprReg II32 src,
1448                    text " ; ffree %st(7); fildl (%esp) ; ",
1449                    gpop dst 1, text " ; addl $4,%esp"])
1450
1451 {- Gruesome swamp follows.  If you're unfortunate enough to have ventured
1452    this far into the jungle AND you give a Rat's Ass (tm) what's going
1453    on, here's the deal.  Generate code to do a floating point comparison
1454    of src1 and src2, of kind cond, and set the Zero flag if true.
1455
1456    The complications are to do with handling NaNs correctly.  We want the
1457    property that if either argument is NaN, then the result of the
1458    comparison is False ... except if we're comparing for inequality,
1459    in which case the answer is True.
1460
1461    Here's how the general (non-inequality) case works.  As an
1462    example, consider generating the an equality test:
1463
1464      pushl %eax         -- we need to mess with this
1465      <get src1 to top of FPU stack>
1466      fcomp <src2 location in FPU stack> and pop pushed src1
1467                 -- Result of comparison is in FPU Status Register bits
1468                 -- C3 C2 and C0
1469      fstsw %ax  -- Move FPU Status Reg to %ax
1470      sahf       -- move C3 C2 C0 from %ax to integer flag reg
1471      -- now the serious magic begins
1472      setpo %ah     -- %ah = if comparable(neither arg was NaN) then 1 else 0
1473      sete  %al     -- %al = if arg1 == arg2 then 1 else 0
1474      andb %ah,%al  -- %al &= %ah
1475                    -- so %al == 1 iff (comparable && same); else it holds 0
1476      decb %al      -- %al == 0, ZeroFlag=1  iff (comparable && same);
1477                       else %al == 0xFF, ZeroFlag=0
1478      -- the zero flag is now set as we desire.
1479      popl %eax
1480
1481    The special case of inequality differs thusly:
1482
1483      setpe %ah     -- %ah = if incomparable(either arg was NaN) then 1 else 0
1484      setne %al     -- %al = if arg1 /= arg2 then 1 else 0
1485      orb %ah,%al   -- %al = if (incomparable || different) then 1 else 0
1486      decb %al      -- if (incomparable || different) then (%al == 0, ZF=1)
1487                                                      else (%al == 0xFF, ZF=0)
1488 -}
1489 pprInstr g@(GCMP cond src1 src2)
1490    | case cond of { NE -> True; other -> False }
1491    = pprG g (vcat [
1492         hcat [gtab, text "pushl %eax ; ",gpush src1 0],
1493         hcat [gtab, text "fcomp ", greg src2 1,
1494                     text "; fstsw %ax ; sahf ;  setpe %ah"],
1495         hcat [gtab, text "setne %al ;  ",
1496               text "orb %ah,%al ;  decb %al ;  popl %eax"]
1497     ])
1498    | otherwise
1499    = pprG g (vcat [
1500         hcat [gtab, text "pushl %eax ; ",gpush src1 0],
1501         hcat [gtab, text "fcomp ", greg src2 1,
1502                     text "; fstsw %ax ; sahf ;  setpo %ah"],
1503         hcat [gtab, text "set", pprCond (fix_FP_cond cond), text " %al ;  ",
1504               text "andb %ah,%al ;  decb %al ;  popl %eax"]
1505     ])
1506     where
1507         {- On the 486, the flags set by FP compare are the unsigned ones!
1508            (This looks like a HACK to me.  WDP 96/03)
1509         -}
1510         fix_FP_cond :: Cond -> Cond
1511         fix_FP_cond GE   = GEU
1512         fix_FP_cond GTT  = GU
1513         fix_FP_cond LTT  = LU
1514         fix_FP_cond LE   = LEU
1515         fix_FP_cond EQQ  = EQQ
1516         fix_FP_cond NE   = NE
1517         -- there should be no others
1518
1519
1520 pprInstr g@(GABS sz src dst)
1521    = pprG g (hcat [gtab, gpush src 0, text " ; fabs ; ", gpop dst 1])
1522 pprInstr g@(GNEG sz src dst)
1523    = pprG g (hcat [gtab, gpush src 0, text " ; fchs ; ", gpop dst 1])
1524
1525 pprInstr g@(GSQRT sz src dst)
1526    = pprG g (hcat [gtab, gpush src 0, text " ; fsqrt"] $$
1527              hcat [gtab, gcoerceto sz, gpop dst 1])
1528 pprInstr g@(GSIN sz l1 l2 src dst)
1529    = pprG g (pprTrigOp "fsin" False l1 l2 src dst sz)
1530 pprInstr g@(GCOS sz l1 l2 src dst)
1531    = pprG g (pprTrigOp "fcos" False l1 l2 src dst sz)
1532 pprInstr g@(GTAN sz l1 l2 src dst)
1533    = pprG g (pprTrigOp "fptan" True l1 l2 src dst sz)
1534
1535 -- In the translations for GADD, GMUL, GSUB and GDIV,
1536 -- the first two cases are mere optimisations.  The otherwise clause
1537 -- generates correct code under all circumstances.
1538
1539 pprInstr g@(GADD sz src1 src2 dst)
1540    | src1 == dst
1541    = pprG g (text "\t#GADD-xxxcase1" $$
1542              hcat [gtab, gpush src2 0,
1543                    text " ; faddp %st(0),", greg src1 1])
1544    | src2 == dst
1545    = pprG g (text "\t#GADD-xxxcase2" $$
1546              hcat [gtab, gpush src1 0,
1547                    text " ; faddp %st(0),", greg src2 1])
1548    | otherwise
1549    = pprG g (hcat [gtab, gpush src1 0,
1550                    text " ; fadd ", greg src2 1, text ",%st(0)",
1551                    gsemi, gpop dst 1])
1552
1553
1554 pprInstr g@(GMUL sz src1 src2 dst)
1555    | src1 == dst
1556    = pprG g (text "\t#GMUL-xxxcase1" $$
1557              hcat [gtab, gpush src2 0,
1558                    text " ; fmulp %st(0),", greg src1 1])
1559    | src2 == dst
1560    = pprG g (text "\t#GMUL-xxxcase2" $$
1561              hcat [gtab, gpush src1 0,
1562                    text " ; fmulp %st(0),", greg src2 1])
1563    | otherwise
1564    = pprG g (hcat [gtab, gpush src1 0,
1565                    text " ; fmul ", greg src2 1, text ",%st(0)",
1566                    gsemi, gpop dst 1])
1567
1568
1569 pprInstr g@(GSUB sz src1 src2 dst)
1570    | src1 == dst
1571    = pprG g (text "\t#GSUB-xxxcase1" $$
1572              hcat [gtab, gpush src2 0,
1573                    text " ; fsubrp %st(0),", greg src1 1])
1574    | src2 == dst
1575    = pprG g (text "\t#GSUB-xxxcase2" $$
1576              hcat [gtab, gpush src1 0,
1577                    text " ; fsubp %st(0),", greg src2 1])
1578    | otherwise
1579    = pprG g (hcat [gtab, gpush src1 0,
1580                    text " ; fsub ", greg src2 1, text ",%st(0)",
1581                    gsemi, gpop dst 1])
1582
1583
1584 pprInstr g@(GDIV sz src1 src2 dst)
1585    | src1 == dst
1586    = pprG g (text "\t#GDIV-xxxcase1" $$
1587              hcat [gtab, gpush src2 0,
1588                    text " ; fdivrp %st(0),", greg src1 1])
1589    | src2 == dst
1590    = pprG g (text "\t#GDIV-xxxcase2" $$
1591              hcat [gtab, gpush src1 0,
1592                    text " ; fdivp %st(0),", greg src2 1])
1593    | otherwise
1594    = pprG g (hcat [gtab, gpush src1 0,
1595                    text " ; fdiv ", greg src2 1, text ",%st(0)",
1596                    gsemi, gpop dst 1])
1597
1598
1599 pprInstr GFREE
1600    = vcat [ ptext (sLit "\tffree %st(0) ;ffree %st(1) ;ffree %st(2) ;ffree %st(3)"),
1601             ptext (sLit "\tffree %st(4) ;ffree %st(5) ;ffree %st(6) ;ffree %st(7)")
1602           ]
1603
1604 pprTrigOp :: String -> Bool -> CLabel -> CLabel -> Reg -> Reg -> Size -> Doc
1605 pprTrigOp op -- fsin, fcos or fptan
1606           isTan -- we need a couple of extra steps if we're doing tan
1607           l1 l2 -- internal labels for us to use
1608           src dst sz
1609     = -- We'll be needing %eax later on
1610       hcat [gtab, text "pushl %eax;"] $$
1611       -- tan is going to use an extra space on the FP stack
1612       (if isTan then hcat [gtab, text "ffree %st(6)"] else empty) $$
1613       -- First put the value in %st(0) and try to apply the op to it
1614       hcat [gpush src 0, text ("; " ++ op)] $$
1615       -- Now look to see if C2 was set (overflow, |value| >= 2^63)
1616       hcat [gtab, text "fnstsw %ax"] $$
1617       hcat [gtab, text "test   $0x400,%eax"] $$
1618       -- If we were in bounds then jump to the end
1619       hcat [gtab, text "je     " <> pprCLabel_asm l1] $$
1620       -- Otherwise we need to shrink the value. Start by
1621       -- loading pi, doubleing it (by adding it to itself),
1622       -- and then swapping pi with the value, so the value we
1623       -- want to apply op to is in %st(0) again
1624       hcat [gtab, text "ffree %st(7); fldpi"] $$
1625       hcat [gtab, text "fadd   %st(0),%st"] $$
1626       hcat [gtab, text "fxch   %st(1)"] $$
1627       -- Now we have a loop in which we make the value smaller,
1628       -- see if it's small enough, and loop if not
1629       (pprCLabel_asm l2 <> char ':') $$
1630       hcat [gtab, text "fprem1"] $$
1631       -- My Debian libc uses fstsw here for the tan code, but I can't
1632       -- see any reason why it should need to be different for tan.
1633       hcat [gtab, text "fnstsw %ax"] $$
1634       hcat [gtab, text "test   $0x400,%eax"] $$
1635       hcat [gtab, text "jne    " <> pprCLabel_asm l2] $$
1636       hcat [gtab, text "fstp   %st(1)"] $$
1637       hcat [gtab, text op] $$
1638       (pprCLabel_asm l1 <> char ':') $$
1639       -- Pop the 1.0 tan gave us
1640       (if isTan then hcat [gtab, text "fstp %st(0)"] else empty) $$
1641       -- Restore %eax
1642       hcat [gtab, text "popl %eax;"] $$
1643       -- And finally make the result the right size
1644       hcat [gtab, gcoerceto sz, gpop dst 1]
1645
1646 --------------------------
1647
1648 -- coerce %st(0) to the specified size
1649 gcoerceto FF64 = empty
1650 gcoerceto FF32 = empty --text "subl $4,%esp ; fstps (%esp) ; flds (%esp) ; addl $4,%esp ; "
1651
1652 gpush reg offset
1653    = hcat [text "ffree %st(7) ; fld ", greg reg offset]
1654 gpop reg offset
1655    = hcat [text "fstp ", greg reg offset]
1656
1657 greg reg offset = text "%st(" <> int (gregno reg - 8+offset) <> char ')'
1658 gsemi = text " ; "
1659 gtab  = char '\t'
1660 gsp   = char ' '
1661
1662 gregno (RealReg i) = i
1663 gregno other       = --pprPanic "gregno" (ppr other)
1664                      999   -- bogus; only needed for debug printing
1665
1666 pprG :: Instr -> Doc -> Doc
1667 pprG fake actual
1668    = (char '#' <> pprGInstr fake) $$ actual
1669
1670 pprGInstr (GMOV src dst)   = pprSizeRegReg (sLit "gmov") FF64 src dst
1671 pprGInstr (GLD sz src dst) = pprSizeAddrReg (sLit "gld") sz src dst
1672 pprGInstr (GST sz src dst) = pprSizeRegAddr (sLit "gst") sz src dst
1673
1674 pprGInstr (GLDZ dst) = pprSizeReg (sLit "gldz") FF64 dst
1675 pprGInstr (GLD1 dst) = pprSizeReg (sLit "gld1") FF64 dst
1676
1677 pprGInstr (GFTOI src dst) = pprSizeSizeRegReg (sLit "gftoi") FF32 II32  src dst
1678 pprGInstr (GDTOI src dst) = pprSizeSizeRegReg (sLit "gdtoi") FF64 II32 src dst
1679
1680 pprGInstr (GITOF src dst) = pprSizeSizeRegReg (sLit "gitof") II32 FF32  src dst
1681 pprGInstr (GITOD src dst) = pprSizeSizeRegReg (sLit "gitod") II32 FF64 src dst
1682
1683 pprGInstr (GCMP co src dst) = pprCondRegReg (sLit "gcmp_") FF64 co src dst
1684 pprGInstr (GABS sz src dst) = pprSizeRegReg (sLit "gabs") sz src dst
1685 pprGInstr (GNEG sz src dst) = pprSizeRegReg (sLit "gneg") sz src dst
1686 pprGInstr (GSQRT sz src dst) = pprSizeRegReg (sLit "gsqrt") sz src dst
1687 pprGInstr (GSIN sz _ _ src dst) = pprSizeRegReg (sLit "gsin") sz src dst
1688 pprGInstr (GCOS sz _ _ src dst) = pprSizeRegReg (sLit "gcos") sz src dst
1689 pprGInstr (GTAN sz _ _ src dst) = pprSizeRegReg (sLit "gtan") sz src dst
1690
1691 pprGInstr (GADD sz src1 src2 dst) = pprSizeRegRegReg (sLit "gadd") sz src1 src2 dst
1692 pprGInstr (GSUB sz src1 src2 dst) = pprSizeRegRegReg (sLit "gsub") sz src1 src2 dst
1693 pprGInstr (GMUL sz src1 src2 dst) = pprSizeRegRegReg (sLit "gmul") sz src1 src2 dst
1694 pprGInstr (GDIV sz src1 src2 dst) = pprSizeRegRegReg (sLit "gdiv") sz src1 src2 dst
1695 #endif
1696
1697 #if i386_TARGET_ARCH || x86_64_TARGET_ARCH
1698
1699 -- Continue with I386-only printing bits and bobs:
1700
1701 pprDollImm :: Imm -> Doc
1702
1703 pprDollImm i =  ptext (sLit "$") <> pprImm i
1704
1705 pprOperand :: Size -> Operand -> Doc
1706 pprOperand s (OpReg r)   = pprReg s r
1707 pprOperand s (OpImm i)   = pprDollImm i
1708 pprOperand s (OpAddr ea) = pprAddr ea
1709
1710 pprMnemonic_  :: LitString -> Doc
1711 pprMnemonic_ name =
1712    char '\t' <> ptext name <> space
1713
1714 pprMnemonic  :: LitString -> Size -> Doc
1715 pprMnemonic name size =
1716    char '\t' <> ptext name <> pprSize size <> space
1717
1718 pprSizeImmOp :: LitString -> Size -> Imm -> Operand -> Doc
1719 pprSizeImmOp name size imm op1
1720   = hcat [
1721         pprMnemonic name size,
1722         char '$',
1723         pprImm imm,
1724         comma,
1725         pprOperand size op1
1726     ]
1727
1728 pprSizeOp :: LitString -> Size -> Operand -> Doc
1729 pprSizeOp name size op1
1730   = hcat [
1731         pprMnemonic name size,
1732         pprOperand size op1
1733     ]
1734
1735 pprSizeOpOp :: LitString -> Size -> Operand -> Operand -> Doc
1736 pprSizeOpOp name size op1 op2
1737   = hcat [
1738         pprMnemonic name size,
1739         pprOperand size op1,
1740         comma,
1741         pprOperand size op2
1742     ]
1743
1744 pprOpOp :: LitString -> Size -> Operand -> Operand -> Doc
1745 pprOpOp name size op1 op2
1746   = hcat [
1747         pprMnemonic_ name,
1748         pprOperand size op1,
1749         comma,
1750         pprOperand size op2
1751     ]
1752
1753 pprSizeReg :: LitString -> Size -> Reg -> Doc
1754 pprSizeReg name size reg1
1755   = hcat [
1756         pprMnemonic name size,
1757         pprReg size reg1
1758     ]
1759
1760 pprSizeRegReg :: LitString -> Size -> Reg -> Reg -> Doc
1761 pprSizeRegReg name size reg1 reg2
1762   = hcat [
1763         pprMnemonic name size,
1764         pprReg size reg1,
1765         comma,
1766         pprReg size reg2
1767     ]
1768
1769 pprRegReg :: LitString -> Reg -> Reg -> Doc
1770 pprRegReg name reg1 reg2
1771   = hcat [
1772         pprMnemonic_ name,
1773         pprReg wordSize reg1,
1774         comma,
1775         pprReg wordSize reg2
1776     ]
1777
1778 pprOpReg :: LitString -> Operand -> Reg -> Doc
1779 pprOpReg name op1 reg2
1780   = hcat [
1781         pprMnemonic_ name,
1782         pprOperand wordSize op1,
1783         comma,
1784         pprReg wordSize reg2
1785     ]
1786
1787 pprCondRegReg :: LitString -> Size -> Cond -> Reg -> Reg -> Doc
1788 pprCondRegReg name size cond reg1 reg2
1789   = hcat [
1790         char '\t',
1791         ptext name,
1792         pprCond cond,
1793         space,
1794         pprReg size reg1,
1795         comma,
1796         pprReg size reg2
1797     ]
1798
1799 pprSizeSizeRegReg :: LitString -> Size -> Size -> Reg -> Reg -> Doc
1800 pprSizeSizeRegReg name size1 size2 reg1 reg2
1801   = hcat [
1802         char '\t',
1803         ptext name,
1804         pprSize size1,
1805         pprSize size2,
1806         space,
1807         pprReg size1 reg1,
1808
1809         comma,
1810         pprReg size2 reg2
1811     ]
1812
1813 pprSizeRegRegReg :: LitString -> Size -> Reg -> Reg -> Reg -> Doc
1814 pprSizeRegRegReg name size reg1 reg2 reg3
1815   = hcat [
1816         pprMnemonic name size,
1817         pprReg size reg1,
1818         comma,
1819         pprReg size reg2,
1820         comma,
1821         pprReg size reg3
1822     ]
1823
1824 pprSizeAddrReg :: LitString -> Size -> AddrMode -> Reg -> Doc
1825 pprSizeAddrReg name size op dst
1826   = hcat [
1827         pprMnemonic name size,
1828         pprAddr op,
1829         comma,
1830         pprReg size dst
1831     ]
1832
1833 pprSizeRegAddr :: LitString -> Size -> Reg -> AddrMode -> Doc
1834 pprSizeRegAddr name size src op
1835   = hcat [
1836         pprMnemonic name size,
1837         pprReg size src,
1838         comma,
1839         pprAddr op
1840     ]
1841
1842 pprShift :: LitString -> Size -> Operand -> Operand -> Doc
1843 pprShift name size src dest
1844   = hcat [
1845         pprMnemonic name size,
1846         pprOperand II8 src,  -- src is 8-bit sized
1847         comma,
1848         pprOperand size dest
1849     ]
1850
1851 pprSizeOpOpCoerce :: LitString -> Size -> Size -> Operand -> Operand -> Doc
1852 pprSizeOpOpCoerce name size1 size2 op1 op2
1853   = hcat [ char '\t', ptext name, pprSize size1, pprSize size2, space,
1854         pprOperand size1 op1,
1855         comma,
1856         pprOperand size2 op2
1857     ]
1858
1859 pprCondInstr :: LitString -> Cond -> Doc -> Doc
1860 pprCondInstr name cond arg
1861   = hcat [ char '\t', ptext name, pprCond cond, space, arg]
1862
1863 #endif /* i386_TARGET_ARCH */
1864
1865
1866 -- ------------------------------------------------------------------------------- pprInstr for a SPARC
1867
1868 #if sparc_TARGET_ARCH
1869
1870 -- a clumsy hack for now, to handle possible double alignment problems
1871
1872 -- even clumsier, to allow for RegReg regs that show when doing indexed
1873 -- reads (bytearrays).
1874 --
1875
1876 pprInstr (SPILL reg slot)
1877    = hcat [
1878         ptext (sLit "\tSPILL"),
1879         char '\t',
1880         pprReg reg,
1881         comma,
1882         ptext (sLit "SLOT") <> parens (int slot)]
1883
1884 pprInstr (RELOAD slot reg)
1885    = hcat [
1886         ptext (sLit "\tRELOAD"),
1887         char '\t',
1888         ptext (sLit "SLOT") <> parens (int slot),
1889         comma,
1890         pprReg reg]
1891
1892 -- Translate to the following:
1893 --    add g1,g2,g1
1894 --    ld  [g1],%fn
1895 --    ld  [g1+4],%f(n+1)
1896 --    sub g1,g2,g1           -- to restore g1
1897
1898 pprInstr (LD FF64 (AddrRegReg g1 g2) reg)
1899  = let Just regH        = fPair reg
1900    in vcat [
1901        hcat [ptext (sLit "\tadd\t"), pprReg g1,comma,pprReg g2,comma,pprReg g1],
1902        hcat [pp_ld_lbracket, pprReg g1, pp_rbracket_comma, pprReg reg],
1903        hcat [pp_ld_lbracket, pprReg g1, ptext (sLit "+4]"), comma, pprReg regH],
1904        hcat [ptext (sLit "\tsub\t"), pprReg g1,comma,pprReg g2,comma,pprReg g1]
1905     ]
1906
1907 -- Translate to
1908 --    ld  [addr],%fn
1909 --    ld  [addr+4],%f(n+1)
1910 pprInstr (LD FF64 addr reg)
1911  = let  Just addr2      = addrOffset addr 4
1912         Just regH       = fPair reg
1913    in   vcat [
1914                hcat [pp_ld_lbracket, pprAddr addr, pp_rbracket_comma, pprReg reg],
1915                hcat [pp_ld_lbracket, pprAddr addr2, pp_rbracket_comma,pprReg regH]
1916             ]
1917
1918
1919 pprInstr (LD size addr reg)
1920   = hcat [
1921        ptext (sLit "\tld"),
1922        pprSize size,
1923        char '\t',
1924        lbrack,
1925        pprAddr addr,
1926        pp_rbracket_comma,
1927        pprReg reg
1928     ]
1929
1930 -- The same clumsy hack as above
1931
1932 -- Translate to the following:
1933 --    add g1,g2,g1
1934 --    st  %fn,[g1]
1935 --    st  %f(n+1),[g1+4]
1936 --    sub g1,g2,g1           -- to restore g1
1937 pprInstr (ST FF64 reg (AddrRegReg g1 g2))
1938  = let  Just regH       = fPair reg
1939    in vcat [
1940        hcat [ptext (sLit "\tadd\t"), pprReg g1,comma,pprReg g2,comma,pprReg g1],
1941        hcat [ptext (sLit "\tst\t"), pprReg reg, pp_comma_lbracket,
1942              pprReg g1, rbrack],
1943        hcat [ptext (sLit "\tst\t"), pprReg regH, pp_comma_lbracket,
1944              pprReg g1, ptext (sLit "+4]")],
1945        hcat [ptext (sLit "\tsub\t"), pprReg g1,comma,pprReg g2,comma,pprReg g1]
1946     ]
1947
1948 -- Translate to
1949 --    st  %fn,[addr]
1950 --    st  %f(n+1),[addr+4]
1951 pprInstr instr@(ST FF64 reg addr)
1952  = let  Just addr2      = addrOffset addr 4
1953         Just regH       = fPair reg
1954    in   vcat [
1955               hcat [ptext (sLit "\tst\t"), pprReg reg, pp_comma_lbracket,
1956                     pprAddr addr, rbrack],
1957               hcat [ptext (sLit "\tst\t"), pprReg regH, pp_comma_lbracket,
1958                     pprAddr addr2, rbrack]
1959             ]
1960
1961
1962
1963 -- no distinction is made between signed and unsigned bytes on stores for the
1964 -- Sparc opcodes (at least I cannot see any, and gas is nagging me --SOF),
1965 -- so we call a special-purpose pprSize for ST..
1966
1967 pprInstr (ST size reg addr)
1968   = hcat [
1969        ptext (sLit "\tst"),
1970        pprStSize size,
1971        char '\t',
1972        pprReg reg,
1973        pp_comma_lbracket,
1974        pprAddr addr,
1975        rbrack
1976     ]
1977
1978 pprInstr (ADD x cc reg1 ri reg2)
1979   | not x && not cc && riZero ri
1980   = hcat [ ptext (sLit "\tmov\t"), pprReg reg1, comma, pprReg reg2 ]
1981
1982   | otherwise
1983   = pprRegRIReg (if x then sLit "addx" else sLit "add") cc reg1 ri reg2
1984
1985 pprInstr (SUB x cc reg1 ri reg2)
1986   | not x && cc && reg2 == g0
1987   = hcat [ ptext (sLit "\tcmp\t"), pprReg reg1, comma, pprRI ri ]
1988   | not x && not cc && riZero ri
1989   = hcat [ ptext (sLit "\tmov\t"), pprReg reg1, comma, pprReg reg2 ]
1990   | otherwise
1991   = pprRegRIReg (if x then sLit "subx" else sLit "sub") cc reg1 ri reg2
1992
1993 pprInstr (AND  b reg1 ri reg2) = pprRegRIReg (sLit "and")  b reg1 ri reg2
1994 pprInstr (ANDN b reg1 ri reg2) = pprRegRIReg (sLit "andn") b reg1 ri reg2
1995
1996 pprInstr (OR b reg1 ri reg2)
1997   | not b && reg1 == g0
1998   = let doit = hcat [ ptext (sLit "\tmov\t"), pprRI ri, comma, pprReg reg2 ]
1999     in  case ri of
2000            RIReg rrr | rrr == reg2 -> empty
2001            other                   -> doit
2002
2003   | otherwise
2004   = pprRegRIReg (sLit "or") b reg1 ri reg2
2005
2006 pprInstr (ORN b reg1 ri reg2) = pprRegRIReg (sLit "orn") b reg1 ri reg2
2007
2008 pprInstr (XOR  b reg1 ri reg2) = pprRegRIReg (sLit "xor")  b reg1 ri reg2
2009 pprInstr (XNOR b reg1 ri reg2) = pprRegRIReg (sLit "xnor") b reg1 ri reg2
2010
2011 pprInstr (SLL reg1 ri reg2) = pprRegRIReg (sLit "sll") False reg1 ri reg2
2012 pprInstr (SRL reg1 ri reg2) = pprRegRIReg (sLit "srl") False reg1 ri reg2
2013 pprInstr (SRA reg1 ri reg2) = pprRegRIReg (sLit "sra") False reg1 ri reg2
2014
2015 pprInstr (RDY rd)               = ptext (sLit "\trd\t%y,") <> pprReg rd
2016 pprInstr (WRY reg1 reg2)
2017         = ptext (sLit "\twr\t")
2018                 <> pprReg reg1
2019                 <> char ','
2020                 <> pprReg reg2
2021                 <> char ','
2022                 <> ptext (sLit "%y")
2023
2024 pprInstr (SMUL b reg1 ri reg2)  = pprRegRIReg (sLit "smul")  b reg1 ri reg2
2025 pprInstr (UMUL b reg1 ri reg2)  = pprRegRIReg (sLit "umul")  b reg1 ri reg2
2026 pprInstr (SDIV b reg1 ri reg2)  = pprRegRIReg (sLit "sdiv")  b reg1 ri reg2
2027 pprInstr (UDIV b reg1 ri reg2)  = pprRegRIReg (sLit "udiv")  b reg1 ri reg2
2028
2029 pprInstr (SETHI imm reg)
2030   = hcat [
2031         ptext (sLit "\tsethi\t"),
2032         pprImm imm,
2033         comma,
2034         pprReg reg
2035     ]
2036
2037 pprInstr NOP = ptext (sLit "\tnop")
2038
2039 pprInstr (FABS FF32 reg1 reg2) = pprSizeRegReg (sLit "fabs") FF32 reg1 reg2
2040 pprInstr (FABS FF64 reg1 reg2)
2041  = let  Just reg1H      = fPair reg1
2042         Just reg2H      = fPair reg2
2043    in
2044     (<>) (pprSizeRegReg (sLit "fabs") FF32 reg1 reg2)
2045     (if (reg1 == reg2) then empty
2046      else (<>) (char '\n')
2047           (pprSizeRegReg (sLit "fmov") FF32 reg1H reg2H))
2048
2049 pprInstr (FADD size reg1 reg2 reg3)
2050   = pprSizeRegRegReg (sLit "fadd") size reg1 reg2 reg3
2051 pprInstr (FCMP e size reg1 reg2)
2052   = pprSizeRegReg (if e then sLit "fcmpe" else sLit "fcmp") size reg1 reg2
2053 pprInstr (FDIV size reg1 reg2 reg3)
2054   = pprSizeRegRegReg (sLit "fdiv") size reg1 reg2 reg3
2055
2056 pprInstr (FMOV FF32 reg1 reg2) = pprSizeRegReg (sLit "fmov") FF32 reg1 reg2
2057 pprInstr (FMOV FF64 reg1 reg2) = pprSizeRegReg (sLit "fmov") FF64 reg1 reg2
2058
2059 {-
2060 pprInstr (FMOV FF64 reg1 reg2)
2061  = let  Just reg1H      = fPair reg1
2062         Just reg2H      = fPair reg2
2063    in
2064     (<>) (pprSizeRegReg (sLit "fmov") FF32 reg1 reg2)
2065     (if (reg1 == reg2) then empty
2066      else (<>) (char '\n')
2067           (pprSizeRegReg (sLit "fmov") FF32 reg1H reg2H))
2068 -}
2069
2070 pprInstr (FMUL size reg1 reg2 reg3)
2071   = pprSizeRegRegReg (sLit "fmul") size reg1 reg2 reg3
2072
2073 pprInstr (FNEG FF32 reg1 reg2) = pprSizeRegReg (sLit "fneg") FF32 reg1 reg2
2074 pprInstr (FNEG FF64 reg1 reg2)
2075  = let  Just reg1H      = fPair reg1
2076         Just reg2H      = fPair reg2
2077    in
2078     (<>) (pprSizeRegReg (sLit "fneg") FF32 reg1 reg2)
2079     (if (reg1 == reg2) then empty
2080      else (<>) (char '\n')
2081           (pprSizeRegReg (sLit "fmov") FF32 reg1H reg2H))
2082
2083 pprInstr (FSQRT size reg1 reg2)     = pprSizeRegReg (sLit "fsqrt") size reg1 reg2
2084 pprInstr (FSUB size reg1 reg2 reg3) = pprSizeRegRegReg (sLit "fsub") size reg1 reg2 reg3
2085 pprInstr (FxTOy size1 size2 reg1 reg2)
2086   = hcat [
2087         ptext (sLit "\tf"),
2088         ptext
2089         (case size1 of
2090             II32  -> sLit "ito"
2091             FF32  -> sLit "sto"
2092             FF64  -> sLit "dto"),
2093         ptext
2094         (case size2 of
2095             II32  -> sLit "i\t"
2096             II64  -> sLit "x\t"
2097             FF32  -> sLit "s\t"
2098             FF64  -> sLit "d\t"),
2099         pprReg reg1, comma, pprReg reg2
2100     ]
2101
2102
2103 pprInstr (BI cond b (BlockId id))
2104   = hcat [
2105         ptext (sLit "\tb"), pprCond cond,
2106         if b then pp_comma_a else empty,
2107         char '\t',
2108         pprCLabel_asm (mkAsmTempLabel id)
2109     ]
2110
2111 pprInstr (BF cond b (BlockId id))
2112   = hcat [
2113         ptext (sLit "\tfb"), pprCond cond,
2114         if b then pp_comma_a else empty,
2115         char '\t',
2116         pprCLabel_asm (mkAsmTempLabel id)
2117     ]
2118
2119 pprInstr (JMP addr) = (<>) (ptext (sLit "\tjmp\t")) (pprAddr addr)
2120 pprInstr (JMP_TBL op ids)  = pprInstr (JMP op)
2121
2122 pprInstr (CALL (Left imm) n _)
2123   = hcat [ ptext (sLit "\tcall\t"), pprImm imm, comma, int n ]
2124 pprInstr (CALL (Right reg) n _)
2125   = hcat [ ptext (sLit "\tcall\t"), pprReg reg, comma, int n ]
2126
2127 pprRI :: RI -> Doc
2128 pprRI (RIReg r) = pprReg r
2129 pprRI (RIImm r) = pprImm r
2130
2131 pprSizeRegReg :: LitString -> Size -> Reg -> Reg -> Doc
2132 pprSizeRegReg name size reg1 reg2
2133   = hcat [
2134         char '\t',
2135         ptext name,
2136         (case size of
2137             FF32 -> ptext (sLit "s\t")
2138             FF64 -> ptext (sLit "d\t")),
2139         pprReg reg1,
2140         comma,
2141         pprReg reg2
2142     ]
2143
2144 pprSizeRegRegReg :: LitString -> Size -> Reg -> Reg -> Reg -> Doc
2145 pprSizeRegRegReg name size reg1 reg2 reg3
2146   = hcat [
2147         char '\t',
2148         ptext name,
2149         (case size of
2150             FF32  -> ptext (sLit "s\t")
2151             FF64  -> ptext (sLit "d\t")),
2152         pprReg reg1,
2153         comma,
2154         pprReg reg2,
2155         comma,
2156         pprReg reg3
2157     ]
2158
2159 pprRegRIReg :: LitString -> Bool -> Reg -> RI -> Reg -> Doc
2160 pprRegRIReg name b reg1 ri reg2
2161   = hcat [
2162         char '\t',
2163         ptext name,
2164         if b then ptext (sLit "cc\t") else char '\t',
2165         pprReg reg1,
2166         comma,
2167         pprRI ri,
2168         comma,
2169         pprReg reg2
2170     ]
2171
2172 pprRIReg :: LitString -> Bool -> RI -> Reg -> Doc
2173 pprRIReg name b ri reg1
2174   = hcat [
2175         char '\t',
2176         ptext name,
2177         if b then ptext (sLit "cc\t") else char '\t',
2178         pprRI ri,
2179         comma,
2180         pprReg reg1
2181     ]
2182
2183 pp_ld_lbracket    = ptext (sLit "\tld\t[")
2184 pp_rbracket_comma = text "],"
2185 pp_comma_lbracket = text ",["
2186 pp_comma_a        = text ",a"
2187
2188 #endif /* sparc_TARGET_ARCH */
2189
2190
2191 -- -----------------------------------------------------------------------------
2192 -- pprInstr for PowerPC
2193
2194 #if powerpc_TARGET_ARCH
2195
2196 pprInstr (SPILL reg slot)
2197    = hcat [
2198         ptext (sLit "\tSPILL"),
2199         char '\t',
2200         pprReg reg,
2201         comma,
2202         ptext (sLit "SLOT") <> parens (int slot)]
2203
2204 pprInstr (RELOAD slot reg)
2205    = hcat [
2206         ptext (sLit "\tRELOAD"),
2207         char '\t',
2208         ptext (sLit "SLOT") <> parens (int slot),
2209         comma,
2210         pprReg reg]
2211
2212 pprInstr (LD sz reg addr) = hcat [
2213         char '\t',
2214         ptext (sLit "l"),
2215         ptext (case sz of
2216             II8  -> sLit "bz"
2217             II16 -> sLit "hz"
2218             II32 -> sLit "wz"
2219             FF32 -> sLit "fs"
2220             FF64 -> sLit "fd"),
2221         case addr of AddrRegImm _ _ -> empty
2222                      AddrRegReg _ _ -> char 'x',
2223         char '\t',
2224         pprReg reg,
2225         ptext (sLit ", "),
2226         pprAddr addr
2227     ]
2228 pprInstr (LA sz reg addr) = hcat [
2229         char '\t',
2230         ptext (sLit "l"),
2231         ptext (case sz of
2232             II8  -> sLit "ba"
2233             II16 -> sLit "ha"
2234             II32 -> sLit "wa"
2235             FF32 -> sLit "fs"
2236             FF64 -> sLit "fd"),
2237         case addr of AddrRegImm _ _ -> empty
2238                      AddrRegReg _ _ -> char 'x',
2239         char '\t',
2240         pprReg reg,
2241         ptext (sLit ", "),
2242         pprAddr addr
2243     ]
2244 pprInstr (ST sz reg addr) = hcat [
2245         char '\t',
2246         ptext (sLit "st"),
2247         pprSize sz,
2248         case addr of AddrRegImm _ _ -> empty
2249                      AddrRegReg _ _ -> char 'x',
2250         char '\t',
2251         pprReg reg,
2252         ptext (sLit ", "),
2253         pprAddr addr
2254     ]
2255 pprInstr (STU sz reg addr) = hcat [
2256         char '\t',
2257         ptext (sLit "st"),
2258         pprSize sz,
2259         ptext (sLit "u\t"),
2260         case addr of AddrRegImm _ _ -> empty
2261                      AddrRegReg _ _ -> char 'x',
2262         pprReg reg,
2263         ptext (sLit ", "),
2264         pprAddr addr
2265     ]
2266 pprInstr (LIS reg imm) = hcat [
2267         char '\t',
2268         ptext (sLit "lis"),
2269         char '\t',
2270         pprReg reg,
2271         ptext (sLit ", "),
2272         pprImm imm
2273     ]
2274 pprInstr (LI reg imm) = hcat [
2275         char '\t',
2276         ptext (sLit "li"),
2277         char '\t',
2278         pprReg reg,
2279         ptext (sLit ", "),
2280         pprImm imm
2281     ]
2282 pprInstr (MR reg1 reg2)
2283     | reg1 == reg2 = empty
2284     | otherwise = hcat [
2285         char '\t',
2286         case regClass reg1 of
2287             RcInteger -> ptext (sLit "mr")
2288             _ -> ptext (sLit "fmr"),
2289         char '\t',
2290         pprReg reg1,
2291         ptext (sLit ", "),
2292         pprReg reg2
2293     ]
2294 pprInstr (CMP sz reg ri) = hcat [
2295         char '\t',
2296         op,
2297         char '\t',
2298         pprReg reg,
2299         ptext (sLit ", "),
2300         pprRI ri
2301     ]
2302     where
2303         op = hcat [
2304                 ptext (sLit "cmp"),
2305                 pprSize sz,
2306                 case ri of
2307                     RIReg _ -> empty
2308                     RIImm _ -> char 'i'
2309             ]
2310 pprInstr (CMPL sz reg ri) = hcat [
2311         char '\t',
2312         op,
2313         char '\t',
2314         pprReg reg,
2315         ptext (sLit ", "),
2316         pprRI ri
2317     ]
2318     where
2319         op = hcat [
2320                 ptext (sLit "cmpl"),
2321                 pprSize sz,
2322                 case ri of
2323                     RIReg _ -> empty
2324                     RIImm _ -> char 'i'
2325             ]
2326 pprInstr (BCC cond (BlockId id)) = hcat [
2327         char '\t',
2328         ptext (sLit "b"),
2329         pprCond cond,
2330         char '\t',
2331         pprCLabel_asm lbl
2332     ]
2333     where lbl = mkAsmTempLabel id
2334
2335 pprInstr (BCCFAR cond (BlockId id)) = vcat [
2336         hcat [
2337             ptext (sLit "\tb"),
2338             pprCond (condNegate cond),
2339             ptext (sLit "\t$+8")
2340         ],
2341         hcat [
2342             ptext (sLit "\tb\t"),
2343             pprCLabel_asm lbl
2344         ]
2345     ]
2346     where lbl = mkAsmTempLabel id
2347
2348 pprInstr (JMP lbl) = hcat [ -- an alias for b that takes a CLabel
2349         char '\t',
2350         ptext (sLit "b"),
2351         char '\t',
2352         pprCLabel_asm lbl
2353     ]
2354
2355 pprInstr (MTCTR reg) = hcat [
2356         char '\t',
2357         ptext (sLit "mtctr"),
2358         char '\t',
2359         pprReg reg
2360     ]
2361 pprInstr (BCTR _) = hcat [
2362         char '\t',
2363         ptext (sLit "bctr")
2364     ]
2365 pprInstr (BL lbl _) = hcat [
2366         ptext (sLit "\tbl\t"),
2367         pprCLabel_asm lbl
2368     ]
2369 pprInstr (BCTRL _) = hcat [
2370         char '\t',
2371         ptext (sLit "bctrl")
2372     ]
2373 pprInstr (ADD reg1 reg2 ri) = pprLogic (sLit "add") reg1 reg2 ri
2374 pprInstr (ADDIS reg1 reg2 imm) = hcat [
2375         char '\t',
2376         ptext (sLit "addis"),
2377         char '\t',
2378         pprReg reg1,
2379         ptext (sLit ", "),
2380         pprReg reg2,
2381         ptext (sLit ", "),
2382         pprImm imm
2383     ]
2384
2385 pprInstr (ADDC reg1 reg2 reg3) = pprLogic (sLit "addc") reg1 reg2 (RIReg reg3)
2386 pprInstr (ADDE reg1 reg2 reg3) = pprLogic (sLit "adde") reg1 reg2 (RIReg reg3)
2387 pprInstr (SUBF reg1 reg2 reg3) = pprLogic (sLit "subf") reg1 reg2 (RIReg reg3)
2388 pprInstr (MULLW reg1 reg2 ri@(RIReg _)) = pprLogic (sLit "mullw") reg1 reg2 ri
2389 pprInstr (MULLW reg1 reg2 ri@(RIImm _)) = pprLogic (sLit "mull") reg1 reg2 ri
2390 pprInstr (DIVW reg1 reg2 reg3) = pprLogic (sLit "divw") reg1 reg2 (RIReg reg3)
2391 pprInstr (DIVWU reg1 reg2 reg3) = pprLogic (sLit "divwu") reg1 reg2 (RIReg reg3)
2392
2393 pprInstr (MULLW_MayOflo reg1 reg2 reg3) = vcat [
2394          hcat [ ptext (sLit "\tmullwo\t"), pprReg reg1, ptext (sLit ", "),
2395                                           pprReg reg2, ptext (sLit ", "),
2396                                           pprReg reg3 ],
2397          hcat [ ptext (sLit "\tmfxer\t"),  pprReg reg1 ],
2398          hcat [ ptext (sLit "\trlwinm\t"), pprReg reg1, ptext (sLit ", "),
2399                                           pprReg reg1, ptext (sLit ", "),
2400                                           ptext (sLit "2, 31, 31") ]
2401     ]
2402
2403         -- for some reason, "andi" doesn't exist.
2404         -- we'll use "andi." instead.
2405 pprInstr (AND reg1 reg2 (RIImm imm)) = hcat [
2406         char '\t',
2407         ptext (sLit "andi."),
2408         char '\t',
2409         pprReg reg1,
2410         ptext (sLit ", "),
2411         pprReg reg2,
2412         ptext (sLit ", "),
2413         pprImm imm
2414     ]
2415 pprInstr (AND reg1 reg2 ri) = pprLogic (sLit "and") reg1 reg2 ri
2416
2417 pprInstr (OR reg1 reg2 ri) = pprLogic (sLit "or") reg1 reg2 ri
2418 pprInstr (XOR reg1 reg2 ri) = pprLogic (sLit "xor") reg1 reg2 ri
2419
2420 pprInstr (XORIS reg1 reg2 imm) = hcat [
2421         char '\t',
2422         ptext (sLit "xoris"),
2423         char '\t',
2424         pprReg reg1,
2425         ptext (sLit ", "),
2426         pprReg reg2,
2427         ptext (sLit ", "),
2428         pprImm imm
2429     ]
2430
2431 pprInstr (EXTS sz reg1 reg2) = hcat [
2432         char '\t',
2433         ptext (sLit "exts"),
2434         pprSize sz,
2435         char '\t',
2436         pprReg reg1,
2437         ptext (sLit ", "),
2438         pprReg reg2
2439     ]
2440
2441 pprInstr (NEG reg1 reg2) = pprUnary (sLit "neg") reg1 reg2
2442 pprInstr (NOT reg1 reg2) = pprUnary (sLit "not") reg1 reg2
2443
2444 pprInstr (SLW reg1 reg2 ri) = pprLogic (sLit "slw") reg1 reg2 (limitShiftRI ri)
2445 pprInstr (SRW reg1 reg2 ri) = pprLogic (sLit "srw") reg1 reg2 (limitShiftRI ri)
2446 pprInstr (SRAW reg1 reg2 ri) = pprLogic (sLit "sraw") reg1 reg2 (limitShiftRI ri)
2447 pprInstr (RLWINM reg1 reg2 sh mb me) = hcat [
2448         ptext (sLit "\trlwinm\t"),
2449         pprReg reg1,
2450         ptext (sLit ", "),
2451         pprReg reg2,
2452         ptext (sLit ", "),
2453         int sh,
2454         ptext (sLit ", "),
2455         int mb,
2456         ptext (sLit ", "),
2457         int me
2458     ]
2459
2460 pprInstr (FADD sz reg1 reg2 reg3) = pprBinaryF (sLit "fadd") sz reg1 reg2 reg3
2461 pprInstr (FSUB sz reg1 reg2 reg3) = pprBinaryF (sLit "fsub") sz reg1 reg2 reg3
2462 pprInstr (FMUL sz reg1 reg2 reg3) = pprBinaryF (sLit "fmul") sz reg1 reg2 reg3
2463 pprInstr (FDIV sz reg1 reg2 reg3) = pprBinaryF (sLit "fdiv") sz reg1 reg2 reg3
2464 pprInstr (FNEG reg1 reg2) = pprUnary (sLit "fneg") reg1 reg2
2465
2466 pprInstr (FCMP reg1 reg2) = hcat [
2467         char '\t',
2468         ptext (sLit "fcmpu\tcr0, "),
2469             -- Note: we're using fcmpu, not fcmpo
2470             -- The difference is with fcmpo, compare with NaN is an invalid operation.
2471             -- We don't handle invalid fp ops, so we don't care
2472         pprReg reg1,
2473         ptext (sLit ", "),
2474         pprReg reg2
2475     ]
2476
2477 pprInstr (FCTIWZ reg1 reg2) = pprUnary (sLit "fctiwz") reg1 reg2
2478 pprInstr (FRSP reg1 reg2) = pprUnary (sLit "frsp") reg1 reg2
2479
2480 pprInstr (CRNOR dst src1 src2) = hcat [
2481         ptext (sLit "\tcrnor\t"),
2482         int dst,
2483         ptext (sLit ", "),
2484         int src1,
2485         ptext (sLit ", "),
2486         int src2
2487     ]
2488
2489 pprInstr (MFCR reg) = hcat [
2490         char '\t',
2491         ptext (sLit "mfcr"),
2492         char '\t',
2493         pprReg reg
2494     ]
2495
2496 pprInstr (MFLR reg) = hcat [
2497         char '\t',
2498         ptext (sLit "mflr"),
2499         char '\t',
2500         pprReg reg
2501     ]
2502
2503 pprInstr (FETCHPC reg) = vcat [
2504         ptext (sLit "\tbcl\t20,31,1f"),
2505         hcat [ ptext (sLit "1:\tmflr\t"), pprReg reg ]
2506     ]
2507
2508 pprInstr LWSYNC = ptext (sLit "\tlwsync")
2509
2510 pprInstr _ = panic "pprInstr (ppc)"
2511
2512 pprLogic op reg1 reg2 ri = hcat [
2513         char '\t',
2514         ptext op,
2515         case ri of
2516             RIReg _ -> empty
2517             RIImm _ -> char 'i',
2518         char '\t',
2519         pprReg reg1,
2520         ptext (sLit ", "),
2521         pprReg reg2,
2522         ptext (sLit ", "),
2523         pprRI ri
2524     ]
2525
2526 pprUnary op reg1 reg2 = hcat [
2527         char '\t',
2528         ptext op,
2529         char '\t',
2530         pprReg reg1,
2531         ptext (sLit ", "),
2532         pprReg reg2
2533     ]
2534
2535 pprBinaryF op sz reg1 reg2 reg3 = hcat [
2536         char '\t',
2537         ptext op,
2538         pprFSize sz,
2539         char '\t',
2540         pprReg reg1,
2541         ptext (sLit ", "),
2542         pprReg reg2,
2543         ptext (sLit ", "),
2544         pprReg reg3
2545     ]
2546
2547 pprRI :: RI -> Doc
2548 pprRI (RIReg r) = pprReg r
2549 pprRI (RIImm r) = pprImm r
2550
2551 pprFSize FF64 = empty
2552 pprFSize FF32 = char 's'
2553
2554     -- limit immediate argument for shift instruction to range 0..32
2555     -- (yes, the maximum is really 32, not 31)
2556 limitShiftRI :: RI -> RI
2557 limitShiftRI (RIImm (ImmInt i)) | i > 32 || i < 0 = RIImm (ImmInt 32)
2558 limitShiftRI x = x
2559
2560 #endif /* powerpc_TARGET_ARCH */
2561
2562
2563 -- -----------------------------------------------------------------------------
2564 -- Converting floating-point literals to integrals for printing
2565
2566 castFloatToWord8Array :: STUArray s Int Float -> ST s (STUArray s Int Word8)
2567 castFloatToWord8Array = castSTUArray
2568
2569 castDoubleToWord8Array :: STUArray s Int Double -> ST s (STUArray s Int Word8)
2570 castDoubleToWord8Array = castSTUArray
2571
2572 -- floatToBytes and doubleToBytes convert to the host's byte
2573 -- order.  Providing that we're not cross-compiling for a
2574 -- target with the opposite endianness, this should work ok
2575 -- on all targets.
2576
2577 -- ToDo: this stuff is very similar to the shenanigans in PprAbs,
2578 -- could they be merged?
2579
2580 floatToBytes :: Float -> [Int]
2581 floatToBytes f
2582    = runST (do
2583         arr <- newArray_ ((0::Int),3)
2584         writeArray arr 0 f
2585         arr <- castFloatToWord8Array arr
2586         i0 <- readArray arr 0
2587         i1 <- readArray arr 1
2588         i2 <- readArray arr 2
2589         i3 <- readArray arr 3
2590         return (map fromIntegral [i0,i1,i2,i3])
2591      )
2592
2593 doubleToBytes :: Double -> [Int]
2594 doubleToBytes d
2595    = runST (do
2596         arr <- newArray_ ((0::Int),7)
2597         writeArray arr 0 d
2598         arr <- castDoubleToWord8Array arr
2599         i0 <- readArray arr 0
2600         i1 <- readArray arr 1
2601         i2 <- readArray arr 2
2602         i3 <- readArray arr 3
2603         i4 <- readArray arr 4
2604         i5 <- readArray arr 5
2605         i6 <- readArray arr 6
2606         i7 <- readArray arr 7
2607         return (map fromIntegral [i0,i1,i2,i3,i4,i5,i6,i7])
2608      )