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