ghc/compiler/nativeGen/PprMach.hs

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