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