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 pprSectionHeader Text
540 IF_ARCH_alpha(SLIT("\t.text\n\t.align 3") {-word boundary-}
541 ,IF_ARCH_sparc(SLIT(".text\n\t.align 4") {-word boundary-}
542 ,IF_ARCH_i386(SLIT(".text\n\t.align 4,0x90") {-needs per-OS variation!-}
543 ,IF_ARCH_powerpc(SLIT(".text\n.align 2")
545 pprSectionHeader Data
547 IF_ARCH_alpha(SLIT("\t.data\n\t.align 3")
548 ,IF_ARCH_sparc(SLIT(".data\n\t.align 8") {-<8 will break double constants -}
549 ,IF_ARCH_i386(SLIT(".data\n\t.align 4")
550 ,IF_ARCH_powerpc(SLIT(".data\n.align 2")
552 pprSectionHeader ReadOnlyData
554 IF_ARCH_alpha(SLIT("\t.data\n\t.align 3")
555 ,IF_ARCH_sparc(SLIT(".data\n\t.align 8") {-<8 will break double constants -}
556 ,IF_ARCH_i386(SLIT(".section .rodata\n\t.align 4")
557 ,IF_ARCH_powerpc(IF_OS_darwin(SLIT(".const\n.align 2"),
558 SLIT(".section .rodata\n\t.align 2"))
560 pprSectionHeader RelocatableReadOnlyData
562 IF_ARCH_alpha(SLIT("\t.data\n\t.align 3")
563 ,IF_ARCH_sparc(SLIT(".data\n\t.align 8") {-<8 will break double constants -}
564 ,IF_ARCH_i386(SLIT(".data\n\t.align 4")
565 ,IF_ARCH_powerpc(IF_OS_darwin(SLIT(".const_data\n.align 2"),
566 SLIT(".data\n\t.align 2"))
568 pprSectionHeader UninitialisedData
570 IF_ARCH_alpha(SLIT("\t.bss\n\t.align 3")
571 ,IF_ARCH_sparc(SLIT(".bss\n\t.align 8") {-<8 will break double constants -}
572 ,IF_ARCH_i386(SLIT(".section .bss\n\t.align 4")
573 ,IF_ARCH_powerpc(IF_OS_darwin(SLIT(".const_data\n.align 2"),
574 SLIT(".section .bss\n\t.align 2"))
576 pprSectionHeader (OtherSection sec)
577 = panic "PprMach.pprSectionHeader: unknown section"
579 pprData :: CmmStatic -> Doc
580 pprData (CmmAlign bytes) = pprAlign bytes
581 pprData (CmmDataLabel lbl) = pprLabel lbl
582 pprData (CmmString str) = pprASCII str
583 pprData (CmmUninitialised bytes) = ptext SLIT(".space ") <> int bytes
584 pprData (CmmStaticLit lit) = pprDataItem lit
586 pprGloblDecl :: CLabel -> Doc
588 | not (externallyVisibleCLabel lbl) = empty
589 | otherwise = ptext IF_ARCH_alpha(SLIT(".globl ")
590 ,IF_ARCH_i386(SLIT(".globl ")
591 ,IF_ARCH_sparc(SLIT(".global ")
592 ,IF_ARCH_powerpc(SLIT(".globl ")
596 pprLabel :: CLabel -> Doc
597 pprLabel lbl = pprGloblDecl lbl $$ (pprCLabel_asm lbl <> char ':')
600 -- Assume we want to backslash-convert the string
602 = vcat (map do1 (str ++ [chr 0]))
605 do1 c = ptext SLIT("\t.byte\t0x") <> hshow (ord c)
608 hshow n | n >= 0 && n <= 255
609 = char (tab !! (n `div` 16)) <> char (tab !! (n `mod` 16))
610 tab = "0123456789ABCDEF"
613 IF_ARCH_alpha(ptextSLIT(".align ") <> int pow2,
614 IF_ARCH_i386(ptext SLIT(".align ") <> int bytes,
615 IF_ARCH_sparc(ptext SLIT(".align ") <> int bytes,
616 IF_ARCH_powerpc(ptext SLIT(".align ") <> int pow2,))))
620 log2 :: Int -> Int -- cache the common ones
625 log2 n = 1 + log2 (n `quot` 2)
628 pprDataItem :: CmmLit -> Doc
630 = vcat (ppr_item (cmmLitRep lit) lit)
634 -- These seem to be common:
635 ppr_item I8 x = [ptext SLIT("\t.byte\t") <> pprImm imm]
636 ppr_item I32 x = [ptext SLIT("\t.long\t") <> pprImm imm]
637 ppr_item F32 (CmmFloat r _)
638 = let bs = floatToBytes (fromRational r)
639 in map (\b -> ptext SLIT("\t.byte\t") <> pprImm (ImmInt b)) bs
640 ppr_item F64 (CmmFloat r _)
641 = let bs = doubleToBytes (fromRational r)
642 in map (\b -> ptext SLIT("\t.byte\t") <> pprImm (ImmInt b)) bs
644 #if sparc_TARGET_ARCH
645 -- copy n paste of x86 version
646 ppr_item I16 x = [ptext SLIT("\t.short\t") <> pprImm imm]
647 ppr_item I64 x = [ptext SLIT("\t.quad\t") <> pprImm imm]
650 ppr_item I16 x = [ptext SLIT("\t.word\t") <> pprImm imm]
651 ppr_item I64 x = [ptext SLIT("\t.quad\t") <> pprImm imm]
653 #if powerpc_TARGET_ARCH
654 ppr_item I16 x = [ptext SLIT("\t.short\t") <> pprImm imm]
655 ppr_item I64 (CmmInt x _) =
656 [ptext SLIT("\t.long\t")
658 (fromIntegral (x `shiftR` 32) :: Word32)),
659 ptext SLIT("\t.long\t")
660 <> int (fromIntegral (fromIntegral x :: Word32))]
663 -- fall through to rest of (machine-specific) pprInstr...
665 -- -----------------------------------------------------------------------------
666 -- pprInstr: print an 'Instr'
668 pprInstr :: Instr -> Doc
670 --pprInstr (COMMENT s) = empty -- nuke 'em
672 = IF_ARCH_alpha( ((<>) (ptext SLIT("\t# ")) (ftext s))
673 ,IF_ARCH_sparc( ((<>) (ptext SLIT("! ")) (ftext s))
674 ,IF_ARCH_i386( ((<>) (ptext SLIT("# ")) (ftext s))
675 ,IF_ARCH_powerpc( IF_OS_linux(
676 ((<>) (ptext SLIT("# ")) (ftext s)),
677 ((<>) (ptext SLIT("; ")) (ftext s)))
681 = pprInstr (COMMENT (mkFastString ("\tdelta = " ++ show d)))
683 pprInstr (NEWBLOCK _)
684 = panic "PprMach.pprInstr: NEWBLOCK"
687 = panic "PprMach.pprInstr: LDATA"
689 -- -----------------------------------------------------------------------------
690 -- pprInstr for an Alpha
692 #if alpha_TARGET_ARCH
694 pprInstr (LD size reg addr)
704 pprInstr (LDA reg addr)
706 ptext SLIT("\tlda\t"),
712 pprInstr (LDAH reg addr)
714 ptext SLIT("\tldah\t"),
720 pprInstr (LDGP reg addr)
722 ptext SLIT("\tldgp\t"),
728 pprInstr (LDI size reg imm)
738 pprInstr (ST size reg addr)
750 ptext SLIT("\tclr\t"),
754 pprInstr (ABS size ri reg)
764 pprInstr (NEG size ov ri reg)
768 if ov then ptext SLIT("v\t") else char '\t',
774 pprInstr (ADD size ov reg1 ri reg2)
778 if ov then ptext SLIT("v\t") else char '\t',
786 pprInstr (SADD size scale reg1 ri reg2)
788 ptext (case scale of {{-UNUSED:L -> SLIT("\ts4");-} Q -> SLIT("\ts8")}),
799 pprInstr (SUB size ov reg1 ri reg2)
803 if ov then ptext SLIT("v\t") else char '\t',
811 pprInstr (SSUB size scale reg1 ri reg2)
813 ptext (case scale of {{-UNUSED:L -> SLIT("\ts4");-} Q -> SLIT("\ts8")}),
824 pprInstr (MUL size ov reg1 ri reg2)
828 if ov then ptext SLIT("v\t") else char '\t',
836 pprInstr (DIV size uns reg1 ri reg2)
840 if uns then ptext SLIT("u\t") else char '\t',
848 pprInstr (REM size uns reg1 ri reg2)
852 if uns then ptext SLIT("u\t") else char '\t',
860 pprInstr (NOT ri reg)
869 pprInstr (AND reg1 ri reg2) = pprRegRIReg SLIT("and") reg1 ri reg2
870 pprInstr (ANDNOT reg1 ri reg2) = pprRegRIReg SLIT("andnot") reg1 ri reg2
871 pprInstr (OR reg1 ri reg2) = pprRegRIReg SLIT("or") reg1 ri reg2
872 pprInstr (ORNOT reg1 ri reg2) = pprRegRIReg SLIT("ornot") reg1 ri reg2
873 pprInstr (XOR reg1 ri reg2) = pprRegRIReg SLIT("xor") reg1 ri reg2
874 pprInstr (XORNOT reg1 ri reg2) = pprRegRIReg SLIT("xornot") reg1 ri reg2
876 pprInstr (SLL reg1 ri reg2) = pprRegRIReg SLIT("sll") reg1 ri reg2
877 pprInstr (SRL reg1 ri reg2) = pprRegRIReg SLIT("srl") reg1 ri reg2
878 pprInstr (SRA reg1 ri reg2) = pprRegRIReg SLIT("sra") reg1 ri reg2
880 pprInstr (ZAP reg1 ri reg2) = pprRegRIReg SLIT("zap") reg1 ri reg2
881 pprInstr (ZAPNOT reg1 ri reg2) = pprRegRIReg SLIT("zapnot") reg1 ri reg2
883 pprInstr (NOP) = ptext SLIT("\tnop")
885 pprInstr (CMP cond reg1 ri reg2)
899 ptext SLIT("\tfclr\t"),
903 pprInstr (FABS reg1 reg2)
905 ptext SLIT("\tfabs\t"),
911 pprInstr (FNEG size reg1 reg2)
921 pprInstr (FADD size reg1 reg2 reg3) = pprSizeRegRegReg SLIT("add") size reg1 reg2 reg3
922 pprInstr (FDIV size reg1 reg2 reg3) = pprSizeRegRegReg SLIT("div") size reg1 reg2 reg3
923 pprInstr (FMUL size reg1 reg2 reg3) = pprSizeRegRegReg SLIT("mul") size reg1 reg2 reg3
924 pprInstr (FSUB size reg1 reg2 reg3) = pprSizeRegRegReg SLIT("sub") size reg1 reg2 reg3
926 pprInstr (CVTxy size1 size2 reg1 reg2)
930 case size2 of {Q -> ptext SLIT("qc"); _ -> pprSize size2},
937 pprInstr (FCMP size cond reg1 reg2 reg3)
950 pprInstr (FMOV reg1 reg2)
952 ptext SLIT("\tfmov\t"),
958 pprInstr (BI ALWAYS reg lab) = pprInstr (BR lab)
960 pprInstr (BI NEVER reg lab) = empty
962 pprInstr (BI cond reg lab)
972 pprInstr (BF cond reg lab)
983 = (<>) (ptext SLIT("\tbr\t")) (pprImm lab)
985 pprInstr (JMP reg addr hint)
987 ptext SLIT("\tjmp\t"),
996 = (<>) (ptext SLIT("\tbsr\t")) (pprImm imm)
998 pprInstr (JSR reg addr n)
1000 ptext SLIT("\tjsr\t"),
1006 pprInstr (FUNBEGIN clab)
1008 if (externallyVisibleCLabel clab) then
1009 hcat [ptext SLIT("\t.globl\t"), pp_lab, char '\n']
1012 ptext SLIT("\t.ent "),
1021 pp_lab = pprCLabel_asm clab
1023 -- NEVER use commas within those string literals, cpp will ruin your day
1024 pp_ldgp = hcat [ ptext SLIT(":\n\tldgp $29"), char ',', ptext SLIT("0($27)\n") ]
1025 pp_frame = hcat [ ptext SLIT("..ng:\n\t.frame $30"), char ',',
1026 ptext SLIT("4240"), char ',',
1027 ptext SLIT("$26"), char ',',
1028 ptext SLIT("0\n\t.prologue 1") ]
1030 pprInstr (FUNEND clab)
1031 = (<>) (ptext SLIT("\t.align 4\n\t.end ")) (pprCLabel_asm clab)
1034 Continue with Alpha-only printing bits and bobs:
1038 pprRI (RIReg r) = pprReg r
1039 pprRI (RIImm r) = pprImm r
1041 pprRegRIReg :: LitString -> Reg -> RI -> Reg -> Doc
1042 pprRegRIReg name reg1 ri reg2
1054 pprSizeRegRegReg :: LitString -> Size -> Reg -> Reg -> Reg -> Doc
1055 pprSizeRegRegReg name size reg1 reg2 reg3
1068 #endif /* alpha_TARGET_ARCH */
1071 -- -----------------------------------------------------------------------------
1072 -- pprInstr for an x86
1074 #if i386_TARGET_ARCH
1076 pprInstr v@(MOV size s@(OpReg src) d@(OpReg dst)) -- hack
1079 #if 0 /* #ifdef DEBUG */
1080 (<>) (ptext SLIT("# warning: ")) (pprSizeOpOp SLIT("mov") size s d)
1084 pprInstr (MOV size src dst)
1085 = pprSizeOpOp SLIT("mov") size src dst
1086 pprInstr (MOVZxL sizes src dst) = pprSizeOpOpCoerce SLIT("movz") sizes I32 src dst
1087 pprInstr (MOVSxL sizes src dst) = pprSizeOpOpCoerce SLIT("movs") sizes I32 src dst
1089 -- here we do some patching, since the physical registers are only set late
1090 -- in the code generation.
1091 pprInstr (LEA size (OpAddr (AddrBaseIndex src1@(Just reg1) (Just (reg2,1)) (ImmInt 0))) dst@(OpReg reg3))
1093 = pprSizeOpOp SLIT("add") size (OpReg reg2) dst
1094 pprInstr (LEA size (OpAddr (AddrBaseIndex src1@(Just reg1) (Just (reg2,1)) (ImmInt 0))) dst@(OpReg reg3))
1096 = pprSizeOpOp SLIT("add") size (OpReg reg1) dst
1097 pprInstr (LEA size (OpAddr (AddrBaseIndex src1@(Just reg1) Nothing displ)) dst@(OpReg reg3))
1099 = pprInstr (ADD size (OpImm displ) dst)
1100 pprInstr (LEA size src dst) = pprSizeOpOp SLIT("lea") size src dst
1102 pprInstr (ADD size (OpImm (ImmInt (-1))) dst)
1103 = pprSizeOp SLIT("dec") size dst
1104 pprInstr (ADD size (OpImm (ImmInt 1)) dst)
1105 = pprSizeOp SLIT("inc") size dst
1106 pprInstr (ADD size src dst)
1107 = pprSizeOpOp SLIT("add") size src dst
1108 pprInstr (ADC size src dst)
1109 = pprSizeOpOp SLIT("adc") size src dst
1110 pprInstr (SUB size src dst) = pprSizeOpOp SLIT("sub") size src dst
1111 pprInstr (IMUL size op1 op2) = pprSizeOpOp SLIT("imul") size op1 op2
1113 {- A hack. The Intel documentation says that "The two and three
1114 operand forms [of IMUL] may also be used with unsigned operands
1115 because the lower half of the product is the same regardless if
1116 (sic) the operands are signed or unsigned. The CF and OF flags,
1117 however, cannot be used to determine if the upper half of the
1118 result is non-zero." So there.
1120 pprInstr (MUL size op1 op2) = pprSizeOpOp SLIT("imul") size op1 op2
1122 pprInstr (AND size src dst) = pprSizeOpOp SLIT("and") size src dst
1123 pprInstr (OR size src dst) = pprSizeOpOp SLIT("or") size src dst
1124 pprInstr (XOR size src dst) = pprSizeOpOp SLIT("xor") size src dst
1125 pprInstr (NOT size op) = pprSizeOp SLIT("not") size op
1126 pprInstr (NEGI size op) = pprSizeOp SLIT("neg") size op
1128 pprInstr (SHL size src dst) = pprShift SLIT("shl") size src dst
1129 pprInstr (SAR size src dst) = pprShift SLIT("sar") size src dst
1130 pprInstr (SHR size src dst) = pprShift SLIT("shr") size src dst
1132 pprInstr (BT size imm src) = pprSizeImmOp SLIT("bt") size imm src
1134 pprInstr (CMP size src dst) = pprSizeOpOp SLIT("cmp") size src dst
1135 pprInstr (TEST size src dst) = pprSizeOpOp SLIT("test") size src dst
1136 pprInstr (PUSH size op) = pprSizeOp SLIT("push") size op
1137 pprInstr (POP size op) = pprSizeOp SLIT("pop") size op
1139 -- both unused (SDM):
1140 -- pprInstr PUSHA = ptext SLIT("\tpushal")
1141 -- pprInstr POPA = ptext SLIT("\tpopal")
1143 pprInstr NOP = ptext SLIT("\tnop")
1144 pprInstr CLTD = ptext SLIT("\tcltd")
1146 pprInstr (SETCC cond op) = pprCondInstr SLIT("set") cond (pprOperand I8 op)
1148 pprInstr (JXX cond (BlockId id))
1149 = pprCondInstr SLIT("j") cond (pprCLabel_asm lab)
1150 where lab = mkAsmTempLabel id
1152 pprInstr (JMP (OpImm imm)) = (<>) (ptext SLIT("\tjmp ")) (pprImm imm)
1153 pprInstr (JMP op) = (<>) (ptext SLIT("\tjmp *")) (pprOperand I32 op)
1154 pprInstr (JMP_TBL op ids) = pprInstr (JMP op)
1155 pprInstr (CALL (Left imm)) = (<>) (ptext SLIT("\tcall ")) (pprImm imm)
1156 pprInstr (CALL (Right reg)) = (<>) (ptext SLIT("\tcall *")) (pprReg I32 reg)
1158 pprInstr (IDIV sz op) = pprSizeOp SLIT("idiv") sz op
1159 pprInstr (DIV sz op) = pprSizeOp SLIT("div") sz op
1161 pprInstr (IMUL64 sd_hi sd_lo) = pprInstr_imul64 sd_hi sd_lo
1164 -- Simulating a flat register set on the x86 FP stack is tricky.
1165 -- you have to free %st(7) before pushing anything on the FP reg stack
1166 -- so as to preclude the possibility of a FP stack overflow exception.
1167 pprInstr g@(GMOV src dst)
1171 = pprG g (hcat [gtab, gpush src 0, gsemi, gpop dst 1])
1173 -- GLD sz addr dst ==> FFREE %st(7) ; FLDsz addr ; FSTP (dst+1)
1174 pprInstr g@(GLD sz addr dst)
1175 = pprG g (hcat [gtab, text "ffree %st(7) ; fld", pprSize sz, gsp,
1176 pprAddr addr, gsemi, gpop dst 1])
1178 -- GST sz src addr ==> FFREE %st(7) ; FLD dst ; FSTPsz addr
1179 pprInstr g@(GST sz src addr)
1180 = pprG g (hcat [gtab, gpush src 0, gsemi,
1181 text "fstp", pprSize sz, gsp, pprAddr addr])
1183 pprInstr g@(GLDZ dst)
1184 = pprG g (hcat [gtab, text "ffree %st(7) ; fldz ; ", gpop dst 1])
1185 pprInstr g@(GLD1 dst)
1186 = pprG g (hcat [gtab, text "ffree %st(7) ; fld1 ; ", gpop dst 1])
1188 pprInstr g@(GFTOI src dst)
1189 = pprInstr (GDTOI src dst)
1190 pprInstr g@(GDTOI src dst)
1191 = pprG g (hcat [gtab, text "subl $4, %esp ; ",
1192 gpush src 0, gsemi, text "fistpl 0(%esp) ; popl ",
1195 pprInstr g@(GITOF src dst)
1196 = pprInstr (GITOD src dst)
1197 pprInstr g@(GITOD src dst)
1198 = pprG g (hcat [gtab, text "pushl ", pprReg I32 src,
1199 text " ; ffree %st(7); fildl (%esp) ; ",
1200 gpop dst 1, text " ; addl $4,%esp"])
1202 {- Gruesome swamp follows. If you're unfortunate enough to have ventured
1203 this far into the jungle AND you give a Rat's Ass (tm) what's going
1204 on, here's the deal. Generate code to do a floating point comparison
1205 of src1 and src2, of kind cond, and set the Zero flag if true.
1207 The complications are to do with handling NaNs correctly. We want the
1208 property that if either argument is NaN, then the result of the
1209 comparison is False ... except if we're comparing for inequality,
1210 in which case the answer is True.
1212 Here's how the general (non-inequality) case works. As an
1213 example, consider generating the an equality test:
1215 pushl %eax -- we need to mess with this
1216 <get src1 to top of FPU stack>
1217 fcomp <src2 location in FPU stack> and pop pushed src1
1218 -- Result of comparison is in FPU Status Register bits
1220 fstsw %ax -- Move FPU Status Reg to %ax
1221 sahf -- move C3 C2 C0 from %ax to integer flag reg
1222 -- now the serious magic begins
1223 setpo %ah -- %ah = if comparable(neither arg was NaN) then 1 else 0
1224 sete %al -- %al = if arg1 == arg2 then 1 else 0
1225 andb %ah,%al -- %al &= %ah
1226 -- so %al == 1 iff (comparable && same); else it holds 0
1227 decb %al -- %al == 0, ZeroFlag=1 iff (comparable && same);
1228 else %al == 0xFF, ZeroFlag=0
1229 -- the zero flag is now set as we desire.
1232 The special case of inequality differs thusly:
1234 setpe %ah -- %ah = if incomparable(either arg was NaN) then 1 else 0
1235 setne %al -- %al = if arg1 /= arg2 then 1 else 0
1236 orb %ah,%al -- %al = if (incomparable || different) then 1 else 0
1237 decb %al -- if (incomparable || different) then (%al == 0, ZF=1)
1238 else (%al == 0xFF, ZF=0)
1240 pprInstr g@(GCMP cond src1 src2)
1241 | case cond of { NE -> True; other -> False }
1243 hcat [gtab, text "pushl %eax ; ",gpush src1 0],
1244 hcat [gtab, text "fcomp ", greg src2 1,
1245 text "; fstsw %ax ; sahf ; setpe %ah"],
1246 hcat [gtab, text "setne %al ; ",
1247 text "orb %ah,%al ; decb %al ; popl %eax"]
1251 hcat [gtab, text "pushl %eax ; ",gpush src1 0],
1252 hcat [gtab, text "fcomp ", greg src2 1,
1253 text "; fstsw %ax ; sahf ; setpo %ah"],
1254 hcat [gtab, text "set", pprCond (fix_FP_cond cond), text " %al ; ",
1255 text "andb %ah,%al ; decb %al ; popl %eax"]
1258 {- On the 486, the flags set by FP compare are the unsigned ones!
1259 (This looks like a HACK to me. WDP 96/03)
1261 fix_FP_cond :: Cond -> Cond
1262 fix_FP_cond GE = GEU
1263 fix_FP_cond GTT = GU
1264 fix_FP_cond LTT = LU
1265 fix_FP_cond LE = LEU
1266 fix_FP_cond EQQ = EQQ
1268 -- there should be no others
1271 pprInstr g@(GABS sz src dst)
1272 = pprG g (hcat [gtab, gpush src 0, text " ; fabs ; ", gpop dst 1])
1273 pprInstr g@(GNEG sz src dst)
1274 = pprG g (hcat [gtab, gpush src 0, text " ; fchs ; ", gpop dst 1])
1276 pprInstr g@(GSQRT sz src dst)
1277 = pprG g (hcat [gtab, gpush src 0, text " ; fsqrt"] $$
1278 hcat [gtab, gcoerceto sz, gpop dst 1])
1279 pprInstr g@(GSIN sz src dst)
1280 = pprG g (hcat [gtab, gpush src 0, text " ; fsin"] $$
1281 hcat [gtab, gcoerceto sz, gpop dst 1])
1282 pprInstr g@(GCOS sz src dst)
1283 = pprG g (hcat [gtab, gpush src 0, text " ; fcos"] $$
1284 hcat [gtab, gcoerceto sz, gpop dst 1])
1285 pprInstr g@(GTAN sz src dst)
1286 = pprG g (hcat [gtab, text "ffree %st(6) ; ",
1287 gpush src 0, text " ; fptan ; ",
1288 text " fstp %st(0)"] $$
1289 hcat [gtab, gcoerceto sz, gpop dst 1])
1291 -- In the translations for GADD, GMUL, GSUB and GDIV,
1292 -- the first two cases are mere optimisations. The otherwise clause
1293 -- generates correct code under all circumstances.
1295 pprInstr g@(GADD sz src1 src2 dst)
1297 = pprG g (text "\t#GADD-xxxcase1" $$
1298 hcat [gtab, gpush src2 0,
1299 text " ; faddp %st(0),", greg src1 1])
1301 = pprG g (text "\t#GADD-xxxcase2" $$
1302 hcat [gtab, gpush src1 0,
1303 text " ; faddp %st(0),", greg src2 1])
1305 = pprG g (hcat [gtab, gpush src1 0,
1306 text " ; fadd ", greg src2 1, text ",%st(0)",
1310 pprInstr g@(GMUL sz src1 src2 dst)
1312 = pprG g (text "\t#GMUL-xxxcase1" $$
1313 hcat [gtab, gpush src2 0,
1314 text " ; fmulp %st(0),", greg src1 1])
1316 = pprG g (text "\t#GMUL-xxxcase2" $$
1317 hcat [gtab, gpush src1 0,
1318 text " ; fmulp %st(0),", greg src2 1])
1320 = pprG g (hcat [gtab, gpush src1 0,
1321 text " ; fmul ", greg src2 1, text ",%st(0)",
1325 pprInstr g@(GSUB sz src1 src2 dst)
1327 = pprG g (text "\t#GSUB-xxxcase1" $$
1328 hcat [gtab, gpush src2 0,
1329 text " ; fsubrp %st(0),", greg src1 1])
1331 = pprG g (text "\t#GSUB-xxxcase2" $$
1332 hcat [gtab, gpush src1 0,
1333 text " ; fsubp %st(0),", greg src2 1])
1335 = pprG g (hcat [gtab, gpush src1 0,
1336 text " ; fsub ", greg src2 1, text ",%st(0)",
1340 pprInstr g@(GDIV sz src1 src2 dst)
1342 = pprG g (text "\t#GDIV-xxxcase1" $$
1343 hcat [gtab, gpush src2 0,
1344 text " ; fdivrp %st(0),", greg src1 1])
1346 = pprG g (text "\t#GDIV-xxxcase2" $$
1347 hcat [gtab, gpush src1 0,
1348 text " ; fdivp %st(0),", greg src2 1])
1350 = pprG g (hcat [gtab, gpush src1 0,
1351 text " ; fdiv ", greg src2 1, text ",%st(0)",
1356 = vcat [ ptext SLIT("\tffree %st(0) ;ffree %st(1) ;ffree %st(2) ;ffree %st(3)"),
1357 ptext SLIT("\tffree %st(4) ;ffree %st(5) ;ffree %st(6) ;ffree %st(7)")
1360 pprInstr (FETCHGOT reg)
1361 = vcat [ ptext SLIT("\tcall 1f"),
1362 hcat [ ptext SLIT("1:\tpopl\t"), pprReg I32 reg ],
1363 hcat [ ptext SLIT("\taddl\t$_GLOBAL_OFFSET_TABLE_+(.-1b), "),
1367 -- Emit code to make hi_reg:lo_reg be the 64-bit product of hi_reg and lo_reg
1368 pprInstr_imul64 hi_reg lo_reg
1369 = let fakeInsn = text "imul64" <+> pp_hi_reg <> comma <+> pp_lo_reg
1370 pp_hi_reg = pprReg I32 hi_reg
1371 pp_lo_reg = pprReg I32 lo_reg
1374 text "\t# BEGIN " <> fakeInsn,
1375 text "\tpushl" <+> pp_hi_reg <> text" ; pushl" <+> pp_lo_reg,
1376 text "\tpushl %eax ; pushl %edx",
1377 text "\tmovl 12(%esp), %eax ; imull 8(%esp)",
1378 text "\tmovl %edx, 12(%esp) ; movl %eax, 8(%esp)",
1379 text "\tpopl %edx ; popl %eax",
1380 text "\tpopl" <+> pp_lo_reg <> text " ; popl" <+> pp_hi_reg,
1381 text "\t# END " <> fakeInsn
1385 --------------------------
1387 -- coerce %st(0) to the specified size
1388 gcoerceto F64 = empty
1389 gcoerceto F32 = empty --text "subl $4,%esp ; fstps (%esp) ; flds (%esp) ; addl $4,%esp ; "
1392 = hcat [text "ffree %st(7) ; fld ", greg reg offset]
1394 = hcat [text "fstp ", greg reg offset]
1396 greg reg offset = text "%st(" <> int (gregno reg - 8+offset) <> char ')'
1401 gregno (RealReg i) = i
1402 gregno other = --pprPanic "gregno" (ppr other)
1403 999 -- bogus; only needed for debug printing
1405 pprG :: Instr -> Doc -> Doc
1407 = (char '#' <> pprGInstr fake) $$ actual
1409 pprGInstr (GMOV src dst) = pprSizeRegReg SLIT("gmov") F64 src dst
1410 pprGInstr (GLD sz src dst) = pprSizeAddrReg SLIT("gld") sz src dst
1411 pprGInstr (GST sz src dst) = pprSizeRegAddr SLIT("gst") sz src dst
1413 pprGInstr (GLDZ dst) = pprSizeReg SLIT("gldz") F64 dst
1414 pprGInstr (GLD1 dst) = pprSizeReg SLIT("gld1") F64 dst
1416 pprGInstr (GFTOI src dst) = pprSizeSizeRegReg SLIT("gftoi") F32 I32 src dst
1417 pprGInstr (GDTOI src dst) = pprSizeSizeRegReg SLIT("gdtoi") F64 I32 src dst
1419 pprGInstr (GITOF src dst) = pprSizeSizeRegReg SLIT("gitof") I32 F32 src dst
1420 pprGInstr (GITOD src dst) = pprSizeSizeRegReg SLIT("gitod") I32 F64 src dst
1422 pprGInstr (GCMP co src dst) = pprCondRegReg SLIT("gcmp_") F64 co src dst
1423 pprGInstr (GABS sz src dst) = pprSizeRegReg SLIT("gabs") sz src dst
1424 pprGInstr (GNEG sz src dst) = pprSizeRegReg SLIT("gneg") sz src dst
1425 pprGInstr (GSQRT sz src dst) = pprSizeRegReg SLIT("gsqrt") sz src dst
1426 pprGInstr (GSIN sz src dst) = pprSizeRegReg SLIT("gsin") sz src dst
1427 pprGInstr (GCOS sz src dst) = pprSizeRegReg SLIT("gcos") sz src dst
1428 pprGInstr (GTAN sz src dst) = pprSizeRegReg SLIT("gtan") sz src dst
1430 pprGInstr (GADD sz src1 src2 dst) = pprSizeRegRegReg SLIT("gadd") sz src1 src2 dst
1431 pprGInstr (GSUB sz src1 src2 dst) = pprSizeRegRegReg SLIT("gsub") sz src1 src2 dst
1432 pprGInstr (GMUL sz src1 src2 dst) = pprSizeRegRegReg SLIT("gmul") sz src1 src2 dst
1433 pprGInstr (GDIV sz src1 src2 dst) = pprSizeRegRegReg SLIT("gdiv") sz src1 src2 dst
1435 -- Continue with I386-only printing bits and bobs:
1437 pprDollImm :: Imm -> Doc
1439 pprDollImm i = ptext SLIT("$") <> pprImm i
1441 pprOperand :: MachRep -> Operand -> Doc
1442 pprOperand s (OpReg r) = pprReg s r
1443 pprOperand s (OpImm i) = pprDollImm i
1444 pprOperand s (OpAddr ea) = pprAddr ea
1446 pprMnemonic :: LitString -> MachRep -> Doc
1447 pprMnemonic name size =
1448 char '\t' <> ptext name <> pprSize size <> space
1450 pprSizeImmOp :: LitString -> MachRep -> Imm -> Operand -> Doc
1451 pprSizeImmOp name size imm op1
1453 pprMnemonic name size,
1460 pprSizeOp :: LitString -> MachRep -> Operand -> Doc
1461 pprSizeOp name size op1
1463 pprMnemonic name size,
1467 pprSizeOpOp :: LitString -> MachRep -> Operand -> Operand -> Doc
1468 pprSizeOpOp name size op1 op2
1470 pprMnemonic name size,
1471 pprOperand size op1,
1476 pprSizeReg :: LitString -> MachRep -> Reg -> Doc
1477 pprSizeReg name size reg1
1479 pprMnemonic name size,
1483 pprSizeRegReg :: LitString -> MachRep -> Reg -> Reg -> Doc
1484 pprSizeRegReg name size reg1 reg2
1486 pprMnemonic name size,
1492 pprCondRegReg :: LitString -> MachRep -> Cond -> Reg -> Reg -> Doc
1493 pprCondRegReg name size cond reg1 reg2
1504 pprSizeSizeRegReg :: LitString -> MachRep -> MachRep -> Reg -> Reg -> Doc
1505 pprSizeSizeRegReg name size1 size2 reg1 reg2
1518 pprSizeRegRegReg :: LitString -> MachRep -> Reg -> Reg -> Reg -> Doc
1519 pprSizeRegRegReg name size reg1 reg2 reg3
1521 pprMnemonic name size,
1529 pprSizeAddrReg :: LitString -> MachRep -> AddrMode -> Reg -> Doc
1530 pprSizeAddrReg name size op dst
1532 pprMnemonic name size,
1538 pprSizeRegAddr :: LitString -> MachRep -> Reg -> AddrMode -> Doc
1539 pprSizeRegAddr name size src op
1541 pprMnemonic name size,
1547 pprShift :: LitString -> MachRep -> Operand -> Operand -> Doc
1548 pprShift name size src dest
1550 pprMnemonic name size,
1551 pprOperand I8 src, -- src is 8-bit sized
1553 pprOperand size dest
1556 pprSizeOpOpCoerce :: LitString -> MachRep -> MachRep -> Operand -> Operand -> Doc
1557 pprSizeOpOpCoerce name size1 size2 op1 op2
1558 = hcat [ char '\t', ptext name, pprSize size1, pprSize size2, space,
1559 pprOperand size1 op1,
1561 pprOperand size2 op2
1564 pprCondInstr :: LitString -> Cond -> Doc -> Doc
1565 pprCondInstr name cond arg
1566 = hcat [ char '\t', ptext name, pprCond cond, space, arg]
1568 #endif /* i386_TARGET_ARCH */
1571 -- ------------------------------------------------------------------------------- pprInstr for a SPARC
1573 #if sparc_TARGET_ARCH
1575 -- a clumsy hack for now, to handle possible double alignment problems
1577 -- even clumsier, to allow for RegReg regs that show when doing indexed
1578 -- reads (bytearrays).
1581 -- Translate to the following:
1584 -- ld [g1+4],%f(n+1)
1585 -- sub g1,g2,g1 -- to restore g1
1586 pprInstr (LD DF (AddrRegReg g1 g2) reg)
1588 hcat [ptext SLIT("\tadd\t"), pprReg g1,comma,pprReg g2,comma,pprReg g1],
1589 hcat [pp_ld_lbracket, pprReg g1, pp_rbracket_comma, pprReg reg],
1590 hcat [pp_ld_lbracket, pprReg g1, ptext SLIT("+4]"), comma, pprReg (fPair reg)],
1591 hcat [ptext SLIT("\tsub\t"), pprReg g1,comma,pprReg g2,comma,pprReg g1]
1596 -- ld [addr+4],%f(n+1)
1597 pprInstr (LD DF addr reg) | isJust off_addr
1599 hcat [pp_ld_lbracket, pprAddr addr, pp_rbracket_comma, pprReg reg],
1600 hcat [pp_ld_lbracket, pprAddr addr2, pp_rbracket_comma,pprReg (fPair reg)]
1603 off_addr = addrOffset addr 4
1604 addr2 = case off_addr of Just x -> x
1607 pprInstr (LD size addr reg)
1618 -- The same clumsy hack as above
1620 -- Translate to the following:
1623 -- st %f(n+1),[g1+4]
1624 -- sub g1,g2,g1 -- to restore g1
1625 pprInstr (ST DF reg (AddrRegReg g1 g2))
1627 hcat [ptext SLIT("\tadd\t"), pprReg g1,comma,pprReg g2,comma,pprReg g1],
1628 hcat [ptext SLIT("\tst\t"), pprReg reg, pp_comma_lbracket,
1630 hcat [ptext SLIT("\tst\t"), pprReg (fPair reg), pp_comma_lbracket,
1631 pprReg g1, ptext SLIT("+4]")],
1632 hcat [ptext SLIT("\tsub\t"), pprReg g1,comma,pprReg g2,comma,pprReg g1]
1637 -- st %f(n+1),[addr+4]
1638 pprInstr (ST DF reg addr) | isJust off_addr
1640 hcat [ptext SLIT("\tst\t"), pprReg reg, pp_comma_lbracket,
1641 pprAddr addr, rbrack],
1642 hcat [ptext SLIT("\tst\t"), pprReg (fPair reg), pp_comma_lbracket,
1643 pprAddr addr2, rbrack]
1646 off_addr = addrOffset addr 4
1647 addr2 = case off_addr of Just x -> x
1649 -- no distinction is made between signed and unsigned bytes on stores for the
1650 -- Sparc opcodes (at least I cannot see any, and gas is nagging me --SOF),
1651 -- so we call a special-purpose pprSize for ST..
1653 pprInstr (ST size reg addr)
1664 pprInstr (ADD x cc reg1 ri reg2)
1665 | not x && not cc && riZero ri
1666 = hcat [ ptext SLIT("\tmov\t"), pprReg reg1, comma, pprReg reg2 ]
1668 = pprRegRIReg (if x then SLIT("addx") else SLIT("add")) cc reg1 ri reg2
1670 pprInstr (SUB x cc reg1 ri reg2)
1671 | not x && cc && reg2 == g0
1672 = hcat [ ptext SLIT("\tcmp\t"), pprReg reg1, comma, pprRI ri ]
1673 | not x && not cc && riZero ri
1674 = hcat [ ptext SLIT("\tmov\t"), pprReg reg1, comma, pprReg reg2 ]
1676 = pprRegRIReg (if x then SLIT("subx") else SLIT("sub")) cc reg1 ri reg2
1678 pprInstr (AND b reg1 ri reg2) = pprRegRIReg SLIT("and") b reg1 ri reg2
1679 pprInstr (ANDN b reg1 ri reg2) = pprRegRIReg SLIT("andn") b reg1 ri reg2
1681 pprInstr (OR b reg1 ri reg2)
1682 | not b && reg1 == g0
1683 = let doit = hcat [ ptext SLIT("\tmov\t"), pprRI ri, comma, pprReg reg2 ]
1685 RIReg rrr | rrr == reg2 -> empty
1688 = pprRegRIReg SLIT("or") b reg1 ri reg2
1690 pprInstr (ORN b reg1 ri reg2) = pprRegRIReg SLIT("orn") b reg1 ri reg2
1692 pprInstr (XOR b reg1 ri reg2) = pprRegRIReg SLIT("xor") b reg1 ri reg2
1693 pprInstr (XNOR b reg1 ri reg2) = pprRegRIReg SLIT("xnor") b reg1 ri reg2
1695 pprInstr (SLL reg1 ri reg2) = pprRegRIReg SLIT("sll") False reg1 ri reg2
1696 pprInstr (SRL reg1 ri reg2) = pprRegRIReg SLIT("srl") False reg1 ri reg2
1697 pprInstr (SRA reg1 ri reg2) = pprRegRIReg SLIT("sra") False reg1 ri reg2
1699 pprInstr (RDY rd) = ptext SLIT("\trd\t%y,") <> pprReg rd
1700 pprInstr (SMUL b reg1 ri reg2) = pprRegRIReg SLIT("smul") b reg1 ri reg2
1701 pprInstr (UMUL b reg1 ri reg2) = pprRegRIReg SLIT("umul") b reg1 ri reg2
1703 pprInstr (SETHI imm reg)
1705 ptext SLIT("\tsethi\t"),
1711 pprInstr NOP = ptext SLIT("\tnop")
1713 pprInstr (FABS F reg1 reg2) = pprSizeRegReg SLIT("fabs") F reg1 reg2
1714 pprInstr (FABS DF reg1 reg2)
1715 = (<>) (pprSizeRegReg SLIT("fabs") F reg1 reg2)
1716 (if (reg1 == reg2) then empty
1717 else (<>) (char '\n')
1718 (pprSizeRegReg SLIT("fmov") F (fPair reg1) (fPair reg2)))
1720 pprInstr (FADD size reg1 reg2 reg3)
1721 = pprSizeRegRegReg SLIT("fadd") size reg1 reg2 reg3
1722 pprInstr (FCMP e size reg1 reg2)
1723 = pprSizeRegReg (if e then SLIT("fcmpe") else SLIT("fcmp")) size reg1 reg2
1724 pprInstr (FDIV size reg1 reg2 reg3)
1725 = pprSizeRegRegReg SLIT("fdiv") size reg1 reg2 reg3
1727 pprInstr (FMOV F reg1 reg2) = pprSizeRegReg SLIT("fmov") F reg1 reg2
1728 pprInstr (FMOV DF reg1 reg2)
1729 = (<>) (pprSizeRegReg SLIT("fmov") F reg1 reg2)
1730 (if (reg1 == reg2) then empty
1731 else (<>) (char '\n')
1732 (pprSizeRegReg SLIT("fmov") F (fPair reg1) (fPair reg2)))
1734 pprInstr (FMUL size reg1 reg2 reg3)
1735 = pprSizeRegRegReg SLIT("fmul") size reg1 reg2 reg3
1737 pprInstr (FNEG F reg1 reg2) = pprSizeRegReg SLIT("fneg") F reg1 reg2
1738 pprInstr (FNEG DF reg1 reg2)
1739 = (<>) (pprSizeRegReg SLIT("fneg") F reg1 reg2)
1740 (if (reg1 == reg2) then empty
1741 else (<>) (char '\n')
1742 (pprSizeRegReg SLIT("fmov") F (fPair reg1) (fPair reg2)))
1744 pprInstr (FSQRT size reg1 reg2) = pprSizeRegReg SLIT("fsqrt") size reg1 reg2
1745 pprInstr (FSUB size reg1 reg2 reg3) = pprSizeRegRegReg SLIT("fsub") size reg1 reg2 reg3
1746 pprInstr (FxTOy size1 size2 reg1 reg2)
1759 pprReg reg1, comma, pprReg reg2
1763 pprInstr (BI cond b lab)
1765 ptext SLIT("\tb"), pprCond cond,
1766 if b then pp_comma_a else empty,
1771 pprInstr (BF cond b lab)
1773 ptext SLIT("\tfb"), pprCond cond,
1774 if b then pp_comma_a else empty,
1779 pprInstr (JMP dsts addr) = (<>) (ptext SLIT("\tjmp\t")) (pprAddr addr)
1781 pprInstr (CALL (Left imm) n _)
1782 = hcat [ ptext SLIT("\tcall\t"), pprImm imm, comma, int n ]
1783 pprInstr (CALL (Right reg) n _)
1784 = hcat [ ptext SLIT("\tcall\t"), pprReg reg, comma, int n ]
1787 Continue with SPARC-only printing bits and bobs:
1790 pprRI (RIReg r) = pprReg r
1791 pprRI (RIImm r) = pprImm r
1793 pprSizeRegReg :: LitString -> Size -> Reg -> Reg -> Doc
1794 pprSizeRegReg name size reg1 reg2
1799 F -> ptext SLIT("s\t")
1800 DF -> ptext SLIT("d\t")),
1806 pprSizeRegRegReg :: LitString -> Size -> Reg -> Reg -> Reg -> Doc
1807 pprSizeRegRegReg name size reg1 reg2 reg3
1812 F -> ptext SLIT("s\t")
1813 DF -> ptext SLIT("d\t")),
1821 pprRegRIReg :: LitString -> Bool -> Reg -> RI -> Reg -> Doc
1822 pprRegRIReg name b reg1 ri reg2
1826 if b then ptext SLIT("cc\t") else char '\t',
1834 pprRIReg :: LitString -> Bool -> RI -> Reg -> Doc
1835 pprRIReg name b ri reg1
1839 if b then ptext SLIT("cc\t") else char '\t',
1845 pp_ld_lbracket = ptext SLIT("\tld\t[")
1846 pp_rbracket_comma = text "],"
1847 pp_comma_lbracket = text ",["
1848 pp_comma_a = text ",a"
1850 #endif /* sparc_TARGET_ARCH */
1853 -- -----------------------------------------------------------------------------
1854 -- pprInstr for PowerPC
1856 #if powerpc_TARGET_ARCH
1857 pprInstr (LD sz reg addr) = hcat [
1866 case addr of AddrRegImm _ _ -> empty
1867 AddrRegReg _ _ -> char 'x',
1873 pprInstr (LA sz reg addr) = hcat [
1882 case addr of AddrRegImm _ _ -> empty
1883 AddrRegReg _ _ -> char 'x',
1889 pprInstr (ST sz reg addr) = hcat [
1893 case addr of AddrRegImm _ _ -> empty
1894 AddrRegReg _ _ -> char 'x',
1900 pprInstr (STU sz reg addr) = hcat [
1905 case addr of AddrRegImm _ _ -> empty
1906 AddrRegReg _ _ -> char 'x',
1911 pprInstr (LIS reg imm) = hcat [
1919 pprInstr (LI reg imm) = hcat [
1927 pprInstr (MR reg1 reg2)
1928 | reg1 == reg2 = empty
1929 | otherwise = hcat [
1931 case regClass reg1 of
1932 RcInteger -> ptext SLIT("mr")
1933 _ -> ptext SLIT("fmr"),
1939 pprInstr (CMP sz reg ri) = hcat [
1955 pprInstr (CMPL sz reg ri) = hcat [
1971 pprInstr (BCC cond (BlockId id)) = hcat [
1978 where lbl = mkAsmTempLabel id
1980 pprInstr (JMP lbl) = hcat [ -- an alias for b that takes a CLabel
1987 pprInstr (MTCTR reg) = hcat [
1989 ptext SLIT("mtctr"),
1993 pprInstr (BCTR _) = hcat [
1997 pprInstr (BL lbl _) = hcat [
1998 ptext SLIT("\tbl\t"),
2001 pprInstr (BCTRL _) = hcat [
2005 pprInstr (ADD reg1 reg2 ri) = pprLogic SLIT("add") reg1 reg2 ri
2006 pprInstr (ADDIS reg1 reg2 imm) = hcat [
2008 ptext SLIT("addis"),
2017 pprInstr (ADDC reg1 reg2 reg3) = pprLogic SLIT("addc") reg1 reg2 (RIReg reg3)
2018 pprInstr (ADDE reg1 reg2 reg3) = pprLogic SLIT("adde") reg1 reg2 (RIReg reg3)
2019 pprInstr (SUBF reg1 reg2 reg3) = pprLogic SLIT("subf") reg1 reg2 (RIReg reg3)
2020 pprInstr (MULLW reg1 reg2 ri@(RIReg _)) = pprLogic SLIT("mullw") reg1 reg2 ri
2021 pprInstr (MULLW reg1 reg2 ri@(RIImm _)) = pprLogic SLIT("mull") reg1 reg2 ri
2022 pprInstr (DIVW reg1 reg2 reg3) = pprLogic SLIT("divw") reg1 reg2 (RIReg reg3)
2023 pprInstr (DIVWU reg1 reg2 reg3) = pprLogic SLIT("divwu") reg1 reg2 (RIReg reg3)
2025 pprInstr (MULLW_MayOflo reg1 reg2 reg3) = vcat [
2026 hcat [ ptext SLIT("\tmullwo\t"), pprReg reg1, ptext SLIT(", "),
2027 pprReg reg2, ptext SLIT(", "),
2029 hcat [ ptext SLIT("\tmfxer\t"), pprReg reg1 ],
2030 hcat [ ptext SLIT("\trlwinm\t"), pprReg reg1, ptext SLIT(", "),
2031 pprReg reg1, ptext SLIT(", "),
2032 ptext SLIT("2, 31, 31") ]
2035 -- for some reason, "andi" doesn't exist.
2036 -- we'll use "andi." instead.
2037 pprInstr (AND reg1 reg2 (RIImm imm)) = hcat [
2039 ptext SLIT("andi."),
2047 pprInstr (AND reg1 reg2 ri) = pprLogic SLIT("and") reg1 reg2 ri
2049 pprInstr (OR reg1 reg2 ri) = pprLogic SLIT("or") reg1 reg2 ri
2050 pprInstr (XOR reg1 reg2 ri) = pprLogic SLIT("xor") reg1 reg2 ri
2052 pprInstr (XORIS reg1 reg2 imm) = hcat [
2054 ptext SLIT("xoris"),
2063 pprInstr (EXTS sz reg1 reg2) = hcat [
2073 pprInstr (NEG reg1 reg2) = pprUnary SLIT("neg") reg1 reg2
2074 pprInstr (NOT reg1 reg2) = pprUnary SLIT("not") reg1 reg2
2076 pprInstr (SLW reg1 reg2 ri) = pprLogic SLIT("slw") reg1 reg2 (limitShiftRI ri)
2077 pprInstr (SRW reg1 reg2 ri) = pprLogic SLIT("srw") reg1 reg2 (limitShiftRI ri)
2078 pprInstr (SRAW reg1 reg2 ri) = pprLogic SLIT("sraw") reg1 reg2 (limitShiftRI ri)
2079 pprInstr (RLWINM reg1 reg2 sh mb me) = hcat [
2080 ptext SLIT("\trlwinm\t"),
2092 pprInstr (FADD sz reg1 reg2 reg3) = pprBinaryF SLIT("fadd") sz reg1 reg2 reg3
2093 pprInstr (FSUB sz reg1 reg2 reg3) = pprBinaryF SLIT("fsub") sz reg1 reg2 reg3
2094 pprInstr (FMUL sz reg1 reg2 reg3) = pprBinaryF SLIT("fmul") sz reg1 reg2 reg3
2095 pprInstr (FDIV sz reg1 reg2 reg3) = pprBinaryF SLIT("fdiv") sz reg1 reg2 reg3
2096 pprInstr (FNEG reg1 reg2) = pprUnary SLIT("fneg") reg1 reg2
2098 pprInstr (FCMP reg1 reg2) = hcat [
2100 ptext SLIT("fcmpu\tcr0, "),
2101 -- Note: we're using fcmpu, not fcmpo
2102 -- The difference is with fcmpo, compare with NaN is an invalid operation.
2103 -- We don't handle invalid fp ops, so we don't care
2109 pprInstr (FCTIWZ reg1 reg2) = pprUnary SLIT("fctiwz") reg1 reg2
2110 pprInstr (FRSP reg1 reg2) = pprUnary SLIT("frsp") reg1 reg2
2112 pprInstr (CRNOR dst src1 src2) = hcat [
2113 ptext SLIT("\tcrnor\t"),
2121 pprInstr (MFCR reg) = hcat [
2128 pprInstr (MFLR reg) = hcat [
2135 pprInstr (FETCHPC reg) = vcat [
2136 ptext SLIT("\tbcl\t20,31,1f"),
2137 hcat [ ptext SLIT("1:\tmflr\t"), pprReg reg ]
2140 pprInstr _ = panic "pprInstr (ppc)"
2142 pprLogic op reg1 reg2 ri = hcat [
2147 RIImm _ -> char 'i',
2156 pprUnary op reg1 reg2 = hcat [
2165 pprBinaryF op sz reg1 reg2 reg3 = hcat [
2178 pprRI (RIReg r) = pprReg r
2179 pprRI (RIImm r) = pprImm r
2181 pprFSize F64 = empty
2182 pprFSize F32 = char 's'
2184 -- limit immediate argument for shift instruction to range 0..32
2185 -- (yes, the maximum is really 32, not 31)
2186 limitShiftRI :: RI -> RI
2187 limitShiftRI (RIImm (ImmInt i)) | i > 32 || i < 0 = RIImm (ImmInt 32)
2190 #endif /* powerpc_TARGET_ARCH */
2193 -- -----------------------------------------------------------------------------
2194 -- Converting floating-point literals to integrals for printing
2196 #if __GLASGOW_HASKELL__ >= 504
2197 newFloatArray :: (Int,Int) -> ST s (STUArray s Int Float)
2198 newFloatArray = newArray_
2200 newDoubleArray :: (Int,Int) -> ST s (STUArray s Int Double)
2201 newDoubleArray = newArray_
2203 castFloatToCharArray :: STUArray s Int Float -> ST s (STUArray s Int Word8)
2204 castFloatToCharArray = castSTUArray
2206 castDoubleToCharArray :: STUArray s Int Double -> ST s (STUArray s Int Word8)
2207 castDoubleToCharArray = castSTUArray
2209 writeFloatArray :: STUArray s Int Float -> Int -> Float -> ST s ()
2210 writeFloatArray = writeArray
2212 writeDoubleArray :: STUArray s Int Double -> Int -> Double -> ST s ()
2213 writeDoubleArray = writeArray
2215 readCharArray :: STUArray s Int Word8 -> Int -> ST s Char
2216 readCharArray arr i = do
2217 w <- readArray arr i
2218 return $! (chr (fromIntegral w))
2222 castFloatToCharArray :: MutableByteArray s t -> ST s (MutableByteArray s t)
2223 castFloatToCharArray = return
2225 castDoubleToCharArray :: MutableByteArray s t -> ST s (MutableByteArray s t)
2228 castDoubleToCharArray = return
2232 -- floatToBytes and doubleToBytes convert to the host's byte
2233 -- order. Providing that we're not cross-compiling for a
2234 -- target with the opposite endianness, this should work ok
2237 -- ToDo: this stuff is very similar to the shenanigans in PprAbs,
2238 -- could they be merged?
2240 floatToBytes :: Float -> [Int]
2243 arr <- newFloatArray ((0::Int),3)
2244 writeFloatArray arr 0 f
2245 arr <- castFloatToCharArray arr
2246 i0 <- readCharArray arr 0
2247 i1 <- readCharArray arr 1
2248 i2 <- readCharArray arr 2
2249 i3 <- readCharArray arr 3
2250 return (map ord [i0,i1,i2,i3])
2253 doubleToBytes :: Double -> [Int]
2256 arr <- newDoubleArray ((0::Int),7)
2257 writeDoubleArray arr 0 d
2258 arr <- castDoubleToCharArray arr
2259 i0 <- readCharArray arr 0
2260 i1 <- readCharArray arr 1
2261 i2 <- readCharArray arr 2
2262 i3 <- readCharArray arr 3
2263 i4 <- readCharArray arr 4
2264 i5 <- readCharArray arr 5
2265 i6 <- readCharArray arr 6
2266 i7 <- readCharArray arr 7
2267 return (map ord [i0,i1,i2,i3,i4,i5,i6,i7])