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,
21 #include "HsVersions.h"
24 import MachOp ( MachRep(..) )
25 import MachRegs -- may differ per-platform
28 import CLabel ( CLabel, pprCLabel, externallyVisibleCLabel,
29 labelDynamic, mkAsmTempLabel, entryLblToInfoLbl )
30 #if HAVE_SUBSECTIONS_VIA_SYMBOLS
31 import CLabel ( mkDeadStripPreventer )
34 import Panic ( panic )
35 import Unique ( pprUnique )
38 import qualified Outputable
40 import CmdLineOpts ( opt_PIC, opt_Static )
42 #if __GLASGOW_HASKELL__ >= 504
44 import Data.Word ( Word8 )
50 import Char ( chr, ord )
52 #if powerpc_TARGET_ARCH
53 import DATA_WORD(Word32)
57 -- -----------------------------------------------------------------------------
58 -- Printing this stuff out
60 asmSDoc d = Outputable.withPprStyleDoc (
61 Outputable.mkCodeStyle Outputable.AsmStyle) d
62 pprCLabel_asm l = asmSDoc (pprCLabel l)
64 pprNatCmmTop :: NatCmmTop -> Doc
65 pprNatCmmTop (CmmData section dats) =
66 pprSectionHeader section $$ vcat (map pprData dats)
68 -- special case for split markers:
69 pprNatCmmTop (CmmProc [] lbl _ []) = pprLabel lbl
71 pprNatCmmTop (CmmProc info lbl params blocks) =
72 pprSectionHeader Text $$
75 #if HAVE_SUBSECTIONS_VIA_SYMBOLS
76 pprCLabel_asm (mkDeadStripPreventer $ entryLblToInfoLbl lbl)
79 vcat (map pprData info) $$
80 pprLabel (entryLblToInfoLbl lbl)
84 (BasicBlock _ instrs : rest) ->
85 (if null info then pprLabel lbl else empty) $$
86 -- the first block doesn't get a label:
87 vcat (map pprInstr instrs) $$
88 vcat (map pprBasicBlock rest)
90 #if HAVE_SUBSECTIONS_VIA_SYMBOLS
91 -- If we are using the .subsections_via_symbols directive
92 -- (available on recent versions of Darwin),
93 -- we have to make sure that there is some kind of reference
94 -- from the entry code to a label on the _top_ of of the info table,
95 -- so that the linker will not think it is unreferenced and dead-strip
96 -- it. That's why the label is called a DeadStripPreventer (_dsp).
99 <+> pprCLabel_asm (entryLblToInfoLbl lbl)
101 <+> pprCLabel_asm (mkDeadStripPreventer $ entryLblToInfoLbl lbl)
106 pprBasicBlock :: NatBasicBlock -> Doc
107 pprBasicBlock (BasicBlock (BlockId id) instrs) =
108 pprLabel (mkAsmTempLabel id) $$
109 vcat (map pprInstr instrs)
111 -- -----------------------------------------------------------------------------
112 -- pprReg: print a 'Reg'
114 -- For x86, the way we print a register name depends
115 -- on which bit of it we care about. Yurgh.
117 pprUserReg :: Reg -> Doc
118 pprUserReg = pprReg IF_ARCH_i386(I32,)
120 pprReg :: IF_ARCH_i386(MachRep ->,) Reg -> Doc
122 pprReg IF_ARCH_i386(s,) r
124 RealReg i -> ppr_reg_no IF_ARCH_i386(s,) i
125 VirtualRegI u -> text "%vI_" <> asmSDoc (pprUnique u)
126 VirtualRegHi u -> text "%vHi_" <> asmSDoc (pprUnique u)
127 VirtualRegF u -> text "%vF_" <> asmSDoc (pprUnique u)
128 VirtualRegD u -> text "%vD_" <> asmSDoc (pprUnique u)
130 #if alpha_TARGET_ARCH
131 ppr_reg_no :: Int -> Doc
134 0 -> SLIT("$0"); 1 -> SLIT("$1");
135 2 -> SLIT("$2"); 3 -> SLIT("$3");
136 4 -> SLIT("$4"); 5 -> SLIT("$5");
137 6 -> SLIT("$6"); 7 -> SLIT("$7");
138 8 -> SLIT("$8"); 9 -> SLIT("$9");
139 10 -> SLIT("$10"); 11 -> SLIT("$11");
140 12 -> SLIT("$12"); 13 -> SLIT("$13");
141 14 -> SLIT("$14"); 15 -> SLIT("$15");
142 16 -> SLIT("$16"); 17 -> SLIT("$17");
143 18 -> SLIT("$18"); 19 -> SLIT("$19");
144 20 -> SLIT("$20"); 21 -> SLIT("$21");
145 22 -> SLIT("$22"); 23 -> SLIT("$23");
146 24 -> SLIT("$24"); 25 -> SLIT("$25");
147 26 -> SLIT("$26"); 27 -> SLIT("$27");
148 28 -> SLIT("$28"); 29 -> SLIT("$29");
149 30 -> SLIT("$30"); 31 -> SLIT("$31");
150 32 -> SLIT("$f0"); 33 -> SLIT("$f1");
151 34 -> SLIT("$f2"); 35 -> SLIT("$f3");
152 36 -> SLIT("$f4"); 37 -> SLIT("$f5");
153 38 -> SLIT("$f6"); 39 -> SLIT("$f7");
154 40 -> SLIT("$f8"); 41 -> SLIT("$f9");
155 42 -> SLIT("$f10"); 43 -> SLIT("$f11");
156 44 -> SLIT("$f12"); 45 -> SLIT("$f13");
157 46 -> SLIT("$f14"); 47 -> SLIT("$f15");
158 48 -> SLIT("$f16"); 49 -> SLIT("$f17");
159 50 -> SLIT("$f18"); 51 -> SLIT("$f19");
160 52 -> SLIT("$f20"); 53 -> SLIT("$f21");
161 54 -> SLIT("$f22"); 55 -> SLIT("$f23");
162 56 -> SLIT("$f24"); 57 -> SLIT("$f25");
163 58 -> SLIT("$f26"); 59 -> SLIT("$f27");
164 60 -> SLIT("$f28"); 61 -> SLIT("$f29");
165 62 -> SLIT("$f30"); 63 -> SLIT("$f31");
166 _ -> SLIT("very naughty alpha register")
170 ppr_reg_no :: MachRep -> Int -> Doc
171 ppr_reg_no I8 = ppr_reg_byte
172 ppr_reg_no I16 = ppr_reg_word
173 ppr_reg_no _ = ppr_reg_long
175 ppr_reg_byte i = ptext
177 0 -> SLIT("%al"); 1 -> SLIT("%bl");
178 2 -> SLIT("%cl"); 3 -> SLIT("%dl");
179 _ -> SLIT("very naughty I386 byte register")
182 ppr_reg_word i = ptext
184 0 -> SLIT("%ax"); 1 -> SLIT("%bx");
185 2 -> SLIT("%cx"); 3 -> SLIT("%dx");
186 4 -> SLIT("%si"); 5 -> SLIT("%di");
187 6 -> SLIT("%bp"); 7 -> SLIT("%sp");
188 _ -> SLIT("very naughty I386 word register")
191 ppr_reg_long i = ptext
193 0 -> SLIT("%eax"); 1 -> SLIT("%ebx");
194 2 -> SLIT("%ecx"); 3 -> SLIT("%edx");
195 4 -> SLIT("%esi"); 5 -> SLIT("%edi");
196 6 -> SLIT("%ebp"); 7 -> SLIT("%esp");
197 8 -> SLIT("%fake0"); 9 -> SLIT("%fake1");
198 10 -> SLIT("%fake2"); 11 -> SLIT("%fake3");
199 12 -> SLIT("%fake4"); 13 -> SLIT("%fake5");
200 _ -> SLIT("very naughty I386 register")
203 #if sparc_TARGET_ARCH
204 ppr_reg_no :: Int -> Doc
207 0 -> SLIT("%g0"); 1 -> SLIT("%g1");
208 2 -> SLIT("%g2"); 3 -> SLIT("%g3");
209 4 -> SLIT("%g4"); 5 -> SLIT("%g5");
210 6 -> SLIT("%g6"); 7 -> SLIT("%g7");
211 8 -> SLIT("%o0"); 9 -> SLIT("%o1");
212 10 -> SLIT("%o2"); 11 -> SLIT("%o3");
213 12 -> SLIT("%o4"); 13 -> SLIT("%o5");
214 14 -> SLIT("%o6"); 15 -> SLIT("%o7");
215 16 -> SLIT("%l0"); 17 -> SLIT("%l1");
216 18 -> SLIT("%l2"); 19 -> SLIT("%l3");
217 20 -> SLIT("%l4"); 21 -> SLIT("%l5");
218 22 -> SLIT("%l6"); 23 -> SLIT("%l7");
219 24 -> SLIT("%i0"); 25 -> SLIT("%i1");
220 26 -> SLIT("%i2"); 27 -> SLIT("%i3");
221 28 -> SLIT("%i4"); 29 -> SLIT("%i5");
222 30 -> SLIT("%i6"); 31 -> SLIT("%i7");
223 32 -> SLIT("%f0"); 33 -> SLIT("%f1");
224 34 -> SLIT("%f2"); 35 -> SLIT("%f3");
225 36 -> SLIT("%f4"); 37 -> SLIT("%f5");
226 38 -> SLIT("%f6"); 39 -> SLIT("%f7");
227 40 -> SLIT("%f8"); 41 -> SLIT("%f9");
228 42 -> SLIT("%f10"); 43 -> SLIT("%f11");
229 44 -> SLIT("%f12"); 45 -> SLIT("%f13");
230 46 -> SLIT("%f14"); 47 -> SLIT("%f15");
231 48 -> SLIT("%f16"); 49 -> SLIT("%f17");
232 50 -> SLIT("%f18"); 51 -> SLIT("%f19");
233 52 -> SLIT("%f20"); 53 -> SLIT("%f21");
234 54 -> SLIT("%f22"); 55 -> SLIT("%f23");
235 56 -> SLIT("%f24"); 57 -> SLIT("%f25");
236 58 -> SLIT("%f26"); 59 -> SLIT("%f27");
237 60 -> SLIT("%f28"); 61 -> SLIT("%f29");
238 62 -> SLIT("%f30"); 63 -> SLIT("%f31");
239 _ -> SLIT("very naughty sparc register")
242 #if powerpc_TARGET_ARCH
244 ppr_reg_no :: Int -> Doc
247 0 -> SLIT("r0"); 1 -> SLIT("r1");
248 2 -> SLIT("r2"); 3 -> SLIT("r3");
249 4 -> SLIT("r4"); 5 -> SLIT("r5");
250 6 -> SLIT("r6"); 7 -> SLIT("r7");
251 8 -> SLIT("r8"); 9 -> SLIT("r9");
252 10 -> SLIT("r10"); 11 -> SLIT("r11");
253 12 -> SLIT("r12"); 13 -> SLIT("r13");
254 14 -> SLIT("r14"); 15 -> SLIT("r15");
255 16 -> SLIT("r16"); 17 -> SLIT("r17");
256 18 -> SLIT("r18"); 19 -> SLIT("r19");
257 20 -> SLIT("r20"); 21 -> SLIT("r21");
258 22 -> SLIT("r22"); 23 -> SLIT("r23");
259 24 -> SLIT("r24"); 25 -> SLIT("r25");
260 26 -> SLIT("r26"); 27 -> SLIT("r27");
261 28 -> SLIT("r28"); 29 -> SLIT("r29");
262 30 -> SLIT("r30"); 31 -> SLIT("r31");
263 32 -> SLIT("f0"); 33 -> SLIT("f1");
264 34 -> SLIT("f2"); 35 -> SLIT("f3");
265 36 -> SLIT("f4"); 37 -> SLIT("f5");
266 38 -> SLIT("f6"); 39 -> SLIT("f7");
267 40 -> SLIT("f8"); 41 -> SLIT("f9");
268 42 -> SLIT("f10"); 43 -> SLIT("f11");
269 44 -> SLIT("f12"); 45 -> SLIT("f13");
270 46 -> SLIT("f14"); 47 -> SLIT("f15");
271 48 -> SLIT("f16"); 49 -> SLIT("f17");
272 50 -> SLIT("f18"); 51 -> SLIT("f19");
273 52 -> SLIT("f20"); 53 -> SLIT("f21");
274 54 -> SLIT("f22"); 55 -> SLIT("f23");
275 56 -> SLIT("f24"); 57 -> SLIT("f25");
276 58 -> SLIT("f26"); 59 -> SLIT("f27");
277 60 -> SLIT("f28"); 61 -> SLIT("f29");
278 62 -> SLIT("f30"); 63 -> SLIT("f31");
279 _ -> SLIT("very naughty powerpc register")
282 ppr_reg_no :: Int -> Doc
283 ppr_reg_no i | i <= 31 = int i -- GPRs
284 | i <= 63 = int (i-32) -- FPRs
285 | otherwise = ptext SLIT("very naughty powerpc register")
290 -- -----------------------------------------------------------------------------
291 -- pprSize: print a 'Size'
293 #if powerpc_TARGET_ARCH || i386_TARGET_ARCH
294 pprSize :: MachRep -> Doc
296 pprSize :: Size -> Doc
299 pprSize x = ptext (case x of
300 #if alpha_TARGET_ARCH
303 -- W -> SLIT("w") UNUSED
304 -- Wu -> SLIT("wu") UNUSED
307 -- FF -> SLIT("f") UNUSED
308 -- DF -> SLIT("d") UNUSED
309 -- GF -> SLIT("g") UNUSED
310 -- SF -> SLIT("s") UNUSED
321 #if sparc_TARGET_ARCH
330 pprStSize :: Size -> Doc
331 pprStSize x = ptext (case x of
340 #if powerpc_TARGET_ARCH
349 -- -----------------------------------------------------------------------------
350 -- pprCond: print a 'Cond'
352 pprCond :: Cond -> Doc
354 pprCond c = ptext (case c of {
355 #if alpha_TARGET_ARCH
366 GEU -> SLIT("ae"); LU -> SLIT("b");
367 EQQ -> SLIT("e"); GTT -> SLIT("g");
368 GE -> SLIT("ge"); GU -> SLIT("a");
369 LTT -> SLIT("l"); LE -> SLIT("le");
370 LEU -> SLIT("be"); NE -> SLIT("ne");
371 NEG -> SLIT("s"); POS -> SLIT("ns");
372 CARRY -> SLIT("c"); OFLO -> SLIT("o");
373 ALWAYS -> SLIT("mp") -- hack
375 #if sparc_TARGET_ARCH
376 ALWAYS -> SLIT(""); NEVER -> SLIT("n");
377 GEU -> SLIT("geu"); LU -> SLIT("lu");
378 EQQ -> SLIT("e"); GTT -> SLIT("g");
379 GE -> SLIT("ge"); GU -> SLIT("gu");
380 LTT -> SLIT("l"); LE -> SLIT("le");
381 LEU -> SLIT("leu"); NE -> SLIT("ne");
382 NEG -> SLIT("neg"); POS -> SLIT("pos");
383 VC -> SLIT("vc"); VS -> SLIT("vs")
385 #if powerpc_TARGET_ARCH
387 EQQ -> SLIT("eq"); NE -> SLIT("ne");
388 LTT -> SLIT("lt"); GE -> SLIT("ge");
389 GTT -> SLIT("gt"); LE -> SLIT("le");
390 LU -> SLIT("lt"); GEU -> SLIT("ge");
391 GU -> SLIT("gt"); LEU -> SLIT("le");
396 -- -----------------------------------------------------------------------------
397 -- pprImm: print an 'Imm'
401 pprImm (ImmInt i) = int i
402 pprImm (ImmInteger i) = integer i
403 pprImm (ImmCLbl l) = pprCLabel_asm l
404 pprImm (ImmIndex l i) = pprCLabel_asm l <> char '+' <> int i
405 pprImm (ImmLit s) = s
407 pprImm (ImmFloat _) = panic "pprImm:ImmFloat"
408 pprImm (ImmDouble _) = panic "pprImm:ImmDouble"
410 pprImm (ImmConstantSum a b) = pprImm a <> char '+' <> pprImm b
411 pprImm (ImmConstantDiff a b) = pprImm a <> char '-'
412 <> lparen <> pprImm b <> rparen
414 #if sparc_TARGET_ARCH
416 = hcat [ pp_lo, pprImm i, rparen ]
421 = hcat [ pp_hi, pprImm i, rparen ]
425 #if powerpc_TARGET_ARCH
428 = hcat [ pp_lo, pprImm i, rparen ]
433 = hcat [ pp_hi, pprImm i, rparen ]
438 = hcat [ pp_ha, pprImm i, rparen ]
444 = pprImm i <> text "@l"
447 = pprImm i <> text "@h"
450 = pprImm i <> text "@ha"
455 -- -----------------------------------------------------------------------------
456 -- @pprAddr: print an 'AddrMode'
458 pprAddr :: AddrMode -> Doc
460 #if alpha_TARGET_ARCH
461 pprAddr (AddrReg r) = parens (pprReg r)
462 pprAddr (AddrImm i) = pprImm i
463 pprAddr (AddrRegImm r1 i)
464 = (<>) (pprImm i) (parens (pprReg r1))
470 pprAddr (ImmAddr imm off)
471 = let pp_imm = pprImm imm
475 else if (off < 0) then
478 pp_imm <> char '+' <> int off
480 pprAddr (AddrBaseIndex base index displacement)
482 pp_disp = ppr_disp displacement
483 pp_off p = pp_disp <> char '(' <> p <> char ')'
484 pp_reg r = pprReg I32 r
487 (Nothing, Nothing) -> pp_disp
488 (Just b, Nothing) -> pp_off (pp_reg b)
489 (Nothing, Just (r,i)) -> pp_off (comma <> pp_reg r <> comma <> int i)
490 (Just b, Just (r,i)) -> pp_off (pp_reg b <> comma <> pp_reg r
493 ppr_disp (ImmInt 0) = empty
494 ppr_disp imm = pprImm imm
499 #if sparc_TARGET_ARCH
500 pprAddr (AddrRegReg r1 (RealReg 0)) = pprReg r1
502 pprAddr (AddrRegReg r1 r2)
503 = hcat [ pprReg r1, char '+', pprReg r2 ]
505 pprAddr (AddrRegImm r1 (ImmInt i))
507 | not (fits13Bits i) = largeOffsetError i
508 | otherwise = hcat [ pprReg r1, pp_sign, int i ]
510 pp_sign = if i > 0 then char '+' else empty
512 pprAddr (AddrRegImm r1 (ImmInteger i))
514 | not (fits13Bits i) = largeOffsetError i
515 | otherwise = hcat [ pprReg r1, pp_sign, integer i ]
517 pp_sign = if i > 0 then char '+' else empty
519 pprAddr (AddrRegImm r1 imm)
520 = hcat [ pprReg r1, char '+', pprImm imm ]
525 #if powerpc_TARGET_ARCH
526 pprAddr (AddrRegReg r1 r2)
527 = pprReg r1 <+> ptext SLIT(", ") <+> pprReg r2
529 pprAddr (AddrRegImm r1 (ImmInt i)) = hcat [ int i, char '(', pprReg r1, char ')' ]
530 pprAddr (AddrRegImm r1 (ImmInteger i)) = hcat [ integer i, char '(', pprReg r1, char ')' ]
531 pprAddr (AddrRegImm r1 imm) = hcat [ pprImm imm, char '(', pprReg r1, char ')' ]
535 -- -----------------------------------------------------------------------------
536 -- pprData: print a 'CmmStatic'
538 #if defined(linux_TARGET_OS)
539 #if defined(powerpc_TARGET_ARCH) || defined(i386_TARGET_ARCH)
540 -- Hack to make dynamic linking work
541 pprSectionHeader ReadOnlyData
542 | not opt_PIC && not opt_Static
543 = pprSectionHeader Data
547 pprSectionHeader Text
549 IF_ARCH_alpha(SLIT("\t.text\n\t.align 3") {-word boundary-}
550 ,IF_ARCH_sparc(SLIT(".text\n\t.align 4") {-word boundary-}
551 ,IF_ARCH_i386(SLIT(".text\n\t.align 4,0x90") {-needs per-OS variation!-}
552 ,IF_ARCH_powerpc(SLIT(".text\n.align 2")
554 pprSectionHeader Data
556 IF_ARCH_alpha(SLIT("\t.data\n\t.align 3")
557 ,IF_ARCH_sparc(SLIT(".data\n\t.align 8") {-<8 will break double constants -}
558 ,IF_ARCH_i386(SLIT(".data\n\t.align 4")
559 ,IF_ARCH_powerpc(SLIT(".data\n.align 2")
561 pprSectionHeader ReadOnlyData
563 IF_ARCH_alpha(SLIT("\t.data\n\t.align 3")
564 ,IF_ARCH_sparc(SLIT(".data\n\t.align 8") {-<8 will break double constants -}
565 ,IF_ARCH_i386(SLIT(".section .rodata\n\t.align 4")
566 ,IF_ARCH_powerpc(IF_OS_darwin(SLIT(".const_data\n.align 2"),
567 SLIT(".section .rodata\n\t.align 2"))
569 pprSectionHeader UninitialisedData
571 IF_ARCH_alpha(SLIT("\t.bss\n\t.align 3")
572 ,IF_ARCH_sparc(SLIT(".bss\n\t.align 8") {-<8 will break double constants -}
573 ,IF_ARCH_i386(SLIT(".section .bss\n\t.align 4")
574 ,IF_ARCH_powerpc(IF_OS_darwin(SLIT(".const_data\n.align 2"),
575 SLIT(".section .bss\n\t.align 2"))
577 pprSectionHeader (OtherSection sec)
578 = panic "PprMach.pprSectionHeader: unknown section"
580 pprData :: CmmStatic -> Doc
581 pprData (CmmAlign bytes) = pprAlign bytes
582 pprData (CmmDataLabel lbl) = pprLabel lbl
583 pprData (CmmString str) = pprASCII str
584 pprData (CmmUninitialised bytes) = ptext SLIT(".space ") <> int bytes
585 pprData (CmmStaticLit lit) = pprDataItem lit
587 pprGloblDecl :: CLabel -> Doc
589 | not (externallyVisibleCLabel lbl) = empty
590 | otherwise = ptext IF_ARCH_alpha(SLIT(".globl ")
591 ,IF_ARCH_i386(SLIT(".globl ")
592 ,IF_ARCH_sparc(SLIT(".global ")
593 ,IF_ARCH_powerpc(SLIT(".globl ")
597 pprLabel :: CLabel -> Doc
598 pprLabel lbl = pprGloblDecl lbl $$ (pprCLabel_asm lbl <> char ':')
601 -- Assume we want to backslash-convert the string
603 = vcat (map do1 (str ++ [chr 0]))
606 do1 c = ptext SLIT("\t.byte\t0x") <> hshow (ord c)
609 hshow n | n >= 0 && n <= 255
610 = char (tab !! (n `div` 16)) <> char (tab !! (n `mod` 16))
611 tab = "0123456789ABCDEF"
614 IF_ARCH_alpha(ptextSLIT(".align ") <> int pow2,
615 IF_ARCH_i386(ptext SLIT(".align ") <> int bytes,
616 IF_ARCH_sparc(ptext SLIT(".align ") <> int bytes,
617 IF_ARCH_powerpc(ptext SLIT(".align ") <> int pow2,))))
621 log2 :: Int -> Int -- cache the common ones
626 log2 n = 1 + log2 (n `quot` 2)
629 pprDataItem :: CmmLit -> Doc
631 = vcat (ppr_item (cmmLitRep lit) lit)
635 -- These seem to be common:
636 ppr_item I8 x = [ptext SLIT("\t.byte\t") <> pprImm imm]
637 ppr_item I32 x = [ptext SLIT("\t.long\t") <> pprImm imm]
638 ppr_item F32 (CmmFloat r _)
639 = let bs = floatToBytes (fromRational r)
640 in map (\b -> ptext SLIT("\t.byte\t") <> pprImm (ImmInt b)) bs
641 ppr_item F64 (CmmFloat r _)
642 = let bs = doubleToBytes (fromRational r)
643 in map (\b -> ptext SLIT("\t.byte\t") <> pprImm (ImmInt b)) bs
645 #if sparc_TARGET_ARCH
646 -- copy n paste of x86 version
647 ppr_item I16 x = [ptext SLIT("\t.short\t") <> pprImm imm]
648 ppr_item I64 x = [ptext SLIT("\t.quad\t") <> pprImm imm]
651 ppr_item I16 x = [ptext SLIT("\t.word\t") <> pprImm imm]
652 ppr_item I64 x = [ptext SLIT("\t.quad\t") <> pprImm imm]
654 #if powerpc_TARGET_ARCH
655 ppr_item I16 x = [ptext SLIT("\t.short\t") <> pprImm imm]
656 ppr_item I64 (CmmInt x _) =
657 [ptext SLIT("\t.long\t")
659 (fromIntegral (x `shiftR` 32) :: Word32)),
660 ptext SLIT("\t.long\t")
661 <> int (fromIntegral (fromIntegral x :: Word32))]
664 -- fall through to rest of (machine-specific) pprInstr...
666 -- -----------------------------------------------------------------------------
667 -- pprInstr: print an 'Instr'
669 pprInstr :: Instr -> Doc
671 --pprInstr (COMMENT s) = empty -- nuke 'em
673 = IF_ARCH_alpha( ((<>) (ptext SLIT("\t# ")) (ftext s))
674 ,IF_ARCH_sparc( ((<>) (ptext SLIT("! ")) (ftext s))
675 ,IF_ARCH_i386( ((<>) (ptext SLIT("# ")) (ftext s))
676 ,IF_ARCH_powerpc( IF_OS_linux(
677 ((<>) (ptext SLIT("# ")) (ftext s)),
678 ((<>) (ptext SLIT("; ")) (ftext s)))
682 = pprInstr (COMMENT (mkFastString ("\tdelta = " ++ show d)))
684 pprInstr (NEWBLOCK _)
685 = panic "PprMach.pprInstr: NEWBLOCK"
688 = panic "PprMach.pprInstr: LDATA"
690 -- -----------------------------------------------------------------------------
691 -- pprInstr for an Alpha
693 #if alpha_TARGET_ARCH
695 pprInstr (LD size reg addr)
705 pprInstr (LDA reg addr)
707 ptext SLIT("\tlda\t"),
713 pprInstr (LDAH reg addr)
715 ptext SLIT("\tldah\t"),
721 pprInstr (LDGP reg addr)
723 ptext SLIT("\tldgp\t"),
729 pprInstr (LDI size reg imm)
739 pprInstr (ST size reg addr)
751 ptext SLIT("\tclr\t"),
755 pprInstr (ABS size ri reg)
765 pprInstr (NEG size ov ri reg)
769 if ov then ptext SLIT("v\t") else char '\t',
775 pprInstr (ADD size ov reg1 ri reg2)
779 if ov then ptext SLIT("v\t") else char '\t',
787 pprInstr (SADD size scale reg1 ri reg2)
789 ptext (case scale of {{-UNUSED:L -> SLIT("\ts4");-} Q -> SLIT("\ts8")}),
800 pprInstr (SUB size ov reg1 ri reg2)
804 if ov then ptext SLIT("v\t") else char '\t',
812 pprInstr (SSUB size scale reg1 ri reg2)
814 ptext (case scale of {{-UNUSED:L -> SLIT("\ts4");-} Q -> SLIT("\ts8")}),
825 pprInstr (MUL size ov reg1 ri reg2)
829 if ov then ptext SLIT("v\t") else char '\t',
837 pprInstr (DIV size uns reg1 ri reg2)
841 if uns then ptext SLIT("u\t") else char '\t',
849 pprInstr (REM size uns reg1 ri reg2)
853 if uns then ptext SLIT("u\t") else char '\t',
861 pprInstr (NOT ri reg)
870 pprInstr (AND reg1 ri reg2) = pprRegRIReg SLIT("and") reg1 ri reg2
871 pprInstr (ANDNOT reg1 ri reg2) = pprRegRIReg SLIT("andnot") reg1 ri reg2
872 pprInstr (OR reg1 ri reg2) = pprRegRIReg SLIT("or") reg1 ri reg2
873 pprInstr (ORNOT reg1 ri reg2) = pprRegRIReg SLIT("ornot") reg1 ri reg2
874 pprInstr (XOR reg1 ri reg2) = pprRegRIReg SLIT("xor") reg1 ri reg2
875 pprInstr (XORNOT reg1 ri reg2) = pprRegRIReg SLIT("xornot") reg1 ri reg2
877 pprInstr (SLL reg1 ri reg2) = pprRegRIReg SLIT("sll") reg1 ri reg2
878 pprInstr (SRL reg1 ri reg2) = pprRegRIReg SLIT("srl") reg1 ri reg2
879 pprInstr (SRA reg1 ri reg2) = pprRegRIReg SLIT("sra") reg1 ri reg2
881 pprInstr (ZAP reg1 ri reg2) = pprRegRIReg SLIT("zap") reg1 ri reg2
882 pprInstr (ZAPNOT reg1 ri reg2) = pprRegRIReg SLIT("zapnot") reg1 ri reg2
884 pprInstr (NOP) = ptext SLIT("\tnop")
886 pprInstr (CMP cond reg1 ri reg2)
900 ptext SLIT("\tfclr\t"),
904 pprInstr (FABS reg1 reg2)
906 ptext SLIT("\tfabs\t"),
912 pprInstr (FNEG size reg1 reg2)
922 pprInstr (FADD size reg1 reg2 reg3) = pprSizeRegRegReg SLIT("add") size reg1 reg2 reg3
923 pprInstr (FDIV size reg1 reg2 reg3) = pprSizeRegRegReg SLIT("div") size reg1 reg2 reg3
924 pprInstr (FMUL size reg1 reg2 reg3) = pprSizeRegRegReg SLIT("mul") size reg1 reg2 reg3
925 pprInstr (FSUB size reg1 reg2 reg3) = pprSizeRegRegReg SLIT("sub") size reg1 reg2 reg3
927 pprInstr (CVTxy size1 size2 reg1 reg2)
931 case size2 of {Q -> ptext SLIT("qc"); _ -> pprSize size2},
938 pprInstr (FCMP size cond reg1 reg2 reg3)
951 pprInstr (FMOV reg1 reg2)
953 ptext SLIT("\tfmov\t"),
959 pprInstr (BI ALWAYS reg lab) = pprInstr (BR lab)
961 pprInstr (BI NEVER reg lab) = empty
963 pprInstr (BI cond reg lab)
973 pprInstr (BF cond reg lab)
984 = (<>) (ptext SLIT("\tbr\t")) (pprImm lab)
986 pprInstr (JMP reg addr hint)
988 ptext SLIT("\tjmp\t"),
997 = (<>) (ptext SLIT("\tbsr\t")) (pprImm imm)
999 pprInstr (JSR reg addr n)
1001 ptext SLIT("\tjsr\t"),
1007 pprInstr (FUNBEGIN clab)
1009 if (externallyVisibleCLabel clab) then
1010 hcat [ptext SLIT("\t.globl\t"), pp_lab, char '\n']
1013 ptext SLIT("\t.ent "),
1022 pp_lab = pprCLabel_asm clab
1024 -- NEVER use commas within those string literals, cpp will ruin your day
1025 pp_ldgp = hcat [ ptext SLIT(":\n\tldgp $29"), char ',', ptext SLIT("0($27)\n") ]
1026 pp_frame = hcat [ ptext SLIT("..ng:\n\t.frame $30"), char ',',
1027 ptext SLIT("4240"), char ',',
1028 ptext SLIT("$26"), char ',',
1029 ptext SLIT("0\n\t.prologue 1") ]
1031 pprInstr (FUNEND clab)
1032 = (<>) (ptext SLIT("\t.align 4\n\t.end ")) (pprCLabel_asm clab)
1035 Continue with Alpha-only printing bits and bobs:
1039 pprRI (RIReg r) = pprReg r
1040 pprRI (RIImm r) = pprImm r
1042 pprRegRIReg :: LitString -> Reg -> RI -> Reg -> Doc
1043 pprRegRIReg name reg1 ri reg2
1055 pprSizeRegRegReg :: LitString -> Size -> Reg -> Reg -> Reg -> Doc
1056 pprSizeRegRegReg name size reg1 reg2 reg3
1069 #endif /* alpha_TARGET_ARCH */
1072 -- -----------------------------------------------------------------------------
1073 -- pprInstr for an x86
1075 #if i386_TARGET_ARCH
1077 pprInstr v@(MOV size s@(OpReg src) d@(OpReg dst)) -- hack
1080 #if 0 /* #ifdef DEBUG */
1081 (<>) (ptext SLIT("# warning: ")) (pprSizeOpOp SLIT("mov") size s d)
1085 pprInstr (MOV size src dst)
1086 = pprSizeOpOp SLIT("mov") size src dst
1087 pprInstr (MOVZxL sizes src dst) = pprSizeOpOpCoerce SLIT("movz") sizes I32 src dst
1088 pprInstr (MOVSxL sizes src dst) = pprSizeOpOpCoerce SLIT("movs") sizes I32 src dst
1090 -- here we do some patching, since the physical registers are only set late
1091 -- in the code generation.
1092 pprInstr (LEA size (OpAddr (AddrBaseIndex src1@(Just reg1) (Just (reg2,1)) (ImmInt 0))) dst@(OpReg reg3))
1094 = pprSizeOpOp SLIT("add") size (OpReg reg2) dst
1095 pprInstr (LEA size (OpAddr (AddrBaseIndex src1@(Just reg1) (Just (reg2,1)) (ImmInt 0))) dst@(OpReg reg3))
1097 = pprSizeOpOp SLIT("add") size (OpReg reg1) dst
1098 pprInstr (LEA size (OpAddr (AddrBaseIndex src1@(Just reg1) Nothing displ)) dst@(OpReg reg3))
1100 = pprInstr (ADD size (OpImm displ) dst)
1101 pprInstr (LEA size src dst) = pprSizeOpOp SLIT("lea") size src dst
1103 pprInstr (ADD size (OpImm (ImmInt (-1))) dst)
1104 = pprSizeOp SLIT("dec") size dst
1105 pprInstr (ADD size (OpImm (ImmInt 1)) dst)
1106 = pprSizeOp SLIT("inc") size dst
1107 pprInstr (ADD size src dst)
1108 = pprSizeOpOp SLIT("add") size src dst
1109 pprInstr (ADC size src dst)
1110 = pprSizeOpOp SLIT("adc") size src dst
1111 pprInstr (SUB size src dst) = pprSizeOpOp SLIT("sub") size src dst
1112 pprInstr (IMUL size op1 op2) = pprSizeOpOp SLIT("imul") size op1 op2
1114 {- A hack. The Intel documentation says that "The two and three
1115 operand forms [of IMUL] may also be used with unsigned operands
1116 because the lower half of the product is the same regardless if
1117 (sic) the operands are signed or unsigned. The CF and OF flags,
1118 however, cannot be used to determine if the upper half of the
1119 result is non-zero." So there.
1121 pprInstr (MUL size op1 op2) = pprSizeOpOp SLIT("imul") size op1 op2
1123 pprInstr (AND size src dst) = pprSizeOpOp SLIT("and") size src dst
1124 pprInstr (OR size src dst) = pprSizeOpOp SLIT("or") size src dst
1125 pprInstr (XOR size src dst) = pprSizeOpOp SLIT("xor") size src dst
1126 pprInstr (NOT size op) = pprSizeOp SLIT("not") size op
1127 pprInstr (NEGI size op) = pprSizeOp SLIT("neg") size op
1129 pprInstr (SHL size src dst) = pprShift SLIT("shl") size src dst
1130 pprInstr (SAR size src dst) = pprShift SLIT("sar") size src dst
1131 pprInstr (SHR size src dst) = pprShift SLIT("shr") size src dst
1133 pprInstr (BT size imm src) = pprSizeImmOp SLIT("bt") size imm src
1135 pprInstr (CMP size src dst) = pprSizeOpOp SLIT("cmp") size src dst
1136 pprInstr (TEST size src dst) = pprSizeOpOp SLIT("test") size src dst
1137 pprInstr (PUSH size op) = pprSizeOp SLIT("push") size op
1138 pprInstr (POP size op) = pprSizeOp SLIT("pop") size op
1140 -- both unused (SDM):
1141 -- pprInstr PUSHA = ptext SLIT("\tpushal")
1142 -- pprInstr POPA = ptext SLIT("\tpopal")
1144 pprInstr NOP = ptext SLIT("\tnop")
1145 pprInstr CLTD = ptext SLIT("\tcltd")
1147 pprInstr (SETCC cond op) = pprCondInstr SLIT("set") cond (pprOperand I8 op)
1149 pprInstr (JXX cond (BlockId id))
1150 = pprCondInstr SLIT("j") cond (pprCLabel_asm lab)
1151 where lab = mkAsmTempLabel id
1153 pprInstr (JMP (OpImm imm)) = (<>) (ptext SLIT("\tjmp ")) (pprImm imm)
1154 pprInstr (JMP op) = (<>) (ptext SLIT("\tjmp *")) (pprOperand I32 op)
1155 pprInstr (JMP_TBL op ids) = pprInstr (JMP op)
1156 pprInstr (CALL (Left imm)) = (<>) (ptext SLIT("\tcall ")) (pprImm imm)
1157 pprInstr (CALL (Right reg)) = (<>) (ptext SLIT("\tcall *")) (pprReg I32 reg)
1159 pprInstr (IDIV sz op) = pprSizeOp SLIT("idiv") sz op
1160 pprInstr (DIV sz op) = pprSizeOp SLIT("div") sz op
1162 pprInstr (IMUL64 sd_hi sd_lo) = pprInstr_imul64 sd_hi sd_lo
1165 -- Simulating a flat register set on the x86 FP stack is tricky.
1166 -- you have to free %st(7) before pushing anything on the FP reg stack
1167 -- so as to preclude the possibility of a FP stack overflow exception.
1168 pprInstr g@(GMOV src dst)
1172 = pprG g (hcat [gtab, gpush src 0, gsemi, gpop dst 1])
1174 -- GLD sz addr dst ==> FFREE %st(7) ; FLDsz addr ; FSTP (dst+1)
1175 pprInstr g@(GLD sz addr dst)
1176 = pprG g (hcat [gtab, text "ffree %st(7) ; fld", pprSize sz, gsp,
1177 pprAddr addr, gsemi, gpop dst 1])
1179 -- GST sz src addr ==> FFREE %st(7) ; FLD dst ; FSTPsz addr
1180 pprInstr g@(GST sz src addr)
1181 = pprG g (hcat [gtab, gpush src 0, gsemi,
1182 text "fstp", pprSize sz, gsp, pprAddr addr])
1184 pprInstr g@(GLDZ dst)
1185 = pprG g (hcat [gtab, text "ffree %st(7) ; fldz ; ", gpop dst 1])
1186 pprInstr g@(GLD1 dst)
1187 = pprG g (hcat [gtab, text "ffree %st(7) ; fld1 ; ", gpop dst 1])
1189 pprInstr g@(GFTOI src dst)
1190 = pprInstr (GDTOI src dst)
1191 pprInstr g@(GDTOI src dst)
1192 = pprG g (hcat [gtab, text "subl $4, %esp ; ",
1193 gpush src 0, gsemi, text "fistpl 0(%esp) ; popl ",
1196 pprInstr g@(GITOF src dst)
1197 = pprInstr (GITOD src dst)
1198 pprInstr g@(GITOD src dst)
1199 = pprG g (hcat [gtab, text "pushl ", pprReg I32 src,
1200 text " ; ffree %st(7); fildl (%esp) ; ",
1201 gpop dst 1, text " ; addl $4,%esp"])
1203 {- Gruesome swamp follows. If you're unfortunate enough to have ventured
1204 this far into the jungle AND you give a Rat's Ass (tm) what's going
1205 on, here's the deal. Generate code to do a floating point comparison
1206 of src1 and src2, of kind cond, and set the Zero flag if true.
1208 The complications are to do with handling NaNs correctly. We want the
1209 property that if either argument is NaN, then the result of the
1210 comparison is False ... except if we're comparing for inequality,
1211 in which case the answer is True.
1213 Here's how the general (non-inequality) case works. As an
1214 example, consider generating the an equality test:
1216 pushl %eax -- we need to mess with this
1217 <get src1 to top of FPU stack>
1218 fcomp <src2 location in FPU stack> and pop pushed src1
1219 -- Result of comparison is in FPU Status Register bits
1221 fstsw %ax -- Move FPU Status Reg to %ax
1222 sahf -- move C3 C2 C0 from %ax to integer flag reg
1223 -- now the serious magic begins
1224 setpo %ah -- %ah = if comparable(neither arg was NaN) then 1 else 0
1225 sete %al -- %al = if arg1 == arg2 then 1 else 0
1226 andb %ah,%al -- %al &= %ah
1227 -- so %al == 1 iff (comparable && same); else it holds 0
1228 decb %al -- %al == 0, ZeroFlag=1 iff (comparable && same);
1229 else %al == 0xFF, ZeroFlag=0
1230 -- the zero flag is now set as we desire.
1233 The special case of inequality differs thusly:
1235 setpe %ah -- %ah = if incomparable(either arg was NaN) then 1 else 0
1236 setne %al -- %al = if arg1 /= arg2 then 1 else 0
1237 orb %ah,%al -- %al = if (incomparable || different) then 1 else 0
1238 decb %al -- if (incomparable || different) then (%al == 0, ZF=1)
1239 else (%al == 0xFF, ZF=0)
1241 pprInstr g@(GCMP cond src1 src2)
1242 | case cond of { NE -> True; other -> False }
1244 hcat [gtab, text "pushl %eax ; ",gpush src1 0],
1245 hcat [gtab, text "fcomp ", greg src2 1,
1246 text "; fstsw %ax ; sahf ; setpe %ah"],
1247 hcat [gtab, text "setne %al ; ",
1248 text "orb %ah,%al ; decb %al ; popl %eax"]
1252 hcat [gtab, text "pushl %eax ; ",gpush src1 0],
1253 hcat [gtab, text "fcomp ", greg src2 1,
1254 text "; fstsw %ax ; sahf ; setpo %ah"],
1255 hcat [gtab, text "set", pprCond (fix_FP_cond cond), text " %al ; ",
1256 text "andb %ah,%al ; decb %al ; popl %eax"]
1259 {- On the 486, the flags set by FP compare are the unsigned ones!
1260 (This looks like a HACK to me. WDP 96/03)
1262 fix_FP_cond :: Cond -> Cond
1263 fix_FP_cond GE = GEU
1264 fix_FP_cond GTT = GU
1265 fix_FP_cond LTT = LU
1266 fix_FP_cond LE = LEU
1267 fix_FP_cond EQQ = EQQ
1269 -- there should be no others
1272 pprInstr g@(GABS sz src dst)
1273 = pprG g (hcat [gtab, gpush src 0, text " ; fabs ; ", gpop dst 1])
1274 pprInstr g@(GNEG sz src dst)
1275 = pprG g (hcat [gtab, gpush src 0, text " ; fchs ; ", gpop dst 1])
1277 pprInstr g@(GSQRT sz src dst)
1278 = pprG g (hcat [gtab, gpush src 0, text " ; fsqrt"] $$
1279 hcat [gtab, gcoerceto sz, gpop dst 1])
1280 pprInstr g@(GSIN sz src dst)
1281 = pprG g (hcat [gtab, gpush src 0, text " ; fsin"] $$
1282 hcat [gtab, gcoerceto sz, gpop dst 1])
1283 pprInstr g@(GCOS sz src dst)
1284 = pprG g (hcat [gtab, gpush src 0, text " ; fcos"] $$
1285 hcat [gtab, gcoerceto sz, gpop dst 1])
1286 pprInstr g@(GTAN sz src dst)
1287 = pprG g (hcat [gtab, text "ffree %st(6) ; ",
1288 gpush src 0, text " ; fptan ; ",
1289 text " fstp %st(0)"] $$
1290 hcat [gtab, gcoerceto sz, gpop dst 1])
1292 -- In the translations for GADD, GMUL, GSUB and GDIV,
1293 -- the first two cases are mere optimisations. The otherwise clause
1294 -- generates correct code under all circumstances.
1296 pprInstr g@(GADD sz src1 src2 dst)
1298 = pprG g (text "\t#GADD-xxxcase1" $$
1299 hcat [gtab, gpush src2 0,
1300 text " ; faddp %st(0),", greg src1 1])
1302 = pprG g (text "\t#GADD-xxxcase2" $$
1303 hcat [gtab, gpush src1 0,
1304 text " ; faddp %st(0),", greg src2 1])
1306 = pprG g (hcat [gtab, gpush src1 0,
1307 text " ; fadd ", greg src2 1, text ",%st(0)",
1311 pprInstr g@(GMUL sz src1 src2 dst)
1313 = pprG g (text "\t#GMUL-xxxcase1" $$
1314 hcat [gtab, gpush src2 0,
1315 text " ; fmulp %st(0),", greg src1 1])
1317 = pprG g (text "\t#GMUL-xxxcase2" $$
1318 hcat [gtab, gpush src1 0,
1319 text " ; fmulp %st(0),", greg src2 1])
1321 = pprG g (hcat [gtab, gpush src1 0,
1322 text " ; fmul ", greg src2 1, text ",%st(0)",
1326 pprInstr g@(GSUB sz src1 src2 dst)
1328 = pprG g (text "\t#GSUB-xxxcase1" $$
1329 hcat [gtab, gpush src2 0,
1330 text " ; fsubrp %st(0),", greg src1 1])
1332 = pprG g (text "\t#GSUB-xxxcase2" $$
1333 hcat [gtab, gpush src1 0,
1334 text " ; fsubp %st(0),", greg src2 1])
1336 = pprG g (hcat [gtab, gpush src1 0,
1337 text " ; fsub ", greg src2 1, text ",%st(0)",
1341 pprInstr g@(GDIV sz src1 src2 dst)
1343 = pprG g (text "\t#GDIV-xxxcase1" $$
1344 hcat [gtab, gpush src2 0,
1345 text " ; fdivrp %st(0),", greg src1 1])
1347 = pprG g (text "\t#GDIV-xxxcase2" $$
1348 hcat [gtab, gpush src1 0,
1349 text " ; fdivp %st(0),", greg src2 1])
1351 = pprG g (hcat [gtab, gpush src1 0,
1352 text " ; fdiv ", greg src2 1, text ",%st(0)",
1357 = vcat [ ptext SLIT("\tffree %st(0) ;ffree %st(1) ;ffree %st(2) ;ffree %st(3)"),
1358 ptext SLIT("\tffree %st(4) ;ffree %st(5) ;ffree %st(6) ;ffree %st(7)")
1361 pprInstr (FETCHGOT reg)
1362 = vcat [ ptext SLIT("\tcall 1f"),
1363 hcat [ ptext SLIT("1:\tpopl\t"), pprReg I32 reg ],
1364 hcat [ ptext SLIT("\taddl\t$_GLOBAL_OFFSET_TABLE_+(.-1b), "),
1368 -- Emit code to make hi_reg:lo_reg be the 64-bit product of hi_reg and lo_reg
1369 pprInstr_imul64 hi_reg lo_reg
1370 = let fakeInsn = text "imul64" <+> pp_hi_reg <> comma <+> pp_lo_reg
1371 pp_hi_reg = pprReg I32 hi_reg
1372 pp_lo_reg = pprReg I32 lo_reg
1375 text "\t# BEGIN " <> fakeInsn,
1376 text "\tpushl" <+> pp_hi_reg <> text" ; pushl" <+> pp_lo_reg,
1377 text "\tpushl %eax ; pushl %edx",
1378 text "\tmovl 12(%esp), %eax ; imull 8(%esp)",
1379 text "\tmovl %edx, 12(%esp) ; movl %eax, 8(%esp)",
1380 text "\tpopl %edx ; popl %eax",
1381 text "\tpopl" <+> pp_lo_reg <> text " ; popl" <+> pp_hi_reg,
1382 text "\t# END " <> fakeInsn
1386 --------------------------
1388 -- coerce %st(0) to the specified size
1389 gcoerceto F64 = empty
1390 gcoerceto F32 = empty --text "subl $4,%esp ; fstps (%esp) ; flds (%esp) ; addl $4,%esp ; "
1393 = hcat [text "ffree %st(7) ; fld ", greg reg offset]
1395 = hcat [text "fstp ", greg reg offset]
1397 greg reg offset = text "%st(" <> int (gregno reg - 8+offset) <> char ')'
1402 gregno (RealReg i) = i
1403 gregno other = --pprPanic "gregno" (ppr other)
1404 999 -- bogus; only needed for debug printing
1406 pprG :: Instr -> Doc -> Doc
1408 = (char '#' <> pprGInstr fake) $$ actual
1410 pprGInstr (GMOV src dst) = pprSizeRegReg SLIT("gmov") F64 src dst
1411 pprGInstr (GLD sz src dst) = pprSizeAddrReg SLIT("gld") sz src dst
1412 pprGInstr (GST sz src dst) = pprSizeRegAddr SLIT("gst") sz src dst
1414 pprGInstr (GLDZ dst) = pprSizeReg SLIT("gldz") F64 dst
1415 pprGInstr (GLD1 dst) = pprSizeReg SLIT("gld1") F64 dst
1417 pprGInstr (GFTOI src dst) = pprSizeSizeRegReg SLIT("gftoi") F32 I32 src dst
1418 pprGInstr (GDTOI src dst) = pprSizeSizeRegReg SLIT("gdtoi") F64 I32 src dst
1420 pprGInstr (GITOF src dst) = pprSizeSizeRegReg SLIT("gitof") I32 F32 src dst
1421 pprGInstr (GITOD src dst) = pprSizeSizeRegReg SLIT("gitod") I32 F64 src dst
1423 pprGInstr (GCMP co src dst) = pprCondRegReg SLIT("gcmp_") F64 co src dst
1424 pprGInstr (GABS sz src dst) = pprSizeRegReg SLIT("gabs") sz src dst
1425 pprGInstr (GNEG sz src dst) = pprSizeRegReg SLIT("gneg") sz src dst
1426 pprGInstr (GSQRT sz src dst) = pprSizeRegReg SLIT("gsqrt") sz src dst
1427 pprGInstr (GSIN sz src dst) = pprSizeRegReg SLIT("gsin") sz src dst
1428 pprGInstr (GCOS sz src dst) = pprSizeRegReg SLIT("gcos") sz src dst
1429 pprGInstr (GTAN sz src dst) = pprSizeRegReg SLIT("gtan") sz src dst
1431 pprGInstr (GADD sz src1 src2 dst) = pprSizeRegRegReg SLIT("gadd") sz src1 src2 dst
1432 pprGInstr (GSUB sz src1 src2 dst) = pprSizeRegRegReg SLIT("gsub") sz src1 src2 dst
1433 pprGInstr (GMUL sz src1 src2 dst) = pprSizeRegRegReg SLIT("gmul") sz src1 src2 dst
1434 pprGInstr (GDIV sz src1 src2 dst) = pprSizeRegRegReg SLIT("gdiv") sz src1 src2 dst
1436 -- Continue with I386-only printing bits and bobs:
1438 pprDollImm :: Imm -> Doc
1440 pprDollImm i = ptext SLIT("$") <> pprImm i
1442 pprOperand :: MachRep -> Operand -> Doc
1443 pprOperand s (OpReg r) = pprReg s r
1444 pprOperand s (OpImm i) = pprDollImm i
1445 pprOperand s (OpAddr ea) = pprAddr ea
1447 pprMnemonic :: LitString -> MachRep -> Doc
1448 pprMnemonic name size =
1449 char '\t' <> ptext name <> pprSize size <> space
1451 pprSizeImmOp :: LitString -> MachRep -> Imm -> Operand -> Doc
1452 pprSizeImmOp name size imm op1
1454 pprMnemonic name size,
1461 pprSizeOp :: LitString -> MachRep -> Operand -> Doc
1462 pprSizeOp name size op1
1464 pprMnemonic name size,
1468 pprSizeOpOp :: LitString -> MachRep -> Operand -> Operand -> Doc
1469 pprSizeOpOp name size op1 op2
1471 pprMnemonic name size,
1472 pprOperand size op1,
1477 pprSizeReg :: LitString -> MachRep -> Reg -> Doc
1478 pprSizeReg name size reg1
1480 pprMnemonic name size,
1484 pprSizeRegReg :: LitString -> MachRep -> Reg -> Reg -> Doc
1485 pprSizeRegReg name size reg1 reg2
1487 pprMnemonic name size,
1493 pprCondRegReg :: LitString -> MachRep -> Cond -> Reg -> Reg -> Doc
1494 pprCondRegReg name size cond reg1 reg2
1505 pprSizeSizeRegReg :: LitString -> MachRep -> MachRep -> Reg -> Reg -> Doc
1506 pprSizeSizeRegReg name size1 size2 reg1 reg2
1519 pprSizeRegRegReg :: LitString -> MachRep -> Reg -> Reg -> Reg -> Doc
1520 pprSizeRegRegReg name size reg1 reg2 reg3
1522 pprMnemonic name size,
1530 pprSizeAddrReg :: LitString -> MachRep -> AddrMode -> Reg -> Doc
1531 pprSizeAddrReg name size op dst
1533 pprMnemonic name size,
1539 pprSizeRegAddr :: LitString -> MachRep -> Reg -> AddrMode -> Doc
1540 pprSizeRegAddr name size src op
1542 pprMnemonic name size,
1548 pprShift :: LitString -> MachRep -> Operand -> Operand -> Doc
1549 pprShift name size src dest
1551 pprMnemonic name size,
1552 pprOperand I8 src, -- src is 8-bit sized
1554 pprOperand size dest
1557 pprSizeOpOpCoerce :: LitString -> MachRep -> MachRep -> Operand -> Operand -> Doc
1558 pprSizeOpOpCoerce name size1 size2 op1 op2
1559 = hcat [ char '\t', ptext name, pprSize size1, pprSize size2, space,
1560 pprOperand size1 op1,
1562 pprOperand size2 op2
1565 pprCondInstr :: LitString -> Cond -> Doc -> Doc
1566 pprCondInstr name cond arg
1567 = hcat [ char '\t', ptext name, pprCond cond, space, arg]
1569 #endif /* i386_TARGET_ARCH */
1572 -- ------------------------------------------------------------------------------- pprInstr for a SPARC
1574 #if sparc_TARGET_ARCH
1576 -- a clumsy hack for now, to handle possible double alignment problems
1578 -- even clumsier, to allow for RegReg regs that show when doing indexed
1579 -- reads (bytearrays).
1582 -- Translate to the following:
1585 -- ld [g1+4],%f(n+1)
1586 -- sub g1,g2,g1 -- to restore g1
1587 pprInstr (LD DF (AddrRegReg g1 g2) reg)
1589 hcat [ptext SLIT("\tadd\t"), pprReg g1,comma,pprReg g2,comma,pprReg g1],
1590 hcat [pp_ld_lbracket, pprReg g1, pp_rbracket_comma, pprReg reg],
1591 hcat [pp_ld_lbracket, pprReg g1, ptext SLIT("+4]"), comma, pprReg (fPair reg)],
1592 hcat [ptext SLIT("\tsub\t"), pprReg g1,comma,pprReg g2,comma,pprReg g1]
1597 -- ld [addr+4],%f(n+1)
1598 pprInstr (LD DF addr reg) | isJust off_addr
1600 hcat [pp_ld_lbracket, pprAddr addr, pp_rbracket_comma, pprReg reg],
1601 hcat [pp_ld_lbracket, pprAddr addr2, pp_rbracket_comma,pprReg (fPair reg)]
1604 off_addr = addrOffset addr 4
1605 addr2 = case off_addr of Just x -> x
1608 pprInstr (LD size addr reg)
1619 -- The same clumsy hack as above
1621 -- Translate to the following:
1624 -- st %f(n+1),[g1+4]
1625 -- sub g1,g2,g1 -- to restore g1
1626 pprInstr (ST DF reg (AddrRegReg g1 g2))
1628 hcat [ptext SLIT("\tadd\t"), pprReg g1,comma,pprReg g2,comma,pprReg g1],
1629 hcat [ptext SLIT("\tst\t"), pprReg reg, pp_comma_lbracket,
1631 hcat [ptext SLIT("\tst\t"), pprReg (fPair reg), pp_comma_lbracket,
1632 pprReg g1, ptext SLIT("+4]")],
1633 hcat [ptext SLIT("\tsub\t"), pprReg g1,comma,pprReg g2,comma,pprReg g1]
1638 -- st %f(n+1),[addr+4]
1639 pprInstr (ST DF reg addr) | isJust off_addr
1641 hcat [ptext SLIT("\tst\t"), pprReg reg, pp_comma_lbracket,
1642 pprAddr addr, rbrack],
1643 hcat [ptext SLIT("\tst\t"), pprReg (fPair reg), pp_comma_lbracket,
1644 pprAddr addr2, rbrack]
1647 off_addr = addrOffset addr 4
1648 addr2 = case off_addr of Just x -> x
1650 -- no distinction is made between signed and unsigned bytes on stores for the
1651 -- Sparc opcodes (at least I cannot see any, and gas is nagging me --SOF),
1652 -- so we call a special-purpose pprSize for ST..
1654 pprInstr (ST size reg addr)
1665 pprInstr (ADD x cc reg1 ri reg2)
1666 | not x && not cc && riZero ri
1667 = hcat [ ptext SLIT("\tmov\t"), pprReg reg1, comma, pprReg reg2 ]
1669 = pprRegRIReg (if x then SLIT("addx") else SLIT("add")) cc reg1 ri reg2
1671 pprInstr (SUB x cc reg1 ri reg2)
1672 | not x && cc && reg2 == g0
1673 = hcat [ ptext SLIT("\tcmp\t"), pprReg reg1, comma, pprRI ri ]
1674 | not x && not cc && riZero ri
1675 = hcat [ ptext SLIT("\tmov\t"), pprReg reg1, comma, pprReg reg2 ]
1677 = pprRegRIReg (if x then SLIT("subx") else SLIT("sub")) cc reg1 ri reg2
1679 pprInstr (AND b reg1 ri reg2) = pprRegRIReg SLIT("and") b reg1 ri reg2
1680 pprInstr (ANDN b reg1 ri reg2) = pprRegRIReg SLIT("andn") b reg1 ri reg2
1682 pprInstr (OR b reg1 ri reg2)
1683 | not b && reg1 == g0
1684 = let doit = hcat [ ptext SLIT("\tmov\t"), pprRI ri, comma, pprReg reg2 ]
1686 RIReg rrr | rrr == reg2 -> empty
1689 = pprRegRIReg SLIT("or") b reg1 ri reg2
1691 pprInstr (ORN b reg1 ri reg2) = pprRegRIReg SLIT("orn") b reg1 ri reg2
1693 pprInstr (XOR b reg1 ri reg2) = pprRegRIReg SLIT("xor") b reg1 ri reg2
1694 pprInstr (XNOR b reg1 ri reg2) = pprRegRIReg SLIT("xnor") b reg1 ri reg2
1696 pprInstr (SLL reg1 ri reg2) = pprRegRIReg SLIT("sll") False reg1 ri reg2
1697 pprInstr (SRL reg1 ri reg2) = pprRegRIReg SLIT("srl") False reg1 ri reg2
1698 pprInstr (SRA reg1 ri reg2) = pprRegRIReg SLIT("sra") False reg1 ri reg2
1700 pprInstr (RDY rd) = ptext SLIT("\trd\t%y,") <> pprReg rd
1701 pprInstr (SMUL b reg1 ri reg2) = pprRegRIReg SLIT("smul") b reg1 ri reg2
1702 pprInstr (UMUL b reg1 ri reg2) = pprRegRIReg SLIT("umul") b reg1 ri reg2
1704 pprInstr (SETHI imm reg)
1706 ptext SLIT("\tsethi\t"),
1712 pprInstr NOP = ptext SLIT("\tnop")
1714 pprInstr (FABS F reg1 reg2) = pprSizeRegReg SLIT("fabs") F reg1 reg2
1715 pprInstr (FABS DF reg1 reg2)
1716 = (<>) (pprSizeRegReg SLIT("fabs") F reg1 reg2)
1717 (if (reg1 == reg2) then empty
1718 else (<>) (char '\n')
1719 (pprSizeRegReg SLIT("fmov") F (fPair reg1) (fPair reg2)))
1721 pprInstr (FADD size reg1 reg2 reg3)
1722 = pprSizeRegRegReg SLIT("fadd") size reg1 reg2 reg3
1723 pprInstr (FCMP e size reg1 reg2)
1724 = pprSizeRegReg (if e then SLIT("fcmpe") else SLIT("fcmp")) size reg1 reg2
1725 pprInstr (FDIV size reg1 reg2 reg3)
1726 = pprSizeRegRegReg SLIT("fdiv") size reg1 reg2 reg3
1728 pprInstr (FMOV F reg1 reg2) = pprSizeRegReg SLIT("fmov") F reg1 reg2
1729 pprInstr (FMOV DF reg1 reg2)
1730 = (<>) (pprSizeRegReg SLIT("fmov") F reg1 reg2)
1731 (if (reg1 == reg2) then empty
1732 else (<>) (char '\n')
1733 (pprSizeRegReg SLIT("fmov") F (fPair reg1) (fPair reg2)))
1735 pprInstr (FMUL size reg1 reg2 reg3)
1736 = pprSizeRegRegReg SLIT("fmul") size reg1 reg2 reg3
1738 pprInstr (FNEG F reg1 reg2) = pprSizeRegReg SLIT("fneg") F reg1 reg2
1739 pprInstr (FNEG DF reg1 reg2)
1740 = (<>) (pprSizeRegReg SLIT("fneg") F reg1 reg2)
1741 (if (reg1 == reg2) then empty
1742 else (<>) (char '\n')
1743 (pprSizeRegReg SLIT("fmov") F (fPair reg1) (fPair reg2)))
1745 pprInstr (FSQRT size reg1 reg2) = pprSizeRegReg SLIT("fsqrt") size reg1 reg2
1746 pprInstr (FSUB size reg1 reg2 reg3) = pprSizeRegRegReg SLIT("fsub") size reg1 reg2 reg3
1747 pprInstr (FxTOy size1 size2 reg1 reg2)
1760 pprReg reg1, comma, pprReg reg2
1764 pprInstr (BI cond b lab)
1766 ptext SLIT("\tb"), pprCond cond,
1767 if b then pp_comma_a else empty,
1772 pprInstr (BF cond b lab)
1774 ptext SLIT("\tfb"), pprCond cond,
1775 if b then pp_comma_a else empty,
1780 pprInstr (JMP dsts addr) = (<>) (ptext SLIT("\tjmp\t")) (pprAddr addr)
1782 pprInstr (CALL (Left imm) n _)
1783 = hcat [ ptext SLIT("\tcall\t"), pprImm imm, comma, int n ]
1784 pprInstr (CALL (Right reg) n _)
1785 = hcat [ ptext SLIT("\tcall\t"), pprReg reg, comma, int n ]
1788 Continue with SPARC-only printing bits and bobs:
1791 pprRI (RIReg r) = pprReg r
1792 pprRI (RIImm r) = pprImm r
1794 pprSizeRegReg :: LitString -> Size -> Reg -> Reg -> Doc
1795 pprSizeRegReg name size reg1 reg2
1800 F -> ptext SLIT("s\t")
1801 DF -> ptext SLIT("d\t")),
1807 pprSizeRegRegReg :: LitString -> Size -> Reg -> Reg -> Reg -> Doc
1808 pprSizeRegRegReg name size reg1 reg2 reg3
1813 F -> ptext SLIT("s\t")
1814 DF -> ptext SLIT("d\t")),
1822 pprRegRIReg :: LitString -> Bool -> Reg -> RI -> Reg -> Doc
1823 pprRegRIReg name b reg1 ri reg2
1827 if b then ptext SLIT("cc\t") else char '\t',
1835 pprRIReg :: LitString -> Bool -> RI -> Reg -> Doc
1836 pprRIReg name b ri reg1
1840 if b then ptext SLIT("cc\t") else char '\t',
1846 pp_ld_lbracket = ptext SLIT("\tld\t[")
1847 pp_rbracket_comma = text "],"
1848 pp_comma_lbracket = text ",["
1849 pp_comma_a = text ",a"
1851 #endif /* sparc_TARGET_ARCH */
1854 -- -----------------------------------------------------------------------------
1855 -- pprInstr for PowerPC
1857 #if powerpc_TARGET_ARCH
1858 pprInstr (LD sz reg addr) = hcat [
1867 case addr of AddrRegImm _ _ -> empty
1868 AddrRegReg _ _ -> char 'x',
1874 pprInstr (LA sz reg addr) = hcat [
1883 case addr of AddrRegImm _ _ -> empty
1884 AddrRegReg _ _ -> char 'x',
1890 pprInstr (ST sz reg addr) = hcat [
1894 case addr of AddrRegImm _ _ -> empty
1895 AddrRegReg _ _ -> char 'x',
1901 pprInstr (STU sz reg addr) = hcat [
1906 case addr of AddrRegImm _ _ -> empty
1907 AddrRegReg _ _ -> char 'x',
1912 pprInstr (LIS reg imm) = hcat [
1920 pprInstr (LI reg imm) = hcat [
1928 pprInstr (MR reg1 reg2)
1929 | reg1 == reg2 = empty
1930 | otherwise = hcat [
1932 case regClass reg1 of
1933 RcInteger -> ptext SLIT("mr")
1934 _ -> ptext SLIT("fmr"),
1940 pprInstr (CMP sz reg ri) = hcat [
1956 pprInstr (CMPL sz reg ri) = hcat [
1972 pprInstr (BCC cond (BlockId id)) = hcat [
1979 where lbl = mkAsmTempLabel id
1981 pprInstr (JMP lbl) = hcat [ -- an alias for b that takes a CLabel
1988 pprInstr (MTCTR reg) = hcat [
1990 ptext SLIT("mtctr"),
1994 pprInstr (BCTR _) = hcat [
1998 pprInstr (BL lbl _) = hcat [
1999 ptext SLIT("\tbl\t"),
2002 pprInstr (BCTRL _) = hcat [
2006 pprInstr (ADD reg1 reg2 ri) = pprLogic SLIT("add") reg1 reg2 ri
2007 pprInstr (ADDIS reg1 reg2 imm) = hcat [
2009 ptext SLIT("addis"),
2018 pprInstr (ADDC reg1 reg2 reg3) = pprLogic SLIT("addc") reg1 reg2 (RIReg reg3)
2019 pprInstr (ADDE reg1 reg2 reg3) = pprLogic SLIT("adde") reg1 reg2 (RIReg reg3)
2020 pprInstr (SUBF reg1 reg2 reg3) = pprLogic SLIT("subf") reg1 reg2 (RIReg reg3)
2021 pprInstr (MULLW reg1 reg2 ri@(RIReg _)) = pprLogic SLIT("mullw") reg1 reg2 ri
2022 pprInstr (MULLW reg1 reg2 ri@(RIImm _)) = pprLogic SLIT("mull") reg1 reg2 ri
2023 pprInstr (DIVW reg1 reg2 reg3) = pprLogic SLIT("divw") reg1 reg2 (RIReg reg3)
2024 pprInstr (DIVWU reg1 reg2 reg3) = pprLogic SLIT("divwu") reg1 reg2 (RIReg reg3)
2026 pprInstr (MULLW_MayOflo reg1 reg2 reg3) = vcat [
2027 hcat [ ptext SLIT("\tmullwo\t"), pprReg reg1, ptext SLIT(", "),
2028 pprReg reg2, ptext SLIT(", "),
2030 hcat [ ptext SLIT("\tmfxer\t"), pprReg reg1 ],
2031 hcat [ ptext SLIT("\trlwinm\t"), pprReg reg1, ptext SLIT(", "),
2032 pprReg reg1, ptext SLIT(", "),
2033 ptext SLIT("2, 31, 31") ]
2036 -- for some reason, "andi" doesn't exist.
2037 -- we'll use "andi." instead.
2038 pprInstr (AND reg1 reg2 (RIImm imm)) = hcat [
2040 ptext SLIT("andi."),
2048 pprInstr (AND reg1 reg2 ri) = pprLogic SLIT("and") reg1 reg2 ri
2050 pprInstr (OR reg1 reg2 ri) = pprLogic SLIT("or") reg1 reg2 ri
2051 pprInstr (XOR reg1 reg2 ri) = pprLogic SLIT("xor") reg1 reg2 ri
2053 pprInstr (XORIS reg1 reg2 imm) = hcat [
2055 ptext SLIT("xoris"),
2064 pprInstr (EXTS sz reg1 reg2) = hcat [
2074 pprInstr (NEG reg1 reg2) = pprUnary SLIT("neg") reg1 reg2
2075 pprInstr (NOT reg1 reg2) = pprUnary SLIT("not") reg1 reg2
2077 pprInstr (SLW reg1 reg2 ri) = pprLogic SLIT("slw") reg1 reg2 (limitShiftRI ri)
2078 pprInstr (SRW reg1 reg2 ri) = pprLogic SLIT("srw") reg1 reg2 (limitShiftRI ri)
2079 pprInstr (SRAW reg1 reg2 ri) = pprLogic SLIT("sraw") reg1 reg2 (limitShiftRI ri)
2080 pprInstr (RLWINM reg1 reg2 sh mb me) = hcat [
2081 ptext SLIT("\trlwinm\t"),
2093 pprInstr (FADD sz reg1 reg2 reg3) = pprBinaryF SLIT("fadd") sz reg1 reg2 reg3
2094 pprInstr (FSUB sz reg1 reg2 reg3) = pprBinaryF SLIT("fsub") sz reg1 reg2 reg3
2095 pprInstr (FMUL sz reg1 reg2 reg3) = pprBinaryF SLIT("fmul") sz reg1 reg2 reg3
2096 pprInstr (FDIV sz reg1 reg2 reg3) = pprBinaryF SLIT("fdiv") sz reg1 reg2 reg3
2097 pprInstr (FNEG reg1 reg2) = pprUnary SLIT("fneg") reg1 reg2
2099 pprInstr (FCMP reg1 reg2) = hcat [
2101 ptext SLIT("fcmpu\tcr0, "),
2102 -- Note: we're using fcmpu, not fcmpo
2103 -- The difference is with fcmpo, compare with NaN is an invalid operation.
2104 -- We don't handle invalid fp ops, so we don't care
2110 pprInstr (FCTIWZ reg1 reg2) = pprUnary SLIT("fctiwz") reg1 reg2
2111 pprInstr (FRSP reg1 reg2) = pprUnary SLIT("frsp") reg1 reg2
2113 pprInstr (CRNOR dst src1 src2) = hcat [
2114 ptext SLIT("\tcrnor\t"),
2122 pprInstr (MFCR reg) = hcat [
2129 pprInstr (MFLR reg) = hcat [
2136 pprInstr (FETCHPC reg) = vcat [
2137 ptext SLIT("\tbcl\t20,31,1f"),
2138 hcat [ ptext SLIT("1:\tmflr\t"), pprReg reg ]
2141 pprInstr _ = panic "pprInstr (ppc)"
2143 pprLogic op reg1 reg2 ri = hcat [
2148 RIImm _ -> char 'i',
2157 pprUnary op reg1 reg2 = hcat [
2166 pprBinaryF op sz reg1 reg2 reg3 = hcat [
2179 pprRI (RIReg r) = pprReg r
2180 pprRI (RIImm r) = pprImm r
2182 pprFSize F64 = empty
2183 pprFSize F32 = char 's'
2185 -- limit immediate argument for shift instruction to range 0..32
2186 -- (yes, the maximum is really 32, not 31)
2187 limitShiftRI :: RI -> RI
2188 limitShiftRI (RIImm (ImmInt i)) | i > 32 || i < 0 = RIImm (ImmInt 32)
2191 #endif /* powerpc_TARGET_ARCH */
2194 -- -----------------------------------------------------------------------------
2195 -- Converting floating-point literals to integrals for printing
2197 #if __GLASGOW_HASKELL__ >= 504
2198 newFloatArray :: (Int,Int) -> ST s (STUArray s Int Float)
2199 newFloatArray = newArray_
2201 newDoubleArray :: (Int,Int) -> ST s (STUArray s Int Double)
2202 newDoubleArray = newArray_
2204 castFloatToCharArray :: STUArray s Int Float -> ST s (STUArray s Int Word8)
2205 castFloatToCharArray = castSTUArray
2207 castDoubleToCharArray :: STUArray s Int Double -> ST s (STUArray s Int Word8)
2208 castDoubleToCharArray = castSTUArray
2210 writeFloatArray :: STUArray s Int Float -> Int -> Float -> ST s ()
2211 writeFloatArray = writeArray
2213 writeDoubleArray :: STUArray s Int Double -> Int -> Double -> ST s ()
2214 writeDoubleArray = writeArray
2216 readCharArray :: STUArray s Int Word8 -> Int -> ST s Char
2217 readCharArray arr i = do
2218 w <- readArray arr i
2219 return $! (chr (fromIntegral w))
2223 castFloatToCharArray :: MutableByteArray s t -> ST s (MutableByteArray s t)
2224 castFloatToCharArray = return
2226 castDoubleToCharArray :: MutableByteArray s t -> ST s (MutableByteArray s t)
2229 castDoubleToCharArray = return
2233 -- floatToBytes and doubleToBytes convert to the host's byte
2234 -- order. Providing that we're not cross-compiling for a
2235 -- target with the opposite endianness, this should work ok
2238 -- ToDo: this stuff is very similar to the shenanigans in PprAbs,
2239 -- could they be merged?
2241 floatToBytes :: Float -> [Int]
2244 arr <- newFloatArray ((0::Int),3)
2245 writeFloatArray arr 0 f
2246 arr <- castFloatToCharArray arr
2247 i0 <- readCharArray arr 0
2248 i1 <- readCharArray arr 1
2249 i2 <- readCharArray arr 2
2250 i3 <- readCharArray arr 3
2251 return (map ord [i0,i1,i2,i3])
2254 doubleToBytes :: Double -> [Int]
2257 arr <- newDoubleArray ((0::Int),7)
2258 writeDoubleArray arr 0 d
2259 arr <- castDoubleToCharArray arr
2260 i0 <- readCharArray arr 0
2261 i1 <- readCharArray arr 1
2262 i2 <- readCharArray arr 2
2263 i3 <- readCharArray arr 3
2264 i4 <- readCharArray arr 4
2265 i5 <- readCharArray arr 5
2266 i6 <- readCharArray arr 6
2267 i7 <- readCharArray arr 7
2268 return (map ord [i0,i1,i2,i3,i4,i5,i6,i7])