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