1 -----------------------------------------------------------------------------
3 -- Pretty-printing assembly language
5 -- (c) The University of Glasgow 1993-2004
7 -----------------------------------------------------------------------------
9 -- We start with the @pprXXX@s with some cross-platform commonality
10 -- (e.g., 'pprReg'); we conclude with the no-commonality monster,
13 #include "nativeGen/NCG.h"
16 pprNatCmmTop, pprBasicBlock,
17 pprInstr, pprSize, pprUserReg,
24 #include "HsVersions.h"
27 import MachOp ( MachRep(..) )
28 import MachRegs -- may differ per-platform
31 import CLabel ( CLabel, pprCLabel, externallyVisibleCLabel,
32 labelDynamic, mkAsmTempLabel, entryLblToInfoLbl )
34 import Panic ( panic )
35 import Unique ( pprUnique )
38 import qualified Outputable
40 #if __GLASGOW_HASKELL__ >= 504
42 import Data.Word ( Word8 )
48 import Char ( chr, ord )
50 #if powerpc_TARGET_ARCH
51 import DATA_WORD(Word32)
55 -- -----------------------------------------------------------------------------
56 -- Printing this stuff out
58 asmSDoc d = Outputable.withPprStyleDoc (
59 Outputable.mkCodeStyle Outputable.AsmStyle) d
60 pprCLabel_asm l = asmSDoc (pprCLabel l)
62 pprNatCmmTop :: NatCmmTop -> Doc
63 pprNatCmmTop (CmmData section dats) =
64 pprSectionHeader section $$ vcat (map pprData dats)
66 -- special case for split markers:
67 pprNatCmmTop (CmmProc [] lbl _ []) = pprLabel lbl
69 pprNatCmmTop (CmmProc info lbl params blocks) =
70 pprSectionHeader Text $$
72 then vcat (map pprData info)
73 $$ pprLabel (entryLblToInfoLbl lbl)
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))
84 pprBasicBlock :: NatBasicBlock -> Doc
85 pprBasicBlock (BasicBlock (BlockId id) instrs) =
86 pprLabel (mkAsmTempLabel id) $$
87 vcat (map pprInstr instrs)
89 -- -----------------------------------------------------------------------------
90 -- pprReg: print a 'Reg'
92 -- For x86, the way we print a register name depends
93 -- on which bit of it we care about. Yurgh.
95 pprUserReg :: Reg -> Doc
96 pprUserReg = pprReg IF_ARCH_i386(I32,)
98 pprReg :: IF_ARCH_i386(MachRep ->,) Reg -> Doc
100 pprReg IF_ARCH_i386(s,) r
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)
108 #if alpha_TARGET_ARCH
109 ppr_reg_no :: Int -> Doc
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")
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
153 ppr_reg_byte i = ptext
155 0 -> SLIT("%al"); 1 -> SLIT("%bl");
156 2 -> SLIT("%cl"); 3 -> SLIT("%dl");
157 _ -> SLIT("very naughty I386 byte register")
160 ppr_reg_word i = ptext
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")
169 ppr_reg_long i = ptext
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")
181 #if sparc_TARGET_ARCH
182 ppr_reg_no :: Int -> Doc
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")
220 #if powerpc_TARGET_ARCH
222 ppr_reg_no :: Int -> Doc
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")
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")
268 -- -----------------------------------------------------------------------------
269 -- pprSize: print a 'Size'
271 #if powerpc_TARGET_ARCH || i386_TARGET_ARCH
272 pprSize :: MachRep -> Doc
274 pprSize :: Size -> Doc
277 pprSize x = ptext (case x of
278 #if alpha_TARGET_ARCH
281 -- W -> SLIT("w") UNUSED
282 -- Wu -> SLIT("wu") UNUSED
285 -- FF -> SLIT("f") UNUSED
286 -- DF -> SLIT("d") UNUSED
287 -- GF -> SLIT("g") UNUSED
288 -- SF -> SLIT("s") UNUSED
299 #if sparc_TARGET_ARCH
308 pprStSize :: Size -> Doc
309 pprStSize x = ptext (case x of
318 #if powerpc_TARGET_ARCH
327 -- -----------------------------------------------------------------------------
328 -- pprCond: print a 'Cond'
330 pprCond :: Cond -> Doc
332 pprCond c = ptext (case c of {
333 #if alpha_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
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")
363 #if powerpc_TARGET_ARCH
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");
374 -- -----------------------------------------------------------------------------
375 -- pprImm: print an 'Imm'
379 pprImm (ImmInt i) = int i
380 pprImm (ImmInteger i) = integer i
381 pprImm (ImmCLbl l) = (if labelDynamic l then text "__imp_" else empty)
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
387 pprImm (ImmFloat _) = panic "pprImm:ImmFloat"
388 pprImm (ImmDouble _) = panic "pprImm:ImmDouble"
390 #if sparc_TARGET_ARCH
392 = hcat [ pp_lo, pprImm i, rparen ]
397 = hcat [ pp_hi, pprImm i, rparen ]
401 #if powerpc_TARGET_ARCH
404 = hcat [ pp_lo, pprImm i, rparen ]
409 = hcat [ pp_hi, pprImm i, rparen ]
414 = hcat [ pp_ha, pprImm i, rparen ]
418 pprImm (ImmDyldNonLazyPtr lbl)
419 = ptext SLIT("L") <> pprCLabel_asm lbl <> ptext SLIT("$non_lazy_ptr")
423 = pprImm i <> text "@l"
426 = pprImm i <> text "@h"
429 = pprImm i <> text "@ha"
434 -- -----------------------------------------------------------------------------
435 -- @pprAddr: print an 'AddrMode'
437 pprAddr :: AddrMode -> Doc
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))
449 pprAddr (ImmAddr imm off)
450 = let pp_imm = pprImm imm
454 else if (off < 0) then
457 pp_imm <> char '+' <> int off
459 pprAddr (AddrBaseIndex base index displacement)
461 pp_disp = ppr_disp displacement
462 pp_off p = pp_disp <> char '(' <> p <> char ')'
463 pp_reg r = pprReg I32 r
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
472 ppr_disp (ImmInt 0) = empty
473 ppr_disp imm = pprImm imm
478 #if sparc_TARGET_ARCH
479 pprAddr (AddrRegReg r1 (RealReg 0)) = pprReg r1
481 pprAddr (AddrRegReg r1 r2)
482 = hcat [ pprReg r1, char '+', pprReg r2 ]
484 pprAddr (AddrRegImm r1 (ImmInt i))
486 | not (fits13Bits i) = largeOffsetError i
487 | otherwise = hcat [ pprReg r1, pp_sign, int i ]
489 pp_sign = if i > 0 then char '+' else empty
491 pprAddr (AddrRegImm r1 (ImmInteger i))
493 | not (fits13Bits i) = largeOffsetError i
494 | otherwise = hcat [ pprReg r1, pp_sign, integer i ]
496 pp_sign = if i > 0 then char '+' else empty
498 pprAddr (AddrRegImm r1 imm)
499 = hcat [ pprReg r1, char '+', pprImm imm ]
504 #if powerpc_TARGET_ARCH
505 pprAddr (AddrRegReg r1 r2)
506 = pprReg r1 <+> ptext SLIT(", ") <+> pprReg r2
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 ')' ]
514 -- -----------------------------------------------------------------------------
515 -- pprData: print a 'CmmStatic'
517 pprSectionHeader Text
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")
524 pprSectionHeader Data
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")
531 pprSectionHeader ReadOnlyData
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"))
539 pprSectionHeader UninitialisedData
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"))
547 pprSectionHeader (OtherSection sec)
548 = panic "PprMach.pprSectionHeader: unknown section"
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
557 pprGloblDecl :: CLabel -> Doc
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 ")
567 pprLabel :: CLabel -> Doc
568 pprLabel lbl = pprGloblDecl lbl $$ (pprCLabel_asm lbl <> char ':')
571 -- Assume we want to backslash-convert the string
573 = vcat (map do1 (str ++ [chr 0]))
576 do1 c = ptext SLIT("\t.byte\t0x") <> hshow (ord c)
579 hshow n | n >= 0 && n <= 255
580 = char (tab !! (n `div` 16)) <> char (tab !! (n `mod` 16))
581 tab = "0123456789ABCDEF"
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,))))
591 log2 :: Int -> Int -- cache the common ones
596 log2 n = 1 + log2 (n `quot` 2)
599 pprDataItem :: CmmLit -> Doc
601 = vcat (ppr_item (cmmLitRep lit) lit)
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
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]
621 ppr_item I16 x = [ptext SLIT("\t.word\t") <> pprImm imm]
622 ppr_item I64 x = [ptext SLIT("\t.quad\t") <> pprImm imm]
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")
629 (fromIntegral (x `shiftR` 32) :: Word32)),
630 ptext SLIT("\t.long\t")
631 <> int (fromIntegral (fromIntegral x :: Word32))]
634 -- fall through to rest of (machine-specific) pprInstr...
636 -- -----------------------------------------------------------------------------
637 -- pprInstr: print an 'Instr'
639 pprInstr :: Instr -> Doc
641 --pprInstr (COMMENT s) = empty -- nuke 'em
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))
650 = pprInstr (COMMENT (mkFastString ("\tdelta = " ++ show d)))
652 pprInstr (NEWBLOCK _)
653 = panic "PprMach.pprInstr: NEWBLOCK"
656 = panic "PprMach.pprInstr: LDATA"
658 -- -----------------------------------------------------------------------------
659 -- pprInstr for an Alpha
661 #if alpha_TARGET_ARCH
663 pprInstr (LD size reg addr)
673 pprInstr (LDA reg addr)
675 ptext SLIT("\tlda\t"),
681 pprInstr (LDAH reg addr)
683 ptext SLIT("\tldah\t"),
689 pprInstr (LDGP reg addr)
691 ptext SLIT("\tldgp\t"),
697 pprInstr (LDI size reg imm)
707 pprInstr (ST size reg addr)
719 ptext SLIT("\tclr\t"),
723 pprInstr (ABS size ri reg)
733 pprInstr (NEG size ov ri reg)
737 if ov then ptext SLIT("v\t") else char '\t',
743 pprInstr (ADD size ov reg1 ri reg2)
747 if ov then ptext SLIT("v\t") else char '\t',
755 pprInstr (SADD size scale reg1 ri reg2)
757 ptext (case scale of {{-UNUSED:L -> SLIT("\ts4");-} Q -> SLIT("\ts8")}),
768 pprInstr (SUB size ov reg1 ri reg2)
772 if ov then ptext SLIT("v\t") else char '\t',
780 pprInstr (SSUB size scale reg1 ri reg2)
782 ptext (case scale of {{-UNUSED:L -> SLIT("\ts4");-} Q -> SLIT("\ts8")}),
793 pprInstr (MUL size ov reg1 ri reg2)
797 if ov then ptext SLIT("v\t") else char '\t',
805 pprInstr (DIV size uns reg1 ri reg2)
809 if uns then ptext SLIT("u\t") else char '\t',
817 pprInstr (REM size uns reg1 ri reg2)
821 if uns then ptext SLIT("u\t") else char '\t',
829 pprInstr (NOT ri reg)
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
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
849 pprInstr (ZAP reg1 ri reg2) = pprRegRIReg SLIT("zap") reg1 ri reg2
850 pprInstr (ZAPNOT reg1 ri reg2) = pprRegRIReg SLIT("zapnot") reg1 ri reg2
852 pprInstr (NOP) = ptext SLIT("\tnop")
854 pprInstr (CMP cond reg1 ri reg2)
868 ptext SLIT("\tfclr\t"),
872 pprInstr (FABS reg1 reg2)
874 ptext SLIT("\tfabs\t"),
880 pprInstr (FNEG size reg1 reg2)
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
895 pprInstr (CVTxy size1 size2 reg1 reg2)
899 case size2 of {Q -> ptext SLIT("qc"); _ -> pprSize size2},
906 pprInstr (FCMP size cond reg1 reg2 reg3)
919 pprInstr (FMOV reg1 reg2)
921 ptext SLIT("\tfmov\t"),
927 pprInstr (BI ALWAYS reg lab) = pprInstr (BR lab)
929 pprInstr (BI NEVER reg lab) = empty
931 pprInstr (BI cond reg lab)
941 pprInstr (BF cond reg lab)
952 = (<>) (ptext SLIT("\tbr\t")) (pprImm lab)
954 pprInstr (JMP reg addr hint)
956 ptext SLIT("\tjmp\t"),
965 = (<>) (ptext SLIT("\tbsr\t")) (pprImm imm)
967 pprInstr (JSR reg addr n)
969 ptext SLIT("\tjsr\t"),
975 pprInstr (FUNBEGIN clab)
977 if (externallyVisibleCLabel clab) then
978 hcat [ptext SLIT("\t.globl\t"), pp_lab, char '\n']
981 ptext SLIT("\t.ent "),
990 pp_lab = pprCLabel_asm clab
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") ]
999 pprInstr (FUNEND clab)
1000 = (<>) (ptext SLIT("\t.align 4\n\t.end ")) (pprCLabel_asm clab)
1003 Continue with Alpha-only printing bits and bobs:
1007 pprRI (RIReg r) = pprReg r
1008 pprRI (RIImm r) = pprImm r
1010 pprRegRIReg :: LitString -> Reg -> RI -> Reg -> Doc
1011 pprRegRIReg name reg1 ri reg2
1023 pprSizeRegRegReg :: LitString -> Size -> Reg -> Reg -> Reg -> Doc
1024 pprSizeRegRegReg name size reg1 reg2 reg3
1037 #endif /* alpha_TARGET_ARCH */
1040 -- -----------------------------------------------------------------------------
1041 -- pprInstr for an x86
1043 #if i386_TARGET_ARCH
1045 pprInstr v@(MOV size s@(OpReg src) d@(OpReg dst)) -- hack
1048 #if 0 /* #ifdef DEBUG */
1049 (<>) (ptext SLIT("# warning: ")) (pprSizeOpOp SLIT("mov") size s d)
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
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))
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))
1065 = pprSizeOpOp SLIT("add") size (OpReg reg1) dst
1066 pprInstr (LEA size (OpAddr (AddrBaseIndex src1@(Just reg1) Nothing displ)) dst@(OpReg reg3))
1068 = pprInstr (ADD size (OpImm displ) dst)
1069 pprInstr (LEA size src dst) = pprSizeOpOp SLIT("lea") size src dst
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
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.
1089 pprInstr (MUL size op1 op2) = pprSizeOpOp SLIT("imul") size op1 op2
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
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
1101 pprInstr (BT size imm src) = pprSizeImmOp SLIT("bt") size imm src
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
1108 -- both unused (SDM):
1109 -- pprInstr PUSHA = ptext SLIT("\tpushal")
1110 -- pprInstr POPA = ptext SLIT("\tpopal")
1112 pprInstr NOP = ptext SLIT("\tnop")
1113 pprInstr CLTD = ptext SLIT("\tcltd")
1115 pprInstr (SETCC cond op) = pprCondInstr SLIT("set") cond (pprOperand I8 op)
1117 pprInstr (JXX cond (BlockId id))
1118 = pprCondInstr SLIT("j") cond (pprCLabel_asm lab)
1119 where lab = mkAsmTempLabel id
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)
1127 pprInstr (IDIV sz op) = pprSizeOp SLIT("idiv") sz op
1128 pprInstr (DIV sz op) = pprSizeOp SLIT("div") sz op
1130 pprInstr (IMUL64 sd_hi sd_lo) = pprInstr_imul64 sd_hi sd_lo
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)
1140 = pprG g (hcat [gtab, gpush src 0, gsemi, gpop dst 1])
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])
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])
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])
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 ",
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"])
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.
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.
1181 Here's how the general (non-inequality) case works. As an
1182 example, consider generating the an equality test:
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
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.
1201 The special case of inequality differs thusly:
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)
1209 pprInstr g@(GCMP cond src1 src2)
1210 | case cond of { NE -> True; other -> False }
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"]
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"]
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)
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
1237 -- there should be no others
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])
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])
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.
1264 pprInstr g@(GADD sz src1 src2 dst)
1266 = pprG g (text "\t#GADD-xxxcase1" $$
1267 hcat [gtab, gpush src2 0,
1268 text " ; faddp %st(0),", greg src1 1])
1270 = pprG g (text "\t#GADD-xxxcase2" $$
1271 hcat [gtab, gpush src1 0,
1272 text " ; faddp %st(0),", greg src2 1])
1274 = pprG g (hcat [gtab, gpush src1 0,
1275 text " ; fadd ", greg src2 1, text ",%st(0)",
1279 pprInstr g@(GMUL sz src1 src2 dst)
1281 = pprG g (text "\t#GMUL-xxxcase1" $$
1282 hcat [gtab, gpush src2 0,
1283 text " ; fmulp %st(0),", greg src1 1])
1285 = pprG g (text "\t#GMUL-xxxcase2" $$
1286 hcat [gtab, gpush src1 0,
1287 text " ; fmulp %st(0),", greg src2 1])
1289 = pprG g (hcat [gtab, gpush src1 0,
1290 text " ; fmul ", greg src2 1, text ",%st(0)",
1294 pprInstr g@(GSUB sz src1 src2 dst)
1296 = pprG g (text "\t#GSUB-xxxcase1" $$
1297 hcat [gtab, gpush src2 0,
1298 text " ; fsubrp %st(0),", greg src1 1])
1300 = pprG g (text "\t#GSUB-xxxcase2" $$
1301 hcat [gtab, gpush src1 0,
1302 text " ; fsubp %st(0),", greg src2 1])
1304 = pprG g (hcat [gtab, gpush src1 0,
1305 text " ; fsub ", greg src2 1, text ",%st(0)",
1309 pprInstr g@(GDIV sz src1 src2 dst)
1311 = pprG g (text "\t#GDIV-xxxcase1" $$
1312 hcat [gtab, gpush src2 0,
1313 text " ; fdivrp %st(0),", greg src1 1])
1315 = pprG g (text "\t#GDIV-xxxcase2" $$
1316 hcat [gtab, gpush src1 0,
1317 text " ; fdivp %st(0),", greg src2 1])
1319 = pprG g (hcat [gtab, gpush src1 0,
1320 text " ; fdiv ", greg src2 1, text ",%st(0)",
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)")
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
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
1348 --------------------------
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 ; "
1355 = hcat [text "ffree %st(7) ; fld ", greg reg offset]
1357 = hcat [text "fstp ", greg reg offset]
1359 greg reg offset = text "%st(" <> int (gregno reg - 8+offset) <> char ')'
1364 gregno (RealReg i) = i
1365 gregno other = --pprPanic "gregno" (ppr other)
1366 999 -- bogus; only needed for debug printing
1368 pprG :: Instr -> Doc -> Doc
1370 = (char '#' <> pprGInstr fake) $$ actual
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
1376 pprGInstr (GLDZ dst) = pprSizeReg SLIT("gldz") F64 dst
1377 pprGInstr (GLD1 dst) = pprSizeReg SLIT("gld1") F64 dst
1379 pprGInstr (GFTOI src dst) = pprSizeSizeRegReg SLIT("gftoi") F32 I32 src dst
1380 pprGInstr (GDTOI src dst) = pprSizeSizeRegReg SLIT("gdtoi") F64 I32 src dst
1382 pprGInstr (GITOF src dst) = pprSizeSizeRegReg SLIT("gitof") I32 F32 src dst
1383 pprGInstr (GITOD src dst) = pprSizeSizeRegReg SLIT("gitod") I32 F64 src dst
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
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
1398 -- Continue with I386-only printing bits and bobs:
1400 pprDollImm :: Imm -> Doc
1402 pprDollImm i = ptext SLIT("$") <> pprImm i
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
1409 pprMnemonic :: LitString -> MachRep -> Doc
1410 pprMnemonic name size =
1411 char '\t' <> ptext name <> pprSize size <> space
1413 pprSizeImmOp :: LitString -> MachRep -> Imm -> Operand -> Doc
1414 pprSizeImmOp name size imm op1
1416 pprMnemonic name size,
1423 pprSizeOp :: LitString -> MachRep -> Operand -> Doc
1424 pprSizeOp name size op1
1426 pprMnemonic name size,
1430 pprSizeOpOp :: LitString -> MachRep -> Operand -> Operand -> Doc
1431 pprSizeOpOp name size op1 op2
1433 pprMnemonic name size,
1434 pprOperand size op1,
1439 pprSizeReg :: LitString -> MachRep -> Reg -> Doc
1440 pprSizeReg name size reg1
1442 pprMnemonic name size,
1446 pprSizeRegReg :: LitString -> MachRep -> Reg -> Reg -> Doc
1447 pprSizeRegReg name size reg1 reg2
1449 pprMnemonic name size,
1455 pprCondRegReg :: LitString -> MachRep -> Cond -> Reg -> Reg -> Doc
1456 pprCondRegReg name size cond reg1 reg2
1467 pprSizeSizeRegReg :: LitString -> MachRep -> MachRep -> Reg -> Reg -> Doc
1468 pprSizeSizeRegReg name size1 size2 reg1 reg2
1481 pprSizeRegRegReg :: LitString -> MachRep -> Reg -> Reg -> Reg -> Doc
1482 pprSizeRegRegReg name size reg1 reg2 reg3
1484 pprMnemonic name size,
1492 pprSizeAddrReg :: LitString -> MachRep -> AddrMode -> Reg -> Doc
1493 pprSizeAddrReg name size op dst
1495 pprMnemonic name size,
1501 pprSizeRegAddr :: LitString -> MachRep -> Reg -> AddrMode -> Doc
1502 pprSizeRegAddr name size src op
1504 pprMnemonic name size,
1510 pprShift :: LitString -> MachRep -> Operand -> Operand -> Doc
1511 pprShift name size src dest
1513 pprMnemonic name size,
1514 pprOperand I8 src, -- src is 8-bit sized
1516 pprOperand size dest
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,
1524 pprOperand size2 op2
1527 pprCondInstr :: LitString -> Cond -> Doc -> Doc
1528 pprCondInstr name cond arg
1529 = hcat [ char '\t', ptext name, pprCond cond, space, arg]
1531 #endif /* i386_TARGET_ARCH */
1534 -- ------------------------------------------------------------------------------- pprInstr for a SPARC
1536 #if sparc_TARGET_ARCH
1538 -- a clumsy hack for now, to handle possible double alignment problems
1540 -- even clumsier, to allow for RegReg regs that show when doing indexed
1541 -- reads (bytearrays).
1544 -- Translate to the following:
1547 -- ld [g1+4],%f(n+1)
1548 -- sub g1,g2,g1 -- to restore g1
1549 pprInstr (LD DF (AddrRegReg g1 g2) reg)
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]
1559 -- ld [addr+4],%f(n+1)
1560 pprInstr (LD DF addr reg) | isJust off_addr
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)]
1566 off_addr = addrOffset addr 4
1567 addr2 = case off_addr of Just x -> x
1570 pprInstr (LD size addr reg)
1581 -- The same clumsy hack as above
1583 -- Translate to the following:
1586 -- st %f(n+1),[g1+4]
1587 -- sub g1,g2,g1 -- to restore g1
1588 pprInstr (ST DF reg (AddrRegReg g1 g2))
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,
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]
1600 -- st %f(n+1),[addr+4]
1601 pprInstr (ST DF reg addr) | isJust off_addr
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]
1609 off_addr = addrOffset addr 4
1610 addr2 = case off_addr of Just x -> x
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..
1616 pprInstr (ST size reg addr)
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 ]
1631 = pprRegRIReg (if x then SLIT("addx") else SLIT("add")) cc reg1 ri reg2
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 ]
1639 = pprRegRIReg (if x then SLIT("subx") else SLIT("sub")) cc reg1 ri reg2
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
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 ]
1648 RIReg rrr | rrr == reg2 -> empty
1651 = pprRegRIReg SLIT("or") b reg1 ri reg2
1653 pprInstr (ORN b reg1 ri reg2) = pprRegRIReg SLIT("orn") b reg1 ri reg2
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
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
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
1666 pprInstr (SETHI imm reg)
1668 ptext SLIT("\tsethi\t"),
1674 pprInstr NOP = ptext SLIT("\tnop")
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)))
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
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)))
1697 pprInstr (FMUL size reg1 reg2 reg3)
1698 = pprSizeRegRegReg SLIT("fmul") size reg1 reg2 reg3
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)))
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)
1722 pprReg reg1, comma, pprReg reg2
1726 pprInstr (BI cond b lab)
1728 ptext SLIT("\tb"), pprCond cond,
1729 if b then pp_comma_a else empty,
1734 pprInstr (BF cond b lab)
1736 ptext SLIT("\tfb"), pprCond cond,
1737 if b then pp_comma_a else empty,
1742 pprInstr (JMP dsts addr) = (<>) (ptext SLIT("\tjmp\t")) (pprAddr addr)
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 ]
1750 Continue with SPARC-only printing bits and bobs:
1753 pprRI (RIReg r) = pprReg r
1754 pprRI (RIImm r) = pprImm r
1756 pprSizeRegReg :: LitString -> Size -> Reg -> Reg -> Doc
1757 pprSizeRegReg name size reg1 reg2
1762 F -> ptext SLIT("s\t")
1763 DF -> ptext SLIT("d\t")),
1769 pprSizeRegRegReg :: LitString -> Size -> Reg -> Reg -> Reg -> Doc
1770 pprSizeRegRegReg name size reg1 reg2 reg3
1775 F -> ptext SLIT("s\t")
1776 DF -> ptext SLIT("d\t")),
1784 pprRegRIReg :: LitString -> Bool -> Reg -> RI -> Reg -> Doc
1785 pprRegRIReg name b reg1 ri reg2
1789 if b then ptext SLIT("cc\t") else char '\t',
1797 pprRIReg :: LitString -> Bool -> RI -> Reg -> Doc
1798 pprRIReg name b ri reg1
1802 if b then ptext SLIT("cc\t") else char '\t',
1808 pp_ld_lbracket = ptext SLIT("\tld\t[")
1809 pp_rbracket_comma = text "],"
1810 pp_comma_lbracket = text ",["
1811 pp_comma_a = text ",a"
1813 #endif /* sparc_TARGET_ARCH */
1816 -- -----------------------------------------------------------------------------
1817 -- pprInstr for PowerPC
1819 #if powerpc_TARGET_ARCH
1820 pprInstr (LD sz reg addr) = hcat [
1829 case addr of AddrRegImm _ _ -> empty
1830 AddrRegReg _ _ -> char 'x',
1836 pprInstr (LA sz reg addr) = hcat [
1845 case addr of AddrRegImm _ _ -> empty
1846 AddrRegReg _ _ -> char 'x',
1852 pprInstr (ST sz reg addr) = hcat [
1856 case addr of AddrRegImm _ _ -> empty
1857 AddrRegReg _ _ -> char 'x',
1863 pprInstr (STU sz reg addr) = hcat [
1868 case addr of AddrRegImm _ _ -> empty
1869 AddrRegReg _ _ -> char 'x',
1874 pprInstr (LIS reg imm) = hcat [
1882 pprInstr (LI reg imm) = hcat [
1890 pprInstr (MR reg1 reg2)
1891 | reg1 == reg2 = empty
1892 | otherwise = hcat [
1894 case regClass reg1 of
1895 RcInteger -> ptext SLIT("mr")
1896 _ -> ptext SLIT("fmr"),
1902 pprInstr (CMP sz reg ri) = hcat [
1918 pprInstr (CMPL sz reg ri) = hcat [
1934 pprInstr (BCC cond (BlockId id)) = hcat [
1941 where lbl = mkAsmTempLabel id
1943 pprInstr (JMP lbl) = hcat [ -- an alias for b that takes a CLabel
1950 pprInstr (MTCTR reg) = hcat [
1952 ptext SLIT("mtctr"),
1956 pprInstr (BCTR _) = hcat [
1960 pprInstr (BL lbl _) = hcat [
1961 ptext SLIT("\tbl\tL"),
1965 pprInstr (BCTRL _) = hcat [
1969 pprInstr (ADD reg1 reg2 ri) = pprLogic SLIT("add") reg1 reg2 ri
1970 pprInstr (ADDIS reg1 reg2 imm) = hcat [
1972 ptext SLIT("addis"),
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)
1989 pprInstr (MULLW_MayOflo reg1 reg2 reg3) = vcat [
1990 hcat [ ptext SLIT("\tmullwo\t"), pprReg reg1, ptext SLIT(", "),
1991 pprReg reg2, ptext SLIT(", "),
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") ]
1999 -- for some reason, "andi" doesn't exist.
2000 -- we'll use "andi." instead.
2001 pprInstr (AND reg1 reg2 (RIImm imm)) = hcat [
2003 ptext SLIT("andi."),
2011 pprInstr (AND reg1 reg2 ri) = pprLogic SLIT("and") reg1 reg2 ri
2013 pprInstr (OR reg1 reg2 ri) = pprLogic SLIT("or") reg1 reg2 ri
2014 pprInstr (XOR reg1 reg2 ri) = pprLogic SLIT("xor") reg1 reg2 ri
2016 pprInstr (XORIS reg1 reg2 imm) = hcat [
2018 ptext SLIT("xoris"),
2027 pprInstr (EXTS sz reg1 reg2) = hcat [
2037 pprInstr (NEG reg1 reg2) = pprUnary SLIT("neg") reg1 reg2
2038 pprInstr (NOT reg1 reg2) = pprUnary SLIT("not") reg1 reg2
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"),
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
2062 pprInstr (FCMP reg1 reg2) = hcat [
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
2073 pprInstr (FCTIWZ reg1 reg2) = pprUnary SLIT("fctiwz") reg1 reg2
2074 pprInstr (FRSP reg1 reg2) = pprUnary SLIT("frsp") reg1 reg2
2076 pprInstr (CRNOR dst src1 src2) = hcat [
2077 ptext SLIT("\tcrnor\t"),
2085 pprInstr (MFCR reg) = hcat [
2092 pprInstr _ = panic "pprInstr (ppc)"
2094 pprLogic op reg1 reg2 ri = hcat [
2099 RIImm _ -> char 'i',
2108 pprUnary op reg1 reg2 = hcat [
2117 pprBinaryF op sz reg1 reg2 reg3 = hcat [
2130 pprRI (RIReg r) = pprReg r
2131 pprRI (RIImm r) = pprImm r
2133 pprFSize F64 = empty
2134 pprFSize F32 = char 's'
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)
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
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.
2151 #if darwin_TARGET_OS
2152 pprDyldSymbolStub (True, lbl) =
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")
2167 where pprLbl = pprCLabel_asm lbl
2169 pprDyldSymbolStub (False, lbl) =
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")
2176 where pprLbl = pprCLabel_asm lbl
2179 #endif /* powerpc_TARGET_ARCH */
2182 -- -----------------------------------------------------------------------------
2183 -- Converting floating-point literals to integrals for printing
2185 #if __GLASGOW_HASKELL__ >= 504
2186 newFloatArray :: (Int,Int) -> ST s (STUArray s Int Float)
2187 newFloatArray = newArray_
2189 newDoubleArray :: (Int,Int) -> ST s (STUArray s Int Double)
2190 newDoubleArray = newArray_
2192 castFloatToCharArray :: STUArray s Int Float -> ST s (STUArray s Int Word8)
2193 castFloatToCharArray = castSTUArray
2195 castDoubleToCharArray :: STUArray s Int Double -> ST s (STUArray s Int Word8)
2196 castDoubleToCharArray = castSTUArray
2198 writeFloatArray :: STUArray s Int Float -> Int -> Float -> ST s ()
2199 writeFloatArray = writeArray
2201 writeDoubleArray :: STUArray s Int Double -> Int -> Double -> ST s ()
2202 writeDoubleArray = writeArray
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))
2211 castFloatToCharArray :: MutableByteArray s t -> ST s (MutableByteArray s t)
2212 castFloatToCharArray = return
2214 castDoubleToCharArray :: MutableByteArray s t -> ST s (MutableByteArray s t)
2217 castDoubleToCharArray = return
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
2226 -- ToDo: this stuff is very similar to the shenanigans in PprAbs,
2227 -- could they be merged?
2229 floatToBytes :: Float -> [Int]
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])
2242 doubleToBytes :: Double -> [Int]
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])