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