ghc/compiler/nativeGen/PprMach.lhs

   1 %
   2 % (c) The AQUA Project, Glasgow University, 1996-1998
   3 %
   4 \section[PprMach]{Pretty-printing assembly language}
   5
   6 We start with the @pprXXX@s with some cross-platform commonality
   7 (e.g., @pprReg@); we conclude with the no-commonality monster,
   8 @pprInstr@.
   9
  10 \begin{code}
  11 #include "nativeGen/NCG.h"
  12
  13 module PprMach ( pprInstr, pprSize, pprUserReg IF_OS_darwin(COMMA pprDyldSymbolStub, ) ) where
  14
  15 #include "HsVersions.h"
  16
  17 import MachRegs         -- may differ per-platform
  18 import MachMisc
  19
  20 import CLabel           ( pprCLabel, externallyVisibleCLabel, labelDynamic )
  21 import Stix             ( CodeSegment(..) )
  22 import Panic            ( panic )
  23 import Pretty
  24 import FastString
  25 import qualified Outputable
  26
  27 #if __GLASGOW_HASKELL__ >= 504
  28 import Data.Array.ST
  29 import Data.Word        ( Word8, Word16 )
  30 #else
  31 import MutableArray
  32 import Word             ( Word16 )
  33 #endif
  34
  35 import MONAD_ST
  36
  37 import Char             ( chr, ord )
  38 import Maybe            ( isJust )
  39
  40 asmSDoc d = Outputable.withPprStyleDoc (
  41               Outputable.mkCodeStyle Outputable.AsmStyle) d
  42 pprCLabel_asm l = asmSDoc (pprCLabel l)
  43 \end{code}
  44
  45 %************************************************************************
  46 %*                                                                      *
  47 \subsection{@pprReg@: print a @Reg@}
  48 %*                                                                      *
  49 %************************************************************************
  50
  51 For x86, the way we print a register name depends
  52 on which bit of it we care about.  Yurgh.
  53 \begin{code}
  54 pprUserReg :: Reg -> Doc
  55 pprUserReg = pprReg IF_ARCH_i386(L,)
  56
  57 pprReg :: IF_ARCH_i386(Size ->,) Reg -> Doc
  58
  59 pprReg IF_ARCH_i386(s,) r
  60   = case r of
  61       RealReg i      -> ppr_reg_no IF_ARCH_i386(s,) i
  62       VirtualRegI u  -> text "%vI_" <> asmSDoc (pprVRegUnique u)
  63       VirtualRegF u  -> text "%vF_" <> asmSDoc (pprVRegUnique u)
  64   where
  65 #if alpha_TARGET_ARCH
  66     ppr_reg_no :: Int -> Doc
  67     ppr_reg_no i = ptext
  68       (case i of {
  69          0 -> SLIT("$0");    1 -> SLIT("$1");
  70          2 -> SLIT("$2");    3 -> SLIT("$3");
  71          4 -> SLIT("$4");    5 -> SLIT("$5");
  72          6 -> SLIT("$6");    7 -> SLIT("$7");
  73          8 -> SLIT("$8");    9 -> SLIT("$9");
  74         10 -> SLIT("$10");  11 -> SLIT("$11");
  75         12 -> SLIT("$12");  13 -> SLIT("$13");
  76         14 -> SLIT("$14");  15 -> SLIT("$15");
  77         16 -> SLIT("$16");  17 -> SLIT("$17");
  78         18 -> SLIT("$18");  19 -> SLIT("$19");
  79         20 -> SLIT("$20");  21 -> SLIT("$21");
  80         22 -> SLIT("$22");  23 -> SLIT("$23");
  81         24 -> SLIT("$24");  25 -> SLIT("$25");
  82         26 -> SLIT("$26");  27 -> SLIT("$27");
  83         28 -> SLIT("$28");  29 -> SLIT("$29");
  84         30 -> SLIT("$30");  31 -> SLIT("$31");
  85         32 -> SLIT("$f0");  33 -> SLIT("$f1");
  86         34 -> SLIT("$f2");  35 -> SLIT("$f3");
  87         36 -> SLIT("$f4");  37 -> SLIT("$f5");
  88         38 -> SLIT("$f6");  39 -> SLIT("$f7");
  89         40 -> SLIT("$f8");  41 -> SLIT("$f9");
  90         42 -> SLIT("$f10"); 43 -> SLIT("$f11");
  91         44 -> SLIT("$f12"); 45 -> SLIT("$f13");
  92         46 -> SLIT("$f14"); 47 -> SLIT("$f15");
  93         48 -> SLIT("$f16"); 49 -> SLIT("$f17");
  94         50 -> SLIT("$f18"); 51 -> SLIT("$f19");
  95         52 -> SLIT("$f20"); 53 -> SLIT("$f21");
  96         54 -> SLIT("$f22"); 55 -> SLIT("$f23");
  97         56 -> SLIT("$f24"); 57 -> SLIT("$f25");
  98         58 -> SLIT("$f26"); 59 -> SLIT("$f27");
  99         60 -> SLIT("$f28"); 61 -> SLIT("$f29");
 100         62 -> SLIT("$f30"); 63 -> SLIT("$f31");
 101         _  -> SLIT("very naughty alpha register")
 102       })
 103 #endif
 104 #if i386_TARGET_ARCH
 105     ppr_reg_no :: Size -> Int -> Doc
 106     ppr_reg_no B  = ppr_reg_byte
 107     ppr_reg_no Bu = ppr_reg_byte
 108     ppr_reg_no W  = ppr_reg_word
 109     ppr_reg_no Wu = ppr_reg_word
 110     ppr_reg_no _  = ppr_reg_long
 111
 112     ppr_reg_byte i = ptext
 113       (case i of {
 114          0 -> SLIT("%al");     1 -> SLIT("%bl");
 115          2 -> SLIT("%cl");     3 -> SLIT("%dl");
 116         _  -> SLIT("very naughty I386 byte register")
 117       })
 118
 119     ppr_reg_word i = ptext
 120       (case i of {
 121          0 -> SLIT("%ax");     1 -> SLIT("%bx");
 122          2 -> SLIT("%cx");     3 -> SLIT("%dx");
 123          4 -> SLIT("%si");     5 -> SLIT("%di");
 124          6 -> SLIT("%bp");     7 -> SLIT("%sp");
 125         _  -> SLIT("very naughty I386 word register")
 126       })
 127
 128     ppr_reg_long i = ptext
 129       (case i of {
 130          0 -> SLIT("%eax");    1 -> SLIT("%ebx");
 131          2 -> SLIT("%ecx");    3 -> SLIT("%edx");
 132          4 -> SLIT("%esi");    5 -> SLIT("%edi");
 133          6 -> SLIT("%ebp");    7 -> SLIT("%esp");
 134          8 -> SLIT("%fake0");  9 -> SLIT("%fake1");
 135         10 -> SLIT("%fake2"); 11 -> SLIT("%fake3");
 136         12 -> SLIT("%fake4"); 13 -> SLIT("%fake5");
 137         _  -> SLIT("very naughty I386 register")
 138       })
 139 #endif
 140 #if sparc_TARGET_ARCH
 141     ppr_reg_no :: Int -> Doc
 142     ppr_reg_no i = ptext
 143       (case i of {
 144          0 -> SLIT("%g0");   1 -> SLIT("%g1");
 145          2 -> SLIT("%g2");   3 -> SLIT("%g3");
 146          4 -> SLIT("%g4");   5 -> SLIT("%g5");
 147          6 -> SLIT("%g6");   7 -> SLIT("%g7");
 148          8 -> SLIT("%o0");   9 -> SLIT("%o1");
 149         10 -> SLIT("%o2");  11 -> SLIT("%o3");
 150         12 -> SLIT("%o4");  13 -> SLIT("%o5");
 151         14 -> SLIT("%o6");  15 -> SLIT("%o7");
 152         16 -> SLIT("%l0");  17 -> SLIT("%l1");
 153         18 -> SLIT("%l2");  19 -> SLIT("%l3");
 154         20 -> SLIT("%l4");  21 -> SLIT("%l5");
 155         22 -> SLIT("%l6");  23 -> SLIT("%l7");
 156         24 -> SLIT("%i0");  25 -> SLIT("%i1");
 157         26 -> SLIT("%i2");  27 -> SLIT("%i3");
 158         28 -> SLIT("%i4");  29 -> SLIT("%i5");
 159         30 -> SLIT("%i6");  31 -> SLIT("%i7");
 160         32 -> SLIT("%f0");  33 -> SLIT("%f1");
 161         34 -> SLIT("%f2");  35 -> SLIT("%f3");
 162         36 -> SLIT("%f4");  37 -> SLIT("%f5");
 163         38 -> SLIT("%f6");  39 -> SLIT("%f7");
 164         40 -> SLIT("%f8");  41 -> SLIT("%f9");
 165         42 -> SLIT("%f10"); 43 -> SLIT("%f11");
 166         44 -> SLIT("%f12"); 45 -> SLIT("%f13");
 167         46 -> SLIT("%f14"); 47 -> SLIT("%f15");
 168         48 -> SLIT("%f16"); 49 -> SLIT("%f17");
 169         50 -> SLIT("%f18"); 51 -> SLIT("%f19");
 170         52 -> SLIT("%f20"); 53 -> SLIT("%f21");
 171         54 -> SLIT("%f22"); 55 -> SLIT("%f23");
 172         56 -> SLIT("%f24"); 57 -> SLIT("%f25");
 173         58 -> SLIT("%f26"); 59 -> SLIT("%f27");
 174         60 -> SLIT("%f28"); 61 -> SLIT("%f29");
 175         62 -> SLIT("%f30"); 63 -> SLIT("%f31");
 176         _  -> SLIT("very naughty sparc register")
 177       })
 178 #endif
 179 #if powerpc_TARGET_ARCH
 180 #if darwin_TARGET_OS
 181     ppr_reg_no :: Int -> Doc
 182     ppr_reg_no i = ptext
 183       (case i of {
 184          0 -> SLIT("r0");   1 -> SLIT("r1");
 185          2 -> SLIT("r2");   3 -> SLIT("r3");
 186          4 -> SLIT("r4");   5 -> SLIT("r5");
 187          6 -> SLIT("r6");   7 -> SLIT("r7");
 188          8 -> SLIT("r8");   9 -> SLIT("r9");
 189         10 -> SLIT("r10");  11 -> SLIT("r11");
 190         12 -> SLIT("r12");  13 -> SLIT("r13");
 191         14 -> SLIT("r14");  15 -> SLIT("r15");
 192         16 -> SLIT("r16");  17 -> SLIT("r17");
 193         18 -> SLIT("r18");  19 -> SLIT("r19");
 194         20 -> SLIT("r20");  21 -> SLIT("r21");
 195         22 -> SLIT("r22");  23 -> SLIT("r23");
 196         24 -> SLIT("r24");  25 -> SLIT("r25");
 197         26 -> SLIT("r26");  27 -> SLIT("r27");
 198         28 -> SLIT("r28");  29 -> SLIT("r29");
 199         30 -> SLIT("r30");  31 -> SLIT("r31");
 200         32 -> SLIT("f0");  33 -> SLIT("f1");
 201         34 -> SLIT("f2");  35 -> SLIT("f3");
 202         36 -> SLIT("f4");  37 -> SLIT("f5");
 203         38 -> SLIT("f6");  39 -> SLIT("f7");
 204         40 -> SLIT("f8");  41 -> SLIT("f9");
 205         42 -> SLIT("f10"); 43 -> SLIT("f11");
 206         44 -> SLIT("f12"); 45 -> SLIT("f13");
 207         46 -> SLIT("f14"); 47 -> SLIT("f15");
 208         48 -> SLIT("f16"); 49 -> SLIT("f17");
 209         50 -> SLIT("f18"); 51 -> SLIT("f19");
 210         52 -> SLIT("f20"); 53 -> SLIT("f21");
 211         54 -> SLIT("f22"); 55 -> SLIT("f23");
 212         56 -> SLIT("f24"); 57 -> SLIT("f25");
 213         58 -> SLIT("f26"); 59 -> SLIT("f27");
 214         60 -> SLIT("f28"); 61 -> SLIT("f29");
 215         62 -> SLIT("f30"); 63 -> SLIT("f31");
 216         _  -> SLIT("very naughty powerpc register")
 217       })
 218 #else
 219     ppr_reg_no :: Int -> Doc
 220     ppr_reg_no i | i <= 31 = int i      -- GPRs
 221                  | i <= 63 = int (i-32) -- FPRs
 222                  | otherwise = ptext SLIT("very naughty powerpc register")
 223 #endif
 224 #endif
 225 \end{code}
 226
 227 %************************************************************************
 228 %*                                                                      *
 229 \subsection{@pprSize@: print a @Size@}
 230 %*                                                                      *
 231 %************************************************************************
 232
 233 \begin{code}
 234 pprSize :: Size -> Doc
 235
 236 pprSize x = ptext (case x of
 237 #if alpha_TARGET_ARCH
 238          B  -> SLIT("b")
 239          Bu -> SLIT("bu")
 240 --       W  -> SLIT("w") UNUSED
 241 --       Wu -> SLIT("wu") UNUSED
 242          L  -> SLIT("l")
 243          Q  -> SLIT("q")
 244 --       FF -> SLIT("f") UNUSED
 245 --       DF -> SLIT("d") UNUSED
 246 --       GF -> SLIT("g") UNUSED
 247 --       SF -> SLIT("s") UNUSED
 248          TF -> SLIT("t")
 249 #endif
 250 #if i386_TARGET_ARCH
 251         B   -> SLIT("b")
 252         Bu  -> SLIT("b")
 253         W   -> SLIT("w")
 254         Wu  -> SLIT("w")
 255         L   -> SLIT("l")
 256         Lu  -> SLIT("l")
 257         F   -> SLIT("s")
 258         DF  -> SLIT("l")
 259         F80 -> SLIT("t")
 260 #endif
 261 #if sparc_TARGET_ARCH
 262         B   -> SLIT("sb")
 263         Bu  -> SLIT("ub")
 264         H   -> SLIT("sh")
 265         Hu  -> SLIT("uh")
 266         W   -> SLIT("")
 267         F   -> SLIT("")
 268         DF  -> SLIT("d")
 269     )
 270 pprStSize :: Size -> Doc
 271 pprStSize x = ptext (case x of
 272         B   -> SLIT("b")
 273         Bu  -> SLIT("b")
 274         H   -> SLIT("h")
 275         Hu  -> SLIT("h")
 276         W   -> SLIT("")
 277         F   -> SLIT("")
 278         DF  -> SLIT("d")
 279 #endif
 280 #if powerpc_TARGET_ARCH
 281         B   -> SLIT("b")
 282         Bu  -> SLIT("b")
 283         H   -> SLIT("h")
 284         Hu  -> SLIT("h")
 285         W   -> SLIT("w")
 286         F   -> SLIT("fs")
 287         DF  -> SLIT("fd")
 288 #endif
 289     )
 290 \end{code}
 291
 292 %************************************************************************
 293 %*                                                                      *
 294 \subsection{@pprCond@: print a @Cond@}
 295 %*                                                                      *
 296 %************************************************************************
 297
 298 \begin{code}
 299 pprCond :: Cond -> Doc
 300
 301 pprCond c = ptext (case c of {
 302 #if alpha_TARGET_ARCH
 303         EQQ  -> SLIT("eq");
 304         LTT  -> SLIT("lt");
 305         LE  -> SLIT("le");
 306         ULT -> SLIT("ult");
 307         ULE -> SLIT("ule");
 308         NE  -> SLIT("ne");
 309         GTT  -> SLIT("gt");
 310         GE  -> SLIT("ge")
 311 #endif
 312 #if i386_TARGET_ARCH
 313         GEU     -> SLIT("ae");  LU    -> SLIT("b");
 314         EQQ     -> SLIT("e");   GTT    -> SLIT("g");
 315         GE      -> SLIT("ge");  GU    -> SLIT("a");
 316         LTT     -> SLIT("l");   LE    -> SLIT("le");
 317         LEU     -> SLIT("be");  NE    -> SLIT("ne");
 318         NEG     -> SLIT("s");   POS   -> SLIT("ns");
 319         CARRY   -> SLIT("c");   OFLO  -> SLIT("o");
 320         ALWAYS  -> SLIT("mp")   -- hack
 321 #endif
 322 #if sparc_TARGET_ARCH
 323         ALWAYS  -> SLIT("");    NEVER -> SLIT("n");
 324         GEU     -> SLIT("geu"); LU    -> SLIT("lu");
 325         EQQ     -> SLIT("e");   GTT   -> SLIT("g");
 326         GE      -> SLIT("ge");  GU    -> SLIT("gu");
 327         LTT     -> SLIT("l");   LE    -> SLIT("le");
 328         LEU     -> SLIT("leu"); NE    -> SLIT("ne");
 329         NEG     -> SLIT("neg"); POS   -> SLIT("pos");
 330         VC      -> SLIT("vc");  VS    -> SLIT("vs")
 331 #endif
 332 #if powerpc_TARGET_ARCH
 333         ALWAYS  -> SLIT("");
 334         EQQ     -> SLIT("eq");  NE    -> SLIT("ne");
 335         LTT     -> SLIT("lt");  GE    -> SLIT("ge");
 336         GTT     -> SLIT("gt");  LE    -> SLIT("le");
 337         LU      -> SLIT("lt");  GEU   -> SLIT("ge");
 338         GU      -> SLIT("gt");  LEU   -> SLIT("le");
 339 #endif
 340     })
 341 \end{code}
 342
 343 %************************************************************************
 344 %*                                                                      *
 345 \subsection{@pprImm@: print an @Imm@}
 346 %*                                                                      *
 347 %************************************************************************
 348
 349 \begin{code}
 350 pprImm :: Imm -> Doc
 351
 352 pprImm (ImmInt i)     = int i
 353 pprImm (ImmInteger i) = integer i
 354 pprImm (ImmCLbl l)    = (if labelDynamic l then text "__imp_" else empty)
 355                         <> pprCLabel_asm l
 356 pprImm (ImmIndex l i) = (if labelDynamic l then text "__imp_" else empty)
 357                         <> pprCLabel_asm l <> char '+' <> int i
 358 pprImm (ImmLit s)     = s
 359
 360 pprImm (ImmLab dll s) = (if underscorePrefix then char '_' else empty)
 361                         <> (if dll then text "_imp__" else empty)
 362                         <> s
 363
 364 #if sparc_TARGET_ARCH
 365 pprImm (LO i)
 366   = hcat [ pp_lo, pprImm i, rparen ]
 367   where
 368     pp_lo = text "%lo("
 369
 370 pprImm (HI i)
 371   = hcat [ pp_hi, pprImm i, rparen ]
 372   where
 373     pp_hi = text "%hi("
 374 #endif
 375 #if powerpc_TARGET_ARCH
 376 #if darwin_TARGET_OS
 377 pprImm (LO i)
 378   = hcat [ pp_lo, pprImm i, rparen ]
 379   where
 380     pp_lo = text "lo16("
 381
 382 pprImm (HI i)
 383   = hcat [ pp_hi, pprImm i, rparen ]
 384   where
 385     pp_hi = text "hi16("
 386
 387 pprImm (HA i)
 388   = hcat [ pp_ha, pprImm i, rparen ]
 389   where
 390     pp_ha = text "ha16("
 391 #else
 392 pprImm (LO i)
 393   = pprImm i <> text "@l"
 394
 395 pprImm (HI i)
 396   = pprImm i <> text "@h"
 397
 398 pprImm (HA i)
 399   = pprImm i <> text "@ha"
 400 #endif
 401 #endif
 402 \end{code}
 403
 404 %************************************************************************
 405 %*                                                                      *
 406 \subsection{@pprAddr@: print an @Addr@}
 407 %*                                                                      *
 408 %************************************************************************
 409
 410 \begin{code}
 411 pprAddr :: MachRegsAddr -> Doc
 412
 413 #if alpha_TARGET_ARCH
 414 pprAddr (AddrReg r) = parens (pprReg r)
 415 pprAddr (AddrImm i) = pprImm i
 416 pprAddr (AddrRegImm r1 i)
 417   = (<>) (pprImm i) (parens (pprReg r1))
 418 #endif
 419
 420 -------------------
 421
 422 #if i386_TARGET_ARCH
 423 pprAddr (ImmAddr imm off)
 424   = let pp_imm = pprImm imm
 425     in
 426     if (off == 0) then
 427         pp_imm
 428     else if (off < 0) then
 429         pp_imm <> int off
 430     else
 431         pp_imm <> char '+' <> int off
 432
 433 pprAddr (AddrBaseIndex base index displacement)
 434   = let
 435         pp_disp  = ppr_disp displacement
 436         pp_off p = pp_disp <> char '(' <> p <> char ')'
 437         pp_reg r = pprReg L r
 438     in
 439     case (base,index) of
 440       (Nothing, Nothing)    -> pp_disp
 441       (Just b,  Nothing)    -> pp_off (pp_reg b)
 442       (Nothing, Just (r,i)) -> pp_off (pp_reg r <> comma <> int i)
 443       (Just b,  Just (r,i)) -> pp_off (pp_reg b <> comma <> pp_reg r
 444                                        <> comma <> int i)
 445   where
 446     ppr_disp (ImmInt 0) = empty
 447     ppr_disp imm        = pprImm imm
 448 #endif
 449
 450 -------------------
 451
 452 #if sparc_TARGET_ARCH
 453 pprAddr (AddrRegReg r1 (RealReg 0)) = pprReg r1
 454
 455 pprAddr (AddrRegReg r1 r2)
 456   = hcat [ pprReg r1, char '+', pprReg r2 ]
 457
 458 pprAddr (AddrRegImm r1 (ImmInt i))
 459   | i == 0 = pprReg r1
 460   | not (fits13Bits i) = largeOffsetError i
 461   | otherwise = hcat [ pprReg r1, pp_sign, int i ]
 462   where
 463     pp_sign = if i > 0 then char '+' else empty
 464
 465 pprAddr (AddrRegImm r1 (ImmInteger i))
 466   | i == 0 = pprReg r1
 467   | not (fits13Bits i) = largeOffsetError i
 468 -------------------
 469
 470   | otherwise  = hcat [ pprReg r1, pp_sign, integer i ]
 471   where
 472     pp_sign = if i > 0 then char '+' else empty
 473
 474 pprAddr (AddrRegImm r1 imm)
 475   = hcat [ pprReg r1, char '+', pprImm imm ]
 476 #endif
 477 #if powerpc_TARGET_ARCH
 478 pprAddr (AddrRegReg r1 r2)
 479   = error "PprMach.pprAddr (AddrRegReg) unimplemented"
 480
 481 pprAddr (AddrRegImm r1 (ImmInt i)) = hcat [ int i, char '(', pprReg r1, char ')' ]
 482 pprAddr (AddrRegImm r1 (ImmInteger i)) = hcat [ integer i, char '(', pprReg r1, char ')' ]
 483 pprAddr (AddrRegImm r1 imm) = hcat [ pprImm imm, char '(', pprReg r1, char ')' ]
 484 #endif
 485 \end{code}
 486
 487 %************************************************************************
 488 %*                                                                      *
 489 \subsection{@pprInstr@: print an @Instr@}
 490 %*                                                                      *
 491 %************************************************************************
 492
 493 \begin{code}
 494 pprInstr :: Instr -> Doc
 495
 496 --pprInstr (COMMENT s) = empty -- nuke 'em
 497 pprInstr (COMMENT s)
 498    =  IF_ARCH_alpha( ((<>) (ptext SLIT("\t# ")) (ftext s))
 499      ,IF_ARCH_sparc( ((<>) (ptext SLIT("! "))   (ftext s))
 500      ,IF_ARCH_i386( ((<>) (ptext SLIT("# "))   (ftext s))
 501      ,IF_ARCH_powerpc( ((<>) (ptext SLIT("; ")) (ftext s))
 502      ,))))
 503
 504 pprInstr (DELTA d)
 505    = pprInstr (COMMENT (mkFastString ("\tdelta = " ++ show d)))
 506
 507 pprInstr (SEGMENT TextSegment)
 508     =  IF_ARCH_alpha(ptext SLIT("\t.text\n\t.align 3") {-word boundary-}
 509       ,IF_ARCH_sparc(ptext SLIT(".text\n\t.align 4") {-word boundary-}
 510       ,IF_ARCH_i386((text ".text\n\t.align 4,0x90") {-needs per-OS variation!-}
 511       ,IF_ARCH_powerpc(ptext SLIT(".text\n.align 2")
 512       ,))))
 513
 514 pprInstr (SEGMENT DataSegment)
 515     = ptext
 516          IF_ARCH_alpha(SLIT("\t.data\n\t.align 3")
 517         ,IF_ARCH_sparc(SLIT(".data\n\t.align 8") {-<8 will break double constants -}
 518         ,IF_ARCH_i386(SLIT(".data\n\t.align 4")
 519         ,IF_ARCH_powerpc(SLIT(".data\n.align 2")
 520         ,))))
 521
 522 pprInstr (SEGMENT RoDataSegment)
 523     = ptext
 524          IF_ARCH_alpha(SLIT("\t.data\n\t.align 3")
 525         ,IF_ARCH_sparc(SLIT(".data\n\t.align 8") {-<8 will break double constants -}
 526         ,IF_ARCH_i386(SLIT(".section .rodata\n\t.align 4")
 527         ,IF_ARCH_powerpc(IF_OS_darwin(SLIT(".const_data\n.align 2"),
 528                                       SLIT(".section .rodata\n\t.align 2"))
 529         ,))))
 530
 531 pprInstr (LABEL clab)
 532   = let
 533         pp_lab = pprCLabel_asm clab
 534     in
 535     hcat [
 536         if not (externallyVisibleCLabel clab) then
 537             empty
 538         else
 539             hcat [ptext
 540                          IF_ARCH_alpha(SLIT("\t.globl\t")
 541                         ,IF_ARCH_i386(SLIT(".globl ")
 542                         ,IF_ARCH_sparc(SLIT(".global\t")
 543                         ,IF_ARCH_powerpc(SLIT(".globl ")
 544                         ,))))
 545                         , pp_lab, char '\n'],
 546         pp_lab,
 547         char ':'
 548     ]
 549
 550 pprInstr (ASCII False{-no backslash conversion-} str)
 551   = hcat [ ptext SLIT("\t.asciz "), char '\"', text str, char '"' ]
 552
 553 pprInstr (ASCII True str)
 554   = vcat (map do1 (str ++ [chr 0]))
 555     where
 556        do1 :: Char -> Doc
 557        do1 c = ptext SLIT("\t.byte\t0x") <> hshow (ord c)
 558
 559        hshow :: Int -> Doc
 560        hshow n | n >= 0 && n <= 255
 561                = char (tab !! (n `div` 16)) <> char (tab !! (n `mod` 16))
 562        tab = "0123456789ABCDEF"
 563
 564
 565 pprInstr (DATA s xs)
 566   = vcat (concatMap (ppr_item s) xs)
 567     where
 568
 569 #if alpha_TARGET_ARCH
 570             ppr_item = error "ppr_item on Alpha"
 571 #endif
 572 #if sparc_TARGET_ARCH
 573         -- copy n paste of x86 version
 574         ppr_item B  x = [ptext SLIT("\t.byte\t") <> pprImm x]
 575         ppr_item W  x = [ptext SLIT("\t.long\t") <> pprImm x]
 576         ppr_item F  (ImmFloat r)
 577            = let bs = floatToBytes (fromRational r)
 578              in  map (\b -> ptext SLIT("\t.byte\t") <> pprImm (ImmInt b)) bs
 579         ppr_item DF (ImmDouble r)
 580            = let bs = doubleToBytes (fromRational r)
 581              in  map (\b -> ptext SLIT("\t.byte\t") <> pprImm (ImmInt b)) bs
 582 #endif
 583 #if i386_TARGET_ARCH
 584         ppr_item B  x = [ptext SLIT("\t.byte\t") <> pprImm x]
 585         ppr_item L  x = [ptext SLIT("\t.long\t") <> pprImm x]
 586         ppr_item F  (ImmFloat r)
 587            = let bs = floatToBytes (fromRational r)
 588              in  map (\b -> ptext SLIT("\t.byte\t") <> pprImm (ImmInt b)) bs
 589         ppr_item DF (ImmDouble r)
 590            = let bs = doubleToBytes (fromRational r)
 591              in  map (\b -> ptext SLIT("\t.byte\t") <> pprImm (ImmInt b)) bs
 592 #endif
 593 #if powerpc_TARGET_ARCH
 594         ppr_item B  x = [ptext SLIT("\t.byte\t") <> pprImm x]
 595         ppr_item Bu  x = [ptext SLIT("\t.byte\t") <> pprImm x]
 596         ppr_item H  x = [ptext SLIT("\t.short\t") <> pprImm x]
 597         ppr_item Hu  x = [ptext SLIT("\t.short\t") <> pprImm x]
 598         ppr_item W  x = [ptext SLIT("\t.long\t") <> pprImm x]
 599         ppr_item F  (ImmFloat r)
 600            = let bs = floatToBytes (fromRational r)
 601              in  map (\b -> ptext SLIT("\t.byte\t") <> pprImm (ImmInt b)) bs
 602         ppr_item DF (ImmDouble r)
 603            = let bs = doubleToBytes (fromRational r)
 604              in  map (\b -> ptext SLIT("\t.byte\t") <> pprImm (ImmInt b)) bs
 605 #endif
 606
 607 -- fall through to rest of (machine-specific) pprInstr...
 608 \end{code}
 609
 610 %************************************************************************
 611 %*                                                                      *
 612 \subsubsection{@pprInstr@ for an Alpha}
 613 %*                                                                      *
 614 %************************************************************************
 615
 616 \begin{code}
 617 #if alpha_TARGET_ARCH
 618
 619 pprInstr (LD size reg addr)
 620   = hcat [
 621         ptext SLIT("\tld"),
 622         pprSize size,
 623         char '\t',
 624         pprReg reg,
 625         comma,
 626         pprAddr addr
 627     ]
 628
 629 pprInstr (LDA reg addr)
 630   = hcat [
 631         ptext SLIT("\tlda\t"),
 632         pprReg reg,
 633         comma,
 634         pprAddr addr
 635     ]
 636
 637 pprInstr (LDAH reg addr)
 638   = hcat [
 639         ptext SLIT("\tldah\t"),
 640         pprReg reg,
 641         comma,
 642         pprAddr addr
 643     ]
 644
 645 pprInstr (LDGP reg addr)
 646   = hcat [
 647         ptext SLIT("\tldgp\t"),
 648         pprReg reg,
 649         comma,
 650         pprAddr addr
 651     ]
 652
 653 pprInstr (LDI size reg imm)
 654   = hcat [
 655         ptext SLIT("\tldi"),
 656         pprSize size,
 657         char '\t',
 658         pprReg reg,
 659         comma,
 660         pprImm imm
 661     ]
 662
 663 pprInstr (ST size reg addr)
 664   = hcat [
 665         ptext SLIT("\tst"),
 666         pprSize size,
 667         char '\t',
 668         pprReg reg,
 669         comma,
 670         pprAddr addr
 671     ]
 672
 673 pprInstr (CLR reg)
 674   = hcat [
 675         ptext SLIT("\tclr\t"),
 676         pprReg reg
 677     ]
 678
 679 pprInstr (ABS size ri reg)
 680   = hcat [
 681         ptext SLIT("\tabs"),
 682         pprSize size,
 683         char '\t',
 684         pprRI ri,
 685         comma,
 686         pprReg reg
 687     ]
 688
 689 pprInstr (NEG size ov ri reg)
 690   = hcat [
 691         ptext SLIT("\tneg"),
 692         pprSize size,
 693         if ov then ptext SLIT("v\t") else char '\t',
 694         pprRI ri,
 695         comma,
 696         pprReg reg
 697     ]
 698
 699 pprInstr (ADD size ov reg1 ri reg2)
 700   = hcat [
 701         ptext SLIT("\tadd"),
 702         pprSize size,
 703         if ov then ptext SLIT("v\t") else char '\t',
 704         pprReg reg1,
 705         comma,
 706         pprRI ri,
 707         comma,
 708         pprReg reg2
 709     ]
 710
 711 pprInstr (SADD size scale reg1 ri reg2)
 712   = hcat [
 713         ptext (case scale of {{-UNUSED:L -> SLIT("\ts4");-} Q -> SLIT("\ts8")}),
 714         ptext SLIT("add"),
 715         pprSize size,
 716         char '\t',
 717         pprReg reg1,
 718         comma,
 719         pprRI ri,
 720         comma,
 721         pprReg reg2
 722     ]
 723
 724 pprInstr (SUB size ov reg1 ri reg2)
 725   = hcat [
 726         ptext SLIT("\tsub"),
 727         pprSize size,
 728         if ov then ptext SLIT("v\t") else char '\t',
 729         pprReg reg1,
 730         comma,
 731         pprRI ri,
 732         comma,
 733         pprReg reg2
 734     ]
 735
 736 pprInstr (SSUB size scale reg1 ri reg2)
 737   = hcat [
 738         ptext (case scale of {{-UNUSED:L -> SLIT("\ts4");-} Q -> SLIT("\ts8")}),
 739         ptext SLIT("sub"),
 740         pprSize size,
 741         char '\t',
 742         pprReg reg1,
 743         comma,
 744         pprRI ri,
 745         comma,
 746         pprReg reg2
 747     ]
 748
 749 pprInstr (MUL size ov reg1 ri reg2)
 750   = hcat [
 751         ptext SLIT("\tmul"),
 752         pprSize size,
 753         if ov then ptext SLIT("v\t") else char '\t',
 754         pprReg reg1,
 755         comma,
 756         pprRI ri,
 757         comma,
 758         pprReg reg2
 759     ]
 760
 761 pprInstr (DIV size uns reg1 ri reg2)
 762   = hcat [
 763         ptext SLIT("\tdiv"),
 764         pprSize size,
 765         if uns then ptext SLIT("u\t") else char '\t',
 766         pprReg reg1,
 767         comma,
 768         pprRI ri,
 769         comma,
 770         pprReg reg2
 771     ]
 772
 773 pprInstr (REM size uns reg1 ri reg2)
 774   = hcat [
 775         ptext SLIT("\trem"),
 776         pprSize size,
 777         if uns then ptext SLIT("u\t") else char '\t',
 778         pprReg reg1,
 779         comma,
 780         pprRI ri,
 781         comma,
 782         pprReg reg2
 783     ]
 784
 785 pprInstr (NOT ri reg)
 786   = hcat [
 787         ptext SLIT("\tnot"),
 788         char '\t',
 789         pprRI ri,
 790         comma,
 791         pprReg reg
 792     ]
 793
 794 pprInstr (AND reg1 ri reg2) = pprRegRIReg SLIT("and") reg1 ri reg2
 795 pprInstr (ANDNOT reg1 ri reg2) = pprRegRIReg SLIT("andnot") reg1 ri reg2
 796 pprInstr (OR reg1 ri reg2) = pprRegRIReg SLIT("or") reg1 ri reg2
 797 pprInstr (ORNOT reg1 ri reg2) = pprRegRIReg SLIT("ornot") reg1 ri reg2
 798 pprInstr (XOR reg1 ri reg2) = pprRegRIReg SLIT("xor") reg1 ri reg2
 799 pprInstr (XORNOT reg1 ri reg2) = pprRegRIReg SLIT("xornot") reg1 ri reg2
 800
 801 pprInstr (SLL reg1 ri reg2) = pprRegRIReg SLIT("sll") reg1 ri reg2
 802 pprInstr (SRL reg1 ri reg2) = pprRegRIReg SLIT("srl") reg1 ri reg2
 803 pprInstr (SRA reg1 ri reg2) = pprRegRIReg SLIT("sra") reg1 ri reg2
 804
 805 pprInstr (ZAP reg1 ri reg2) = pprRegRIReg SLIT("zap") reg1 ri reg2
 806 pprInstr (ZAPNOT reg1 ri reg2) = pprRegRIReg SLIT("zapnot") reg1 ri reg2
 807
 808 pprInstr (NOP) = ptext SLIT("\tnop")
 809
 810 pprInstr (CMP cond reg1 ri reg2)
 811   = hcat [
 812         ptext SLIT("\tcmp"),
 813         pprCond cond,
 814         char '\t',
 815         pprReg reg1,
 816         comma,
 817         pprRI ri,
 818         comma,
 819         pprReg reg2
 820     ]
 821
 822 pprInstr (FCLR reg)
 823   = hcat [
 824         ptext SLIT("\tfclr\t"),
 825         pprReg reg
 826     ]
 827
 828 pprInstr (FABS reg1 reg2)
 829   = hcat [
 830         ptext SLIT("\tfabs\t"),
 831         pprReg reg1,
 832         comma,
 833         pprReg reg2
 834     ]
 835
 836 pprInstr (FNEG size reg1 reg2)
 837   = hcat [
 838         ptext SLIT("\tneg"),
 839         pprSize size,
 840         char '\t',
 841         pprReg reg1,
 842         comma,
 843         pprReg reg2
 844     ]
 845
 846 pprInstr (FADD size reg1 reg2 reg3) = pprSizeRegRegReg SLIT("add") size reg1 reg2 reg3
 847 pprInstr (FDIV size reg1 reg2 reg3) = pprSizeRegRegReg SLIT("div") size reg1 reg2 reg3
 848 pprInstr (FMUL size reg1 reg2 reg3) = pprSizeRegRegReg SLIT("mul") size reg1 reg2 reg3
 849 pprInstr (FSUB size reg1 reg2 reg3) = pprSizeRegRegReg SLIT("sub") size reg1 reg2 reg3
 850
 851 pprInstr (CVTxy size1 size2 reg1 reg2)
 852   = hcat [
 853         ptext SLIT("\tcvt"),
 854         pprSize size1,
 855         case size2 of {Q -> ptext SLIT("qc"); _ -> pprSize size2},
 856         char '\t',
 857         pprReg reg1,
 858         comma,
 859         pprReg reg2
 860     ]
 861
 862 pprInstr (FCMP size cond reg1 reg2 reg3)
 863   = hcat [
 864         ptext SLIT("\tcmp"),
 865         pprSize size,
 866         pprCond cond,
 867         char '\t',
 868         pprReg reg1,
 869         comma,
 870         pprReg reg2,
 871         comma,
 872         pprReg reg3
 873     ]
 874
 875 pprInstr (FMOV reg1 reg2)
 876   = hcat [
 877         ptext SLIT("\tfmov\t"),
 878         pprReg reg1,
 879         comma,
 880         pprReg reg2
 881     ]
 882
 883 pprInstr (BI ALWAYS reg lab) = pprInstr (BR lab)
 884
 885 pprInstr (BI NEVER reg lab) = empty
 886
 887 pprInstr (BI cond reg lab)
 888   = hcat [
 889         ptext SLIT("\tb"),
 890         pprCond cond,
 891         char '\t',
 892         pprReg reg,
 893         comma,
 894         pprImm lab
 895     ]
 896
 897 pprInstr (BF cond reg lab)
 898   = hcat [
 899         ptext SLIT("\tfb"),
 900         pprCond cond,
 901         char '\t',
 902         pprReg reg,
 903         comma,
 904         pprImm lab
 905     ]
 906
 907 pprInstr (BR lab)
 908   = (<>) (ptext SLIT("\tbr\t")) (pprImm lab)
 909
 910 pprInstr (JMP reg addr hint)
 911   = hcat [
 912         ptext SLIT("\tjmp\t"),
 913         pprReg reg,
 914         comma,
 915         pprAddr addr,
 916         comma,
 917         int hint
 918     ]
 919
 920 pprInstr (BSR imm n)
 921   = (<>) (ptext SLIT("\tbsr\t")) (pprImm imm)
 922
 923 pprInstr (JSR reg addr n)
 924   = hcat [
 925         ptext SLIT("\tjsr\t"),
 926         pprReg reg,
 927         comma,
 928         pprAddr addr
 929     ]
 930
 931 pprInstr (FUNBEGIN clab)
 932   = hcat [
 933         if (externallyVisibleCLabel clab) then
 934             hcat [ptext SLIT("\t.globl\t"), pp_lab, char '\n']
 935         else
 936             empty,
 937         ptext SLIT("\t.ent "),
 938         pp_lab,
 939         char '\n',
 940         pp_lab,
 941         pp_ldgp,
 942         pp_lab,
 943         pp_frame
 944     ]
 945     where
 946         pp_lab = pprCLabel_asm clab
 947
 948         -- NEVER use commas within those string literals, cpp will ruin your day
 949         pp_ldgp  = hcat [ ptext SLIT(":\n\tldgp $29"), char ',', ptext SLIT("0($27)\n") ]
 950         pp_frame = hcat [ ptext SLIT("..ng:\n\t.frame $30"), char ',',
 951                           ptext SLIT("4240"), char ',',
 952                           ptext SLIT("$26"), char ',',
 953                           ptext SLIT("0\n\t.prologue 1") ]
 954
 955 pprInstr (FUNEND clab)
 956   = (<>) (ptext SLIT("\t.align 4\n\t.end ")) (pprCLabel_asm clab)
 957 \end{code}
 958
 959 Continue with Alpha-only printing bits and bobs:
 960 \begin{code}
 961 pprRI :: RI -> Doc
 962
 963 pprRI (RIReg r) = pprReg r
 964 pprRI (RIImm r) = pprImm r
 965
 966 pprRegRIReg :: LitString -> Reg -> RI -> Reg -> Doc
 967 pprRegRIReg name reg1 ri reg2
 968   = hcat [
 969         char '\t',
 970         ptext name,
 971         char '\t',
 972         pprReg reg1,
 973         comma,
 974         pprRI ri,
 975         comma,
 976         pprReg reg2
 977     ]
 978
 979 pprSizeRegRegReg :: LitString -> Size -> Reg -> Reg -> Reg -> Doc
 980 pprSizeRegRegReg name size reg1 reg2 reg3
 981   = hcat [
 982         char '\t',
 983         ptext name,
 984         pprSize size,
 985         char '\t',
 986         pprReg reg1,
 987         comma,
 988         pprReg reg2,
 989         comma,
 990         pprReg reg3
 991     ]
 992
 993 #endif /* alpha_TARGET_ARCH */
 994 \end{code}
 995
 996 %************************************************************************
 997 %*                                                                      *
 998 \subsubsection{@pprInstr@ for an I386}
 999 %*                                                                      *
1000 %************************************************************************
1001
1002 \begin{code}
1003 #if i386_TARGET_ARCH
1004
1005 pprInstr v@(MOV size s@(OpReg src) d@(OpReg dst)) -- hack
1006   | src == dst
1007   =
1008 #if 0 /* #ifdef DEBUG */
1009     (<>) (ptext SLIT("# warning: ")) (pprSizeOpOp SLIT("mov") size s d)
1010 #else
1011     empty
1012 #endif
1013 pprInstr (MOV size src dst)
1014   = pprSizeOpOp SLIT("mov") size src dst
1015 pprInstr (MOVZxL sizes src dst) = pprSizeOpOpCoerce SLIT("movz") sizes L src dst
1016 pprInstr (MOVSxL sizes src dst) = pprSizeOpOpCoerce SLIT("movs") sizes L src dst
1017
1018 -- here we do some patching, since the physical registers are only set late
1019 -- in the code generation.
1020 pprInstr (LEA size (OpAddr (AddrBaseIndex src1@(Just reg1) (Just (reg2,1)) (ImmInt 0))) dst@(OpReg reg3))
1021   | reg1 == reg3
1022   = pprSizeOpOp SLIT("add") size (OpReg reg2) dst
1023 pprInstr (LEA size (OpAddr (AddrBaseIndex src1@(Just reg1) (Just (reg2,1)) (ImmInt 0))) dst@(OpReg reg3))
1024   | reg2 == reg3
1025   = pprSizeOpOp SLIT("add") size (OpReg reg1) dst
1026 pprInstr (LEA size (OpAddr (AddrBaseIndex src1@(Just reg1) Nothing displ)) dst@(OpReg reg3))
1027   | reg1 == reg3
1028   = pprInstr (ADD size (OpImm displ) dst)
1029 pprInstr (LEA size src dst) = pprSizeOpOp SLIT("lea") size src dst
1030
1031 pprInstr (ADD size (OpImm (ImmInt (-1))) dst)
1032   = pprSizeOp SLIT("dec") size dst
1033 pprInstr (ADD size (OpImm (ImmInt 1)) dst)
1034   = pprSizeOp SLIT("inc") size dst
1035 pprInstr (ADD size src dst)
1036   = pprSizeOpOp SLIT("add") size src dst
1037 pprInstr (SUB size src dst) = pprSizeOpOp SLIT("sub") size src dst
1038 pprInstr (IMUL size op1 op2) = pprSizeOpOp SLIT("imul") size op1 op2
1039
1040 {- A hack.  The Intel documentation says that "The two and three
1041    operand forms [of IMUL] may also be used with unsigned operands
1042    because the lower half of the product is the same regardless if
1043    (sic) the operands are signed or unsigned.  The CF and OF flags,
1044    however, cannot be used to determine if the upper half of the
1045    result is non-zero."  So there.
1046 -}
1047 pprInstr (MUL size op1 op2) = pprSizeOpOp SLIT("imul") size op1 op2
1048
1049 pprInstr (AND size src dst) = pprSizeOpOp SLIT("and") size src dst
1050 pprInstr (OR  size src dst) = pprSizeOpOp SLIT("or")  size src dst
1051 pprInstr (XOR size src dst) = pprSizeOpOp SLIT("xor")  size src dst
1052 pprInstr (NOT size op) = pprSizeOp SLIT("not") size op
1053 pprInstr (NEGI size op) = pprSizeOp SLIT("neg") size op
1054
1055 pprInstr (SHL size imm dst) = pprSizeImmOp SLIT("shl") size imm dst
1056 pprInstr (SAR size imm dst) = pprSizeImmOp SLIT("sar") size imm dst
1057 pprInstr (SHR size imm dst) = pprSizeImmOp SLIT("shr") size imm dst
1058 pprInstr (BT  size imm src) = pprSizeImmOp SLIT("bt")  size imm src
1059
1060 pprInstr (CMP size src dst) = pprSizeOpOp SLIT("cmp")  size src dst
1061 pprInstr (TEST size src dst) = pprSizeOpOp SLIT("test")  size src dst
1062 pprInstr (PUSH size op) = pprSizeOp SLIT("push") size op
1063 pprInstr (POP size op) = pprSizeOp SLIT("pop") size op
1064 pprInstr PUSHA = ptext SLIT("\tpushal")
1065 pprInstr POPA = ptext SLIT("\tpopal")
1066
1067 pprInstr NOP = ptext SLIT("\tnop")
1068 pprInstr CLTD = ptext SLIT("\tcltd")
1069
1070 pprInstr (SETCC cond op) = pprCondInstr SLIT("set") cond (pprOperand B op)
1071
1072 pprInstr (JXX cond lab) = pprCondInstr SLIT("j") cond (pprCLabel_asm lab)
1073
1074 pprInstr (JMP dsts (OpImm imm)) = (<>) (ptext SLIT("\tjmp ")) (pprImm imm)
1075 pprInstr (JMP dsts op)          = (<>) (ptext SLIT("\tjmp *")) (pprOperand L op)
1076 pprInstr (CALL (Left imm))      = (<>) (ptext SLIT("\tcall ")) (pprImm imm)
1077 pprInstr (CALL (Right reg))     = (<>) (ptext SLIT("\tcall *")) (pprReg L reg)
1078
1079 -- First bool indicates signedness; second whether quot or rem
1080 pprInstr (IQUOT sz src dst) = pprInstr_quotRem True True sz src dst
1081 pprInstr (IREM  sz src dst) = pprInstr_quotRem True False sz src dst
1082
1083 pprInstr (QUOT sz src dst) = pprInstr_quotRem False True sz src dst
1084 pprInstr (REM  sz src dst) = pprInstr_quotRem False False sz src dst
1085
1086 pprInstr (IMUL64 sd_hi sd_lo) = pprInstr_imul64 sd_hi sd_lo
1087
1088
1089 -- Simulating a flat register set on the x86 FP stack is tricky.
1090 -- you have to free %st(7) before pushing anything on the FP reg stack
1091 -- so as to preclude the possibility of a FP stack overflow exception.
1092 pprInstr g@(GMOV src dst)
1093    | src == dst
1094    = empty
1095    | otherwise
1096    = pprG g (hcat [gtab, gpush src 0, gsemi, gpop dst 1])
1097
1098 -- GLD sz addr dst ==> FFREE %st(7) ; FLDsz addr ; FSTP (dst+1)
1099 pprInstr g@(GLD sz addr dst)
1100  = pprG g (hcat [gtab, text "ffree %st(7) ; fld", pprSize sz, gsp,
1101                  pprAddr addr, gsemi, gpop dst 1])
1102
1103 -- GST sz src addr ==> FFREE %st(7) ; FLD dst ; FSTPsz addr
1104 pprInstr g@(GST sz src addr)
1105  = pprG g (hcat [gtab, gpush src 0, gsemi,
1106                  text "fstp", pprSize sz, gsp, pprAddr addr])
1107
1108 pprInstr g@(GLDZ dst)
1109  = pprG g (hcat [gtab, text "ffree %st(7) ; fldz ; ", gpop dst 1])
1110 pprInstr g@(GLD1 dst)
1111  = pprG g (hcat [gtab, text "ffree %st(7) ; fld1 ; ", gpop dst 1])
1112
1113 pprInstr g@(GFTOI src dst)
1114    = pprInstr (GDTOI src dst)
1115 pprInstr g@(GDTOI src dst)
1116    = pprG g (hcat [gtab, text "subl $4, %esp ; ",
1117                    gpush src 0, gsemi, text "fistpl 0(%esp) ; popl ",
1118                    pprReg L dst])
1119
1120 pprInstr g@(GITOF src dst)
1121    = pprInstr (GITOD src dst)
1122 pprInstr g@(GITOD src dst)
1123    = pprG g (hcat [gtab, text "pushl ", pprReg L src,
1124                    text " ; ffree %st(7); fildl (%esp) ; ",
1125                    gpop dst 1, text " ; addl $4,%esp"])
1126
1127 {- Gruesome swamp follows.  If you're unfortunate enough to have ventured
1128    this far into the jungle AND you give a Rat's Ass (tm) what's going
1129    on, here's the deal.  Generate code to do a floating point comparison
1130    of src1 and src2, of kind cond, and set the Zero flag if true.
1131
1132    The complications are to do with handling NaNs correctly.  We want the
1133    property that if either argument is NaN, then the result of the
1134    comparison is False ... except if we're comparing for inequality,
1135    in which case the answer is True.
1136
1137    Here's how the general (non-inequality) case works.  As an
1138    example, consider generating the an equality test:
1139
1140      pushl %eax         -- we need to mess with this
1141      <get src1 to top of FPU stack>
1142      fcomp <src2 location in FPU stack> and pop pushed src1
1143                 -- Result of comparison is in FPU Status Register bits
1144                 -- C3 C2 and C0
1145      fstsw %ax  -- Move FPU Status Reg to %ax
1146      sahf       -- move C3 C2 C0 from %ax to integer flag reg
1147      -- now the serious magic begins
1148      setpo %ah     -- %ah = if comparable(neither arg was NaN) then 1 else 0
1149      sete  %al     -- %al = if arg1 == arg2 then 1 else 0
1150      andb %ah,%al  -- %al &= %ah
1151                    -- so %al == 1 iff (comparable && same); else it holds 0
1152      decb %al      -- %al == 0, ZeroFlag=1  iff (comparable && same);
1153                       else %al == 0xFF, ZeroFlag=0
1154      -- the zero flag is now set as we desire.
1155      popl %eax
1156
1157    The special case of inequality differs thusly:
1158
1159      setpe %ah     -- %ah = if incomparable(either arg was NaN) then 1 else 0
1160      setne %al     -- %al = if arg1 /= arg2 then 1 else 0
1161      orb %ah,%al   -- %al = if (incomparable || different) then 1 else 0
1162      decb %al      -- if (incomparable || different) then (%al == 0, ZF=1)
1163                                                      else (%al == 0xFF, ZF=0)
1164 -}
1165 pprInstr g@(GCMP cond src1 src2)
1166    | case cond of { NE -> True; other -> False }
1167    = pprG g (vcat [
1168         hcat [gtab, text "pushl %eax ; ",gpush src1 0],
1169         hcat [gtab, text "fcomp ", greg src2 1,
1170                     text "; fstsw %ax ; sahf ;  setpe %ah"],
1171         hcat [gtab, text "setne %al ;  ",
1172               text "orb %ah,%al ;  decb %al ;  popl %eax"]
1173     ])
1174    | otherwise
1175    = pprG g (vcat [
1176         hcat [gtab, text "pushl %eax ; ",gpush src1 0],
1177         hcat [gtab, text "fcomp ", greg src2 1,
1178                     text "; fstsw %ax ; sahf ;  setpo %ah"],
1179         hcat [gtab, text "set", pprCond (fix_FP_cond cond), text " %al ;  ",
1180               text "andb %ah,%al ;  decb %al ;  popl %eax"]
1181     ])
1182     where
1183         {- On the 486, the flags set by FP compare are the unsigned ones!
1184            (This looks like a HACK to me.  WDP 96/03)
1185         -}
1186         fix_FP_cond :: Cond -> Cond
1187         fix_FP_cond GE   = GEU
1188         fix_FP_cond GTT  = GU
1189         fix_FP_cond LTT  = LU
1190         fix_FP_cond LE   = LEU
1191         fix_FP_cond EQQ  = EQQ
1192         fix_FP_cond NE   = NE
1193         -- there should be no others
1194
1195
1196 pprInstr g@(GABS sz src dst)
1197    = pprG g (hcat [gtab, gpush src 0, text " ; fabs ; ", gpop dst 1])
1198 pprInstr g@(GNEG sz src dst)
1199    = pprG g (hcat [gtab, gpush src 0, text " ; fchs ; ", gpop dst 1])
1200
1201 pprInstr g@(GSQRT sz src dst)
1202    = pprG g (hcat [gtab, gpush src 0, text " ; fsqrt"] $$
1203              hcat [gtab, gcoerceto sz, gpop dst 1])
1204 pprInstr g@(GSIN sz src dst)
1205    = pprG g (hcat [gtab, gpush src 0, text " ; fsin"] $$
1206              hcat [gtab, gcoerceto sz, gpop dst 1])
1207 pprInstr g@(GCOS sz src dst)
1208    = pprG g (hcat [gtab, gpush src 0, text " ; fcos"] $$
1209              hcat [gtab, gcoerceto sz, gpop dst 1])
1210 pprInstr g@(GTAN sz src dst)
1211    = pprG g (hcat [gtab, text "ffree %st(6) ; ",
1212                    gpush src 0, text " ; fptan ; ",
1213                    text " fstp %st(0)"] $$
1214              hcat [gtab, gcoerceto sz, gpop dst 1])
1215
1216 -- In the translations for GADD, GMUL, GSUB and GDIV,
1217 -- the first two cases are mere optimisations.  The otherwise clause
1218 -- generates correct code under all circumstances.
1219
1220 pprInstr g@(GADD sz src1 src2 dst)
1221    | src1 == dst
1222    = pprG g (text "\t#GADD-xxxcase1" $$
1223              hcat [gtab, gpush src2 0,
1224                    text " ; faddp %st(0),", greg src1 1])
1225    | src2 == dst
1226    = pprG g (text "\t#GADD-xxxcase2" $$
1227              hcat [gtab, gpush src1 0,
1228                    text " ; faddp %st(0),", greg src2 1])
1229    | otherwise
1230    = pprG g (hcat [gtab, gpush src1 0,
1231                    text " ; fadd ", greg src2 1, text ",%st(0)",
1232                    gsemi, gpop dst 1])
1233
1234
1235 pprInstr g@(GMUL sz src1 src2 dst)
1236    | src1 == dst
1237    = pprG g (text "\t#GMUL-xxxcase1" $$
1238              hcat [gtab, gpush src2 0,
1239                    text " ; fmulp %st(0),", greg src1 1])
1240    | src2 == dst
1241    = pprG g (text "\t#GMUL-xxxcase2" $$
1242              hcat [gtab, gpush src1 0,
1243                    text " ; fmulp %st(0),", greg src2 1])
1244    | otherwise
1245    = pprG g (hcat [gtab, gpush src1 0,
1246                    text " ; fmul ", greg src2 1, text ",%st(0)",
1247                    gsemi, gpop dst 1])
1248
1249
1250 pprInstr g@(GSUB sz src1 src2 dst)
1251    | src1 == dst
1252    = pprG g (text "\t#GSUB-xxxcase1" $$
1253              hcat [gtab, gpush src2 0,
1254                    text " ; fsubrp %st(0),", greg src1 1])
1255    | src2 == dst
1256    = pprG g (text "\t#GSUB-xxxcase2" $$
1257              hcat [gtab, gpush src1 0,
1258                    text " ; fsubp %st(0),", greg src2 1])
1259    | otherwise
1260    = pprG g (hcat [gtab, gpush src1 0,
1261                    text " ; fsub ", greg src2 1, text ",%st(0)",
1262                    gsemi, gpop dst 1])
1263
1264
1265 pprInstr g@(GDIV sz src1 src2 dst)
1266    | src1 == dst
1267    = pprG g (text "\t#GDIV-xxxcase1" $$
1268              hcat [gtab, gpush src2 0,
1269                    text " ; fdivrp %st(0),", greg src1 1])
1270    | src2 == dst
1271    = pprG g (text "\t#GDIV-xxxcase2" $$
1272              hcat [gtab, gpush src1 0,
1273                    text " ; fdivp %st(0),", greg src2 1])
1274    | otherwise
1275    = pprG g (hcat [gtab, gpush src1 0,
1276                    text " ; fdiv ", greg src2 1, text ",%st(0)",
1277                    gsemi, gpop dst 1])
1278
1279
1280 pprInstr GFREE
1281    = vcat [ ptext SLIT("\tffree %st(0) ;ffree %st(1) ;ffree %st(2) ;ffree %st(3)"),
1282             ptext SLIT("\tffree %st(4) ;ffree %st(5) ;ffree %st(6) ;ffree %st(7)")
1283           ]
1284
1285
1286 pprInstr_quotRem signed isQuot sz src dst
1287    | case sz of L -> False; _ -> True
1288    = panic "pprInstr_quotRem: dunno how to do non-32bit operands"
1289    | otherwise
1290    = vcat [
1291      (text "\t# BEGIN " <> fakeInsn),
1292      (text "\tpushl $0;  pushl %eax;  pushl %edx;  pushl " <> pprOperand sz src),
1293      (text "\tmovl " <> pprOperand sz dst <> text ",%eax;  " <> widen_to_64),
1294      (x86op <> text " 0(%esp);  movl " <> text resReg <> text ",12(%esp)"),
1295      (text "\tpopl %edx;  popl %edx;  popl %eax;  popl " <> pprOperand sz dst),
1296      (text "\t# END   " <> fakeInsn)
1297      ]
1298      where
1299         widen_to_64 | signed     = text "cltd"
1300                     | not signed = text "xorl %edx,%edx"
1301         x86op = if signed then text "\tidivl" else text "\tdivl"
1302         resReg = if isQuot then "%eax" else "%edx"
1303         opStr  | signed     = if isQuot then "IQUOT" else "IREM"
1304                | not signed = if isQuot then "QUOT"  else "REM"
1305         fakeInsn = text opStr <+> pprOperand sz src
1306                               <> char ',' <+> pprOperand sz dst
1307
1308 -- Emit code to make hi_reg:lo_reg be the 64-bit product of hi_reg and lo_reg
1309 pprInstr_imul64 hi_reg lo_reg
1310    = let fakeInsn = text "imul64" <+> pp_hi_reg <> comma <+> pp_lo_reg
1311          pp_hi_reg = pprReg L hi_reg
1312          pp_lo_reg = pprReg L lo_reg
1313      in
1314          vcat [
1315             text "\t# BEGIN " <> fakeInsn,
1316             text "\tpushl" <+> pp_hi_reg <> text" ;  pushl" <+> pp_lo_reg,
1317             text "\tpushl %eax ; pushl %edx",
1318             text "\tmovl 12(%esp), %eax ; imull 8(%esp)",
1319             text "\tmovl %edx, 12(%esp) ; movl %eax, 8(%esp)",
1320             text "\tpopl %edx ; popl %eax",
1321             text "\tpopl" <+> pp_lo_reg <> text " ;  popl" <+> pp_hi_reg,
1322             text "\t# END   " <> fakeInsn
1323          ]
1324
1325
1326 --------------------------
1327
1328 -- coerce %st(0) to the specified size
1329 gcoerceto DF = empty
1330 gcoerceto  F = empty --text "subl $4,%esp ; fstps (%esp) ; flds (%esp) ; addl $4,%esp ; "
1331
1332 gpush reg offset
1333    = hcat [text "ffree %st(7) ; fld ", greg reg offset]
1334 gpop reg offset
1335    = hcat [text "fstp ", greg reg offset]
1336
1337 bogus = text "\tbogus"
1338 greg reg offset = text "%st(" <> int (gregno reg - 8+offset) <> char ')'
1339 gsemi = text " ; "
1340 gtab  = char '\t'
1341 gsp   = char ' '
1342
1343 gregno (RealReg i) = i
1344 gregno other       = --pprPanic "gregno" (ppr other)
1345                      999   -- bogus; only needed for debug printing
1346
1347 pprG :: Instr -> Doc -> Doc
1348 pprG fake actual
1349    = (char '#' <> pprGInstr fake) $$ actual
1350
1351 pprGInstr (GMOV src dst)   = pprSizeRegReg SLIT("gmov") DF src dst
1352 pprGInstr (GLD sz src dst) = pprSizeAddrReg SLIT("gld") sz src dst
1353 pprGInstr (GST sz src dst) = pprSizeRegAddr SLIT("gst") sz src dst
1354
1355 pprGInstr (GLDZ dst) = pprSizeReg SLIT("gldz") DF dst
1356 pprGInstr (GLD1 dst) = pprSizeReg SLIT("gld1") DF dst
1357
1358 pprGInstr (GFTOI src dst) = pprSizeSizeRegReg SLIT("gftoi") F L  src dst
1359 pprGInstr (GDTOI src dst) = pprSizeSizeRegReg SLIT("gdtoi") DF L src dst
1360
1361 pprGInstr (GITOF src dst) = pprSizeSizeRegReg SLIT("gitof") L F  src dst
1362 pprGInstr (GITOD src dst) = pprSizeSizeRegReg SLIT("gitod") L DF src dst
1363
1364 pprGInstr (GCMP co src dst) = pprCondRegReg SLIT("gcmp_") DF co src dst
1365 pprGInstr (GABS sz src dst) = pprSizeRegReg SLIT("gabs") sz src dst
1366 pprGInstr (GNEG sz src dst) = pprSizeRegReg SLIT("gneg") sz src dst
1367 pprGInstr (GSQRT sz src dst) = pprSizeRegReg SLIT("gsqrt") sz src dst
1368 pprGInstr (GSIN sz src dst) = pprSizeRegReg SLIT("gsin") sz src dst
1369 pprGInstr (GCOS sz src dst) = pprSizeRegReg SLIT("gcos") sz src dst
1370 pprGInstr (GTAN sz src dst) = pprSizeRegReg SLIT("gtan") sz src dst
1371
1372 pprGInstr (GADD sz src1 src2 dst) = pprSizeRegRegReg SLIT("gadd") sz src1 src2 dst
1373 pprGInstr (GSUB sz src1 src2 dst) = pprSizeRegRegReg SLIT("gsub") sz src1 src2 dst
1374 pprGInstr (GMUL sz src1 src2 dst) = pprSizeRegRegReg SLIT("gmul") sz src1 src2 dst
1375 pprGInstr (GDIV sz src1 src2 dst) = pprSizeRegRegReg SLIT("gdiv") sz src1 src2 dst
1376 \end{code}
1377
1378 Continue with I386-only printing bits and bobs:
1379 \begin{code}
1380 pprDollImm :: Imm -> Doc
1381
1382 pprDollImm i =  ptext SLIT("$") <> pprImm i
1383
1384 pprOperand :: Size -> Operand -> Doc
1385 pprOperand s (OpReg r)   = pprReg s r
1386 pprOperand s (OpImm i)   = pprDollImm i
1387 pprOperand s (OpAddr ea) = pprAddr ea
1388
1389 pprSizeImmOp :: LitString -> Size -> Imm -> Operand -> Doc
1390 pprSizeImmOp name size imm op1
1391   = hcat [
1392         char '\t',
1393         ptext name,
1394         pprSize size,
1395         space,
1396         char '$',
1397         pprImm imm,
1398         comma,
1399         pprOperand size op1
1400     ]
1401
1402 pprSizeOp :: LitString -> Size -> Operand -> Doc
1403 pprSizeOp name size op1
1404   = hcat [
1405         char '\t',
1406         ptext name,
1407         pprSize size,
1408         space,
1409         pprOperand size op1
1410     ]
1411
1412 pprSizeOpOp :: LitString -> Size -> Operand -> Operand -> Doc
1413 pprSizeOpOp name size op1 op2
1414   = hcat [
1415         char '\t',
1416         ptext name,
1417         pprSize size,
1418         space,
1419         pprOperand size op1,
1420         comma,
1421         pprOperand size op2
1422     ]
1423
1424 pprSizeByteOpOp :: LitString -> Size -> Operand -> Operand -> Doc
1425 pprSizeByteOpOp name size op1 op2
1426   = hcat [
1427         char '\t',
1428         ptext name,
1429         pprSize size,
1430         space,
1431         pprOperand B op1,
1432         comma,
1433         pprOperand size op2
1434     ]
1435
1436 pprSizeOpReg :: LitString -> Size -> Operand -> Reg -> Doc
1437 pprSizeOpReg name size op1 reg
1438   = hcat [
1439         char '\t',
1440         ptext name,
1441         pprSize size,
1442         space,
1443         pprOperand size op1,
1444         comma,
1445         pprReg size reg
1446     ]
1447
1448 pprSizeReg :: LitString -> Size -> Reg -> Doc
1449 pprSizeReg name size reg1
1450   = hcat [
1451         char '\t',
1452         ptext name,
1453         pprSize size,
1454         space,
1455         pprReg size reg1
1456     ]
1457
1458 pprSizeRegReg :: LitString -> Size -> Reg -> Reg -> Doc
1459 pprSizeRegReg name size reg1 reg2
1460   = hcat [
1461         char '\t',
1462         ptext name,
1463         pprSize size,
1464         space,
1465         pprReg size reg1,
1466         comma,
1467         pprReg size reg2
1468     ]
1469
1470 pprCondRegReg :: LitString -> Size -> Cond -> Reg -> Reg -> Doc
1471 pprCondRegReg name size cond reg1 reg2
1472   = hcat [
1473         char '\t',
1474         ptext name,
1475         pprCond cond,
1476         space,
1477         pprReg size reg1,
1478         comma,
1479         pprReg size reg2
1480     ]
1481
1482 pprSizeSizeRegReg :: LitString -> Size -> Size -> Reg -> Reg -> Doc
1483 pprSizeSizeRegReg name size1 size2 reg1 reg2
1484   = hcat [
1485         char '\t',
1486         ptext name,
1487         pprSize size1,
1488         pprSize size2,
1489         space,
1490         pprReg size1 reg1,
1491
1492         comma,
1493         pprReg size2 reg2
1494     ]
1495
1496 pprSizeRegRegReg :: LitString -> Size -> Reg -> Reg -> Reg -> Doc
1497 pprSizeRegRegReg name size reg1 reg2 reg3
1498   = hcat [
1499         char '\t',
1500         ptext name,
1501         pprSize size,
1502         space,
1503         pprReg size reg1,
1504         comma,
1505         pprReg size reg2,
1506         comma,
1507         pprReg size reg3
1508     ]
1509
1510 pprSizeAddr :: LitString -> Size -> MachRegsAddr -> Doc
1511 pprSizeAddr name size op
1512   = hcat [
1513         char '\t',
1514         ptext name,
1515         pprSize size,
1516         space,
1517         pprAddr op
1518     ]
1519
1520 pprSizeAddrReg :: LitString -> Size -> MachRegsAddr -> Reg -> Doc
1521 pprSizeAddrReg name size op dst
1522   = hcat [
1523         char '\t',
1524         ptext name,
1525         pprSize size,
1526         space,
1527         pprAddr op,
1528         comma,
1529         pprReg size dst
1530     ]
1531
1532 pprSizeRegAddr :: LitString -> Size -> Reg -> MachRegsAddr -> Doc
1533 pprSizeRegAddr name size src op
1534   = hcat [
1535         char '\t',
1536         ptext name,
1537         pprSize size,
1538         space,
1539         pprReg size src,
1540         comma,
1541         pprAddr op
1542     ]
1543
1544 pprOpOp :: LitString -> Size -> Operand -> Operand -> Doc
1545 pprOpOp name size op1 op2
1546   = hcat [
1547         char '\t',
1548         ptext name, space,
1549         pprOperand size op1,
1550         comma,
1551         pprOperand size op2
1552     ]
1553
1554 pprSizeOpOpCoerce :: LitString -> Size -> Size -> Operand -> Operand -> Doc
1555 pprSizeOpOpCoerce name size1 size2 op1 op2
1556   = hcat [ char '\t', ptext name, pprSize size1, pprSize size2, space,
1557         pprOperand size1 op1,
1558         comma,
1559         pprOperand size2 op2
1560     ]
1561
1562 pprCondInstr :: LitString -> Cond -> Doc -> Doc
1563 pprCondInstr name cond arg
1564   = hcat [ char '\t', ptext name, pprCond cond, space, arg]
1565
1566 #endif /* i386_TARGET_ARCH */
1567 \end{code}
1568
1569 %************************************************************************
1570 %*                                                                      *
1571 \subsubsection{@pprInstr@ for a SPARC}
1572 %*                                                                      *
1573 %************************************************************************
1574
1575 \begin{code}
1576 #if sparc_TARGET_ARCH
1577
1578 -- a clumsy hack for now, to handle possible double alignment problems
1579
1580 -- even clumsier, to allow for RegReg regs that show when doing indexed
1581 -- reads (bytearrays).
1582 --
1583
1584 -- Translate to the following:
1585 --    add g1,g2,g1
1586 --    ld  [g1],%fn
1587 --    ld  [g1+4],%f(n+1)
1588 --    sub g1,g2,g1           -- to restore g1
1589 pprInstr (LD DF (AddrRegReg g1 g2) reg)
1590   = vcat [
1591        hcat [ptext SLIT("\tadd\t"), pprReg g1,comma,pprReg g2,comma,pprReg g1],
1592        hcat [pp_ld_lbracket, pprReg g1, pp_rbracket_comma, pprReg reg],
1593        hcat [pp_ld_lbracket, pprReg g1, ptext SLIT("+4]"), comma, pprReg (fPair reg)],
1594        hcat [ptext SLIT("\tsub\t"), pprReg g1,comma,pprReg g2,comma,pprReg g1]
1595     ]
1596
1597 -- Translate to
1598 --    ld  [addr],%fn
1599 --    ld  [addr+4],%f(n+1)
1600 pprInstr (LD DF addr reg) | isJust off_addr
1601   = vcat [
1602        hcat [pp_ld_lbracket, pprAddr addr, pp_rbracket_comma, pprReg reg],
1603        hcat [pp_ld_lbracket, pprAddr addr2, pp_rbracket_comma,pprReg (fPair reg)]
1604     ]
1605   where
1606     off_addr = addrOffset addr 4
1607     addr2 = case off_addr of Just x -> x
1608
1609
1610 pprInstr (LD size addr reg)
1611   = hcat [
1612        ptext SLIT("\tld"),
1613        pprSize size,
1614        char '\t',
1615        lbrack,
1616        pprAddr addr,
1617        pp_rbracket_comma,
1618        pprReg reg
1619     ]
1620
1621 -- The same clumsy hack as above
1622
1623 -- Translate to the following:
1624 --    add g1,g2,g1
1625 --    st  %fn,[g1]
1626 --    st  %f(n+1),[g1+4]
1627 --    sub g1,g2,g1           -- to restore g1
1628 pprInstr (ST DF reg (AddrRegReg g1 g2))
1629  = vcat [
1630        hcat [ptext SLIT("\tadd\t"), pprReg g1,comma,pprReg g2,comma,pprReg g1],
1631        hcat [ptext SLIT("\tst\t"), pprReg reg, pp_comma_lbracket,
1632              pprReg g1, rbrack],
1633        hcat [ptext SLIT("\tst\t"), pprReg (fPair reg), pp_comma_lbracket,
1634              pprReg g1, ptext SLIT("+4]")],
1635        hcat [ptext SLIT("\tsub\t"), pprReg g1,comma,pprReg g2,comma,pprReg g1]
1636     ]
1637
1638 -- Translate to
1639 --    st  %fn,[addr]
1640 --    st  %f(n+1),[addr+4]
1641 pprInstr (ST DF reg addr) | isJust off_addr
1642  = vcat [
1643       hcat [ptext SLIT("\tst\t"), pprReg reg, pp_comma_lbracket,
1644             pprAddr addr, rbrack],
1645       hcat [ptext SLIT("\tst\t"), pprReg (fPair reg), pp_comma_lbracket,
1646             pprAddr addr2, rbrack]
1647     ]
1648   where
1649     off_addr = addrOffset addr 4
1650     addr2 = case off_addr of Just x -> x
1651
1652 -- no distinction is made between signed and unsigned bytes on stores for the
1653 -- Sparc opcodes (at least I cannot see any, and gas is nagging me --SOF),
1654 -- so we call a special-purpose pprSize for ST..
1655
1656 pprInstr (ST size reg addr)
1657   = hcat [
1658        ptext SLIT("\tst"),
1659        pprStSize size,
1660        char '\t',
1661        pprReg reg,
1662        pp_comma_lbracket,
1663        pprAddr addr,
1664        rbrack
1665     ]
1666
1667 pprInstr (ADD x cc reg1 ri reg2)
1668   | not x && not cc && riZero ri
1669   = hcat [ ptext SLIT("\tmov\t"), pprReg reg1, comma, pprReg reg2 ]
1670   | otherwise
1671   = pprRegRIReg (if x then SLIT("addx") else SLIT("add")) cc reg1 ri reg2
1672
1673 pprInstr (SUB x cc reg1 ri reg2)
1674   | not x && cc && reg2 == g0
1675   = hcat [ ptext SLIT("\tcmp\t"), pprReg reg1, comma, pprRI ri ]
1676   | not x && not cc && riZero ri
1677   = hcat [ ptext SLIT("\tmov\t"), pprReg reg1, comma, pprReg reg2 ]
1678   | otherwise
1679   = pprRegRIReg (if x then SLIT("subx") else SLIT("sub")) cc reg1 ri reg2
1680
1681 pprInstr (AND  b reg1 ri reg2) = pprRegRIReg SLIT("and")  b reg1 ri reg2
1682 pprInstr (ANDN b reg1 ri reg2) = pprRegRIReg SLIT("andn") b reg1 ri reg2
1683
1684 pprInstr (OR b reg1 ri reg2)
1685   | not b && reg1 == g0
1686   = let doit = hcat [ ptext SLIT("\tmov\t"), pprRI ri, comma, pprReg reg2 ]
1687     in  case ri of
1688            RIReg rrr | rrr == reg2 -> empty
1689            other                   -> doit
1690   | otherwise
1691   = pprRegRIReg SLIT("or") b reg1 ri reg2
1692
1693 pprInstr (ORN b reg1 ri reg2) = pprRegRIReg SLIT("orn") b reg1 ri reg2
1694
1695 pprInstr (XOR  b reg1 ri reg2) = pprRegRIReg SLIT("xor")  b reg1 ri reg2
1696 pprInstr (XNOR b reg1 ri reg2) = pprRegRIReg SLIT("xnor") b reg1 ri reg2
1697
1698 pprInstr (SLL reg1 ri reg2) = pprRegRIReg SLIT("sll") False reg1 ri reg2
1699 pprInstr (SRL reg1 ri reg2) = pprRegRIReg SLIT("srl") False reg1 ri reg2
1700 pprInstr (SRA reg1 ri reg2) = pprRegRIReg SLIT("sra") False reg1 ri reg2
1701
1702 pprInstr (RDY rd) = ptext SLIT("\trd\t%y,") <> pprReg rd
1703 pprInstr (SMUL b reg1 ri reg2) = pprRegRIReg SLIT("smul")  b reg1 ri reg2
1704 pprInstr (UMUL b reg1 ri reg2) = pprRegRIReg SLIT("umul")  b reg1 ri reg2
1705
1706 pprInstr (SETHI imm reg)
1707   = hcat [
1708         ptext SLIT("\tsethi\t"),
1709         pprImm imm,
1710         comma,
1711         pprReg reg
1712     ]
1713
1714 pprInstr NOP = ptext SLIT("\tnop")
1715
1716 pprInstr (FABS F reg1 reg2) = pprSizeRegReg SLIT("fabs") F reg1 reg2
1717 pprInstr (FABS DF reg1 reg2)
1718   = (<>) (pprSizeRegReg SLIT("fabs") F reg1 reg2)
1719     (if (reg1 == reg2) then empty
1720      else (<>) (char '\n')
1721           (pprSizeRegReg SLIT("fmov") F (fPair reg1) (fPair reg2)))
1722
1723 pprInstr (FADD size reg1 reg2 reg3)
1724   = pprSizeRegRegReg SLIT("fadd") size reg1 reg2 reg3
1725 pprInstr (FCMP e size reg1 reg2)
1726   = pprSizeRegReg (if e then SLIT("fcmpe") else SLIT("fcmp")) size reg1 reg2
1727 pprInstr (FDIV size reg1 reg2 reg3)
1728   = pprSizeRegRegReg SLIT("fdiv") size reg1 reg2 reg3
1729
1730 pprInstr (FMOV F reg1 reg2) = pprSizeRegReg SLIT("fmov") F reg1 reg2
1731 pprInstr (FMOV DF reg1 reg2)
1732   = (<>) (pprSizeRegReg SLIT("fmov") F reg1 reg2)
1733     (if (reg1 == reg2) then empty
1734      else (<>) (char '\n')
1735           (pprSizeRegReg SLIT("fmov") F (fPair reg1) (fPair reg2)))
1736
1737 pprInstr (FMUL size reg1 reg2 reg3)
1738   = pprSizeRegRegReg SLIT("fmul") size reg1 reg2 reg3
1739
1740 pprInstr (FNEG F reg1 reg2) = pprSizeRegReg SLIT("fneg") F reg1 reg2
1741 pprInstr (FNEG DF reg1 reg2)
1742   = (<>) (pprSizeRegReg SLIT("fneg") F reg1 reg2)
1743     (if (reg1 == reg2) then empty
1744      else (<>) (char '\n')
1745           (pprSizeRegReg SLIT("fmov") F (fPair reg1) (fPair reg2)))
1746
1747 pprInstr (FSQRT size reg1 reg2)     = pprSizeRegReg SLIT("fsqrt") size reg1 reg2
1748 pprInstr (FSUB size reg1 reg2 reg3) = pprSizeRegRegReg SLIT("fsub") size reg1 reg2 reg3
1749 pprInstr (FxTOy size1 size2 reg1 reg2)
1750   = hcat [
1751         ptext SLIT("\tf"),
1752         ptext
1753         (case size1 of
1754             W  -> SLIT("ito")
1755             F  -> SLIT("sto")
1756             DF -> SLIT("dto")),
1757         ptext
1758         (case size2 of
1759             W  -> SLIT("i\t")
1760             F  -> SLIT("s\t")
1761             DF -> SLIT("d\t")),
1762         pprReg reg1, comma, pprReg reg2
1763     ]
1764
1765
1766 pprInstr (BI cond b lab)
1767   = hcat [
1768         ptext SLIT("\tb"), pprCond cond,
1769         if b then pp_comma_a else empty,
1770         char '\t',
1771         pprImm lab
1772     ]
1773
1774 pprInstr (BF cond b lab)
1775   = hcat [
1776         ptext SLIT("\tfb"), pprCond cond,
1777         if b then pp_comma_a else empty,
1778         char '\t',
1779         pprImm lab
1780     ]
1781
1782 pprInstr (JMP dsts addr) = (<>) (ptext SLIT("\tjmp\t")) (pprAddr addr)
1783
1784 pprInstr (CALL (Left imm) n _)
1785   = hcat [ ptext SLIT("\tcall\t"), pprImm imm, comma, int n ]
1786 pprInstr (CALL (Right reg) n _)
1787   = hcat [ ptext SLIT("\tcall\t"), pprReg reg, comma, int n ]
1788 \end{code}
1789
1790 Continue with SPARC-only printing bits and bobs:
1791 \begin{code}
1792 pprRI :: RI -> Doc
1793 pprRI (RIReg r) = pprReg r
1794 pprRI (RIImm r) = pprImm r
1795
1796 pprSizeRegReg :: LitString -> Size -> Reg -> Reg -> Doc
1797 pprSizeRegReg name size reg1 reg2
1798   = hcat [
1799         char '\t',
1800         ptext name,
1801         (case size of
1802             F  -> ptext SLIT("s\t")
1803             DF -> ptext SLIT("d\t")),
1804         pprReg reg1,
1805         comma,
1806         pprReg reg2
1807     ]
1808
1809 pprSizeRegRegReg :: LitString -> Size -> Reg -> Reg -> Reg -> Doc
1810 pprSizeRegRegReg name size reg1 reg2 reg3
1811   = hcat [
1812         char '\t',
1813         ptext name,
1814         (case size of
1815             F  -> ptext SLIT("s\t")
1816             DF -> ptext SLIT("d\t")),
1817         pprReg reg1,
1818         comma,
1819         pprReg reg2,
1820         comma,
1821         pprReg reg3
1822     ]
1823
1824 pprRegRIReg :: LitString -> Bool -> Reg -> RI -> Reg -> Doc
1825 pprRegRIReg name b reg1 ri reg2
1826   = hcat [
1827         char '\t',
1828         ptext name,
1829         if b then ptext SLIT("cc\t") else char '\t',
1830         pprReg reg1,
1831         comma,
1832         pprRI ri,
1833         comma,
1834         pprReg reg2
1835     ]
1836
1837 pprRIReg :: LitString -> Bool -> RI -> Reg -> Doc
1838 pprRIReg name b ri reg1
1839   = hcat [
1840         char '\t',
1841         ptext name,
1842         if b then ptext SLIT("cc\t") else char '\t',
1843         pprRI ri,
1844         comma,
1845         pprReg reg1
1846     ]
1847
1848 pp_ld_lbracket    = ptext SLIT("\tld\t[")
1849 pp_rbracket_comma = text "],"
1850 pp_comma_lbracket = text ",["
1851 pp_comma_a        = text ",a"
1852
1853 #endif /* sparc_TARGET_ARCH */
1854 \end{code}
1855
1856 %************************************************************************
1857 %*                                                                      *
1858 \subsubsection{@pprInstr@ for PowerPC}
1859 %*                                                                      *
1860 %************************************************************************
1861
1862 \begin{code}
1863 #if powerpc_TARGET_ARCH
1864 pprInstr (LD sz reg addr) = hcat [
1865         char '\t',
1866         ptext SLIT("l"),
1867         ptext (case sz of
1868             B   -> SLIT("ba")
1869             Bu  -> SLIT("bz")
1870             H   -> SLIT("ha")
1871             Hu  -> SLIT("hz")
1872             W   -> SLIT("wz")
1873             F   -> SLIT("fs")
1874             DF  -> SLIT("fd")),
1875         char '\t',
1876         pprReg reg,
1877         ptext SLIT(", "),
1878         pprAddr addr
1879     ]
1880 pprInstr (ST sz reg addr) = hcat [
1881         char '\t',
1882         ptext SLIT("st"),
1883         pprSize sz,
1884         char '\t',
1885         pprReg reg,
1886         ptext SLIT(", "),
1887         pprAddr addr
1888     ]
1889 pprInstr (STU sz reg addr) = hcat [
1890         char '\t',
1891         ptext SLIT("st"),
1892         pprSize sz,
1893         ptext SLIT("u\t"),
1894         pprReg reg,
1895         ptext SLIT(", "),
1896         pprAddr addr
1897     ]
1898 pprInstr (LIS reg imm) = hcat [
1899         char '\t',
1900         ptext SLIT("lis"),
1901         char '\t',
1902         pprReg reg,
1903         ptext SLIT(", "),
1904         pprImm imm
1905     ]
1906 pprInstr (LI reg imm) = hcat [
1907         char '\t',
1908         ptext SLIT("li"),
1909         char '\t',
1910         pprReg reg,
1911         ptext SLIT(", "),
1912         pprImm imm
1913     ]
1914 pprInstr (MR reg1 reg2)
1915     | reg1 == reg2 = empty
1916     | otherwise = hcat [
1917         char '\t',
1918         case regClass reg1 of
1919             RcInteger -> ptext SLIT("mr")
1920             _ -> ptext SLIT("fmr"),
1921         char '\t',
1922         pprReg reg1,
1923         ptext SLIT(", "),
1924         pprReg reg2
1925     ]
1926 pprInstr (CMP sz reg ri) = hcat [
1927         char '\t',
1928         op,
1929         char '\t',
1930         pprReg reg,
1931         ptext SLIT(", "),
1932         pprRI ri
1933     ]
1934     where
1935         op = hcat [
1936                 ptext SLIT("cmp"),
1937                 pprSize sz,
1938                 case ri of
1939                     RIReg _ -> empty
1940                     RIImm _ -> char 'i'
1941             ]
1942 pprInstr (CMPL sz reg ri) = hcat [
1943         char '\t',
1944         op,
1945         char '\t',
1946         pprReg reg,
1947         ptext SLIT(", "),
1948         pprRI ri
1949     ]
1950     where
1951         op = hcat [
1952                 ptext SLIT("cmpl"),
1953                 pprSize sz,
1954                 case ri of
1955                     RIReg _ -> empty
1956                     RIImm _ -> char 'i'
1957             ]
1958 pprInstr (BCC cond lbl) = hcat [
1959         char '\t',
1960         ptext SLIT("b"),
1961         pprCond cond,
1962         char '\t',
1963         pprCLabel_asm lbl
1964     ]
1965
1966 pprInstr (MTCTR reg) = hcat [
1967         char '\t',
1968         ptext SLIT("mtctr"),
1969         char '\t',
1970         pprReg reg
1971     ]
1972 pprInstr (BCTR _) = hcat [
1973         char '\t',
1974         ptext SLIT("bctr")
1975     ]
1976 pprInstr (BL imm _) = hcat [
1977         char '\t',
1978         ptext SLIT("bl"),
1979         char '\t',
1980         pprImm imm
1981     ]
1982 pprInstr (BCTRL _) = hcat [
1983         char '\t',
1984         ptext SLIT("bctrl")
1985     ]
1986 pprInstr (ADD reg1 reg2 ri) = pprLogic SLIT("add") reg1 reg2 ri
1987 pprInstr (SUBF reg1 reg2 reg3) = pprLogic SLIT("subf") reg1 reg2 (RIReg reg3)
1988 pprInstr (MULLW reg1 reg2 ri@(RIReg _)) = pprLogic SLIT("mullw") reg1 reg2 ri
1989 pprInstr (MULLW reg1 reg2 ri@(RIImm _)) = pprLogic SLIT("mull") reg1 reg2 ri
1990 pprInstr (DIVW reg1 reg2 reg3) = pprLogic SLIT("divw") reg1 reg2 (RIReg reg3)
1991 pprInstr (DIVWU reg1 reg2 reg3) = pprLogic SLIT("divwu") reg1 reg2 (RIReg reg3)
1992
1993         -- for some reason, "andi" doesn't exist.
1994         -- we'll use "andi." instead.
1995 pprInstr (AND reg1 reg2 (RIImm imm)) = hcat [
1996         char '\t',
1997         ptext SLIT("andi."),
1998         char '\t',
1999         pprReg reg1,
2000         ptext SLIT(", "),
2001         pprReg reg2,
2002         ptext SLIT(", "),
2003         pprImm imm
2004     ]
2005 pprInstr (AND reg1 reg2 ri) = pprLogic SLIT("and") reg1 reg2 (toUI16 ri)
2006
2007 pprInstr (OR reg1 reg2 ri) = pprLogic SLIT("or") reg1 reg2 (toUI16 ri)
2008 pprInstr (XOR reg1 reg2 ri) = pprLogic SLIT("xor") reg1 reg2 (toUI16 ri)
2009
2010 pprInstr (XORIS reg1 reg2 imm) = hcat [
2011         char '\t',
2012         ptext SLIT("xoris"),
2013         char '\t',
2014         pprReg reg1,
2015         ptext SLIT(", "),
2016         pprReg reg2,
2017         ptext SLIT(", "),
2018         pprImm imm
2019     ]
2020
2021 pprInstr (SLW reg1 reg2 ri) = pprLogic SLIT("slw") reg1 reg2 ri
2022 pprInstr (SRW reg1 reg2 ri) = pprLogic SLIT("srw") reg1 reg2 ri
2023 pprInstr (SRAW reg1 reg2 ri) = pprLogic SLIT("sraw") reg1 reg2 ri
2024 pprInstr (NEG reg1 reg2) = pprUnary SLIT("neg") reg1 reg2
2025 pprInstr (NOT reg1 reg2) = pprUnary SLIT("not") reg1 reg2
2026
2027 pprInstr (FADD sz reg1 reg2 reg3) = pprBinaryF SLIT("fadd") sz reg1 reg2 reg3
2028 pprInstr (FSUB sz reg1 reg2 reg3) = pprBinaryF SLIT("fsub") sz reg1 reg2 reg3
2029 pprInstr (FMUL sz reg1 reg2 reg3) = pprBinaryF SLIT("fmul") sz reg1 reg2 reg3
2030 pprInstr (FDIV sz reg1 reg2 reg3) = pprBinaryF SLIT("fdiv") sz reg1 reg2 reg3
2031 pprInstr (FNEG reg1 reg2) = pprUnary SLIT("fneg") reg1 reg2
2032
2033 pprInstr (FCMP reg1 reg2) = hcat [
2034         char '\t',
2035         ptext SLIT("fcmpu\tcr0, "),
2036             -- Note: we're using fcmpu, not fcmpo
2037             -- The difference is with fcmpo, compare with NaN is an invalid operation.
2038             -- We don't handle invalid fp ops, so we don't care
2039         pprReg reg1,
2040         ptext SLIT(", "),
2041         pprReg reg2
2042     ]
2043
2044 pprInstr (FCTIWZ reg1 reg2) = pprUnary SLIT("fctiwz") reg1 reg2
2045
2046 pprInstr _ = ptext SLIT("something")
2047
2048 pprLogic op reg1 reg2 ri = hcat [
2049         char '\t',
2050         ptext op,
2051         case ri of
2052             RIReg _ -> empty
2053             RIImm _ -> char 'i',
2054         char '\t',
2055         pprReg reg1,
2056         ptext SLIT(", "),
2057         pprReg reg2,
2058         ptext SLIT(", "),
2059         pprRI ri
2060     ]
2061
2062 pprUnary op reg1 reg2 = hcat [
2063         char '\t',
2064         ptext op,
2065         char '\t',
2066         pprReg reg1,
2067         ptext SLIT(", "),
2068         pprReg reg2
2069     ]
2070
2071 pprBinaryF op sz reg1 reg2 reg3 = hcat [
2072         char '\t',
2073         ptext op,
2074         pprFSize sz,
2075         char '\t',
2076         pprReg reg1,
2077         ptext SLIT(", "),
2078         pprReg reg2,
2079         ptext SLIT(", "),
2080         pprReg reg3
2081     ]
2082
2083 pprRI :: RI -> Doc
2084 pprRI (RIReg r) = pprReg r
2085 pprRI (RIImm r) = pprImm r
2086
2087 pprFSize DF = empty
2088 pprFSize F = char 's'
2089
2090 -- hack to ensure that negative vals come out in non-negative form
2091 -- (assuming that fromIntegral{Int->Word16} will do a 'c-style'
2092 -- conversion, and not throw a fit/exception.)
2093 toUI16 :: RI -> RI
2094 toUI16 (RIImm (ImmInt x))
2095   | x < 0 = RIImm (ImmInt (fromIntegral ((fromIntegral x) :: Word16)))
2096 toUI16 (RIImm (ImmInteger x))
2097   | x < 0 = RIImm (ImmInt (fromIntegral ((fromIntegral x) :: Word16)))
2098 toUI16 x = x
2099
2100 {-
2101   The Mach-O object file format used in Darwin/Mac OS X needs a so-called
2102   "symbol stub" for every function that might be imported from a dynamic
2103   library.
2104   The stubs are always the same, and they are all output at the end of the
2105   generated assembly (see AsmCodeGen.lhs), so we don't use the Instr datatype.
2106   Instead, we just pretty-print it directly.
2107 -}
2108
2109 #if darwin_TARGET_OS
2110 pprDyldSymbolStub fn =
2111     vcat [
2112         ptext SLIT(".symbol_stub"),
2113         ptext SLIT("L_") <> ftext fn <> ptext SLIT("$stub:"),
2114             ptext SLIT("\t.indirect_symbol _") <> ftext fn,
2115             ptext SLIT("\tlis r11,ha16(L_") <> ftext fn <> ptext SLIT("$lazy_ptr)"),
2116             ptext SLIT("\tlwz r12,lo16(L_") <> ftext fn <> ptext SLIT("$lazy_ptr)(r11)"),
2117             ptext SLIT("\tmtctr r12"),
2118             ptext SLIT("\taddi r11,r11,lo16(L_") <> ftext fn <> ptext SLIT("$lazy_ptr)"),
2119             ptext SLIT("\tbctr"),
2120         ptext SLIT(".lazy_symbol_pointer"),
2121         ptext SLIT("L_") <> ftext fn <> ptext SLIT("$lazy_ptr:"),
2122             ptext SLIT("\t.indirect_symbol _") <> ftext fn,
2123             ptext SLIT("\t.long dyld_stub_binding_helper")
2124     ]
2125 #endif
2126
2127
2128 #endif /* powerpc_TARGET_ARCH */
2129 \end{code}
2130
2131 \begin{code}
2132 #if __GLASGOW_HASKELL__ >= 504
2133 newFloatArray :: (Int,Int) -> ST s (STUArray s Int Float)
2134 newFloatArray = newArray_
2135
2136 newDoubleArray :: (Int,Int) -> ST s (STUArray s Int Double)
2137 newDoubleArray = newArray_
2138
2139 castFloatToCharArray :: STUArray s Int Float -> ST s (STUArray s Int Word8)
2140 castFloatToCharArray = castSTUArray
2141
2142 castDoubleToCharArray :: STUArray s Int Double -> ST s (STUArray s Int Word8)
2143 castDoubleToCharArray = castSTUArray
2144
2145 writeFloatArray :: STUArray s Int Float -> Int -> Float -> ST s ()
2146 writeFloatArray = writeArray
2147
2148 writeDoubleArray :: STUArray s Int Double -> Int -> Double -> ST s ()
2149 writeDoubleArray = writeArray
2150
2151 readCharArray :: STUArray s Int Word8 -> Int -> ST s Char
2152 readCharArray arr i = do
2153   w <- readArray arr i
2154   return $! (chr (fromIntegral w))
2155
2156 #else
2157
2158 castFloatToCharArray :: MutableByteArray s t -> ST s (MutableByteArray s t)
2159 castFloatToCharArray = return
2160
2161 castDoubleToCharArray :: MutableByteArray s t -> ST s (MutableByteArray s t)
2162
2163
2164 castDoubleToCharArray = return
2165
2166 #endif
2167
2168 -- floatToBytes and doubleToBytes convert to the host's byte
2169 -- order.  Providing that we're not cross-compiling for a
2170 -- target with the opposite endianness, this should work ok
2171 -- on all targets.
2172
2173 -- ToDo: this stuff is very similar to the shenanigans in PprAbs,
2174 -- could they be merged?
2175
2176 floatToBytes :: Float -> [Int]
2177 floatToBytes f
2178    = runST (do
2179         arr <- newFloatArray ((0::Int),3)
2180         writeFloatArray arr 0 f
2181         arr <- castFloatToCharArray arr
2182         i0 <- readCharArray arr 0
2183         i1 <- readCharArray arr 1
2184         i2 <- readCharArray arr 2
2185         i3 <- readCharArray arr 3
2186         return (map ord [i0,i1,i2,i3])
2187      )
2188
2189 doubleToBytes :: Double -> [Int]
2190 doubleToBytes d
2191    = runST (do
2192         arr <- newDoubleArray ((0::Int),7)
2193         writeDoubleArray arr 0 d
2194         arr <- castDoubleToCharArray arr
2195         i0 <- readCharArray arr 0
2196         i1 <- readCharArray arr 1
2197         i2 <- readCharArray arr 2
2198         i3 <- readCharArray arr 3
2199         i4 <- readCharArray arr 4
2200         i5 <- readCharArray arr 5
2201         i6 <- readCharArray arr 6
2202         i7 <- readCharArray arr 7
2203         return (map ord [i0,i1,i2,i3,i4,i5,i6,i7])
2204      )
2205 \end{code}