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