1 -----------------------------------------------------------------------------
3 -- Pretty-printing assembly language
5 -- (c) The University of Glasgow 1993-2005
7 -----------------------------------------------------------------------------
20 #include "HsVersions.h"
21 #include "nativeGen/NCG.h"
33 import Panic ( panic )
34 import Unique ( pprUnique )
39 -- | Pretty print a register.
40 -- This is an alias of pprReg for legacy reasons, should remove it.
41 pprUserReg :: Reg -> Doc
45 -- | Pretty print a register.
49 RealReg i -> pprReg_ofRegNo i
50 VirtualRegI u -> text "%vI_" <> asmSDoc (pprUnique u)
51 VirtualRegHi u -> text "%vHi_" <> asmSDoc (pprUnique u)
52 VirtualRegF u -> text "%vF_" <> asmSDoc (pprUnique u)
53 VirtualRegD u -> text "%vD_" <> asmSDoc (pprUnique u)
56 -- | Pretty print a register name, based on this register number.
57 -- The definition has been unfolded so we get a jump-table in the
58 -- object code. This function is called quite a lot when emitting the asm file..
60 pprReg_ofRegNo :: Int -> Doc
64 0 -> sLit "%g0"; 1 -> sLit "%g1";
65 2 -> sLit "%g2"; 3 -> sLit "%g3";
66 4 -> sLit "%g4"; 5 -> sLit "%g5";
67 6 -> sLit "%g6"; 7 -> sLit "%g7";
68 8 -> sLit "%o0"; 9 -> sLit "%o1";
69 10 -> sLit "%o2"; 11 -> sLit "%o3";
70 12 -> sLit "%o4"; 13 -> sLit "%o5";
71 14 -> sLit "%o6"; 15 -> sLit "%o7";
72 16 -> sLit "%l0"; 17 -> sLit "%l1";
73 18 -> sLit "%l2"; 19 -> sLit "%l3";
74 20 -> sLit "%l4"; 21 -> sLit "%l5";
75 22 -> sLit "%l6"; 23 -> sLit "%l7";
76 24 -> sLit "%i0"; 25 -> sLit "%i1";
77 26 -> sLit "%i2"; 27 -> sLit "%i3";
78 28 -> sLit "%i4"; 29 -> sLit "%i5";
79 30 -> sLit "%i6"; 31 -> sLit "%i7";
80 32 -> sLit "%f0"; 33 -> sLit "%f1";
81 34 -> sLit "%f2"; 35 -> sLit "%f3";
82 36 -> sLit "%f4"; 37 -> sLit "%f5";
83 38 -> sLit "%f6"; 39 -> sLit "%f7";
84 40 -> sLit "%f8"; 41 -> sLit "%f9";
85 42 -> sLit "%f10"; 43 -> sLit "%f11";
86 44 -> sLit "%f12"; 45 -> sLit "%f13";
87 46 -> sLit "%f14"; 47 -> sLit "%f15";
88 48 -> sLit "%f16"; 49 -> sLit "%f17";
89 50 -> sLit "%f18"; 51 -> sLit "%f19";
90 52 -> sLit "%f20"; 53 -> sLit "%f21";
91 54 -> sLit "%f22"; 55 -> sLit "%f23";
92 56 -> sLit "%f24"; 57 -> sLit "%f25";
93 58 -> sLit "%f26"; 59 -> sLit "%f27";
94 60 -> sLit "%f28"; 61 -> sLit "%f29";
95 62 -> sLit "%f30"; 63 -> sLit "%f31";
96 _ -> sLit "very naughty sparc register" })
99 -- | Pretty print a size for an instruction suffix.
100 pprSize :: Size -> Doc
112 -- | Pretty print a size for an instruction suffix.
113 -- eg LD is 32bit on sparc, but LDD is 64 bit.
114 pprStSize :: Size -> Doc
126 -- | Pretty print a condition code.
127 pprCond :: Cond -> Doc
149 -- | Pretty print an address mode.
150 pprAddr :: AddrMode -> Doc
153 AddrRegReg r1 (RealReg 0)
157 -> hcat [ pprReg r1, char '+', pprReg r2 ]
159 AddrRegImm r1 (ImmInt i)
160 | i == 0 -> pprReg r1
161 | not (fits13Bits i) -> largeOffsetError i
162 | otherwise -> hcat [ pprReg r1, pp_sign, int i ]
164 pp_sign = if i > 0 then char '+' else empty
166 AddrRegImm r1 (ImmInteger i)
167 | i == 0 -> pprReg r1
168 | not (fits13Bits i) -> largeOffsetError i
169 | otherwise -> hcat [ pprReg r1, pp_sign, integer i ]
171 pp_sign = if i > 0 then char '+' else empty
174 -> hcat [ pprReg r1, char '+', pprImm imm ]
177 -- | Pretty print an immediate value.
182 ImmInteger i -> integer i
183 ImmCLbl l -> pprCLabel_asm l
184 ImmIndex l i -> pprCLabel_asm l <> char '+' <> int i
188 -> pprImm a <> char '+' <> pprImm b
191 -> pprImm a <> char '-' <> lparen <> pprImm b <> rparen
194 -> hcat [ text "%lo(", pprImm i, rparen ]
197 -> hcat [ text "%hi(", pprImm i, rparen ]
199 -- these should have been converted to bytes and placed
200 -- in the data section.
201 ImmFloat _ -> ptext (sLit "naughty float immediate")
202 ImmDouble _ -> ptext (sLit "naughty double immediate")
205 -- | Pretty print a section \/ segment header.
206 -- On SPARC all the data sections must be at least 8 byte aligned
207 -- incase we store doubles in them.
209 pprSectionHeader :: Section -> Doc
212 Text -> ptext (sLit ".text\n\t.align 4")
213 Data -> ptext (sLit ".data\n\t.align 8")
214 ReadOnlyData -> ptext (sLit ".text\n\t.align 8")
215 RelocatableReadOnlyData -> ptext (sLit ".text\n\t.align 8")
216 UninitialisedData -> ptext (sLit ".bss\n\t.align 8")
217 ReadOnlyData16 -> ptext (sLit ".data\n\t.align 16")
218 OtherSection _ -> panic "PprMach.pprSectionHeader: unknown section"
221 -- | Pretty print a data item.
222 pprDataItem :: CmmLit -> Doc
224 = vcat (ppr_item (cmmTypeSize $ cmmLitType lit) lit)
228 ppr_item II8 _ = [ptext (sLit "\t.byte\t") <> pprImm imm]
229 ppr_item II32 _ = [ptext (sLit "\t.long\t") <> pprImm imm]
231 ppr_item FF32 (CmmFloat r _)
232 = let bs = floatToBytes (fromRational r)
233 in map (\b -> ptext (sLit "\t.byte\t") <> pprImm (ImmInt b)) bs
235 ppr_item FF64 (CmmFloat r _)
236 = let bs = doubleToBytes (fromRational r)
237 in map (\b -> ptext (sLit "\t.byte\t") <> pprImm (ImmInt b)) bs
239 ppr_item II16 _ = [ptext (sLit "\t.short\t") <> pprImm imm]
240 ppr_item II64 _ = [ptext (sLit "\t.quad\t") <> pprImm imm]
241 ppr_item _ _ = panic "SPARC.Ppr.pprDataItem: no match"
244 -- | Pretty print an instruction.
245 pprInstr :: Instr -> Doc
252 = pprInstr (COMMENT (mkFastString ("\tdelta = " ++ show d)))
254 -- Newblocks and LData should have been slurped out before producing the .s file.
255 pprInstr (NEWBLOCK _)
256 = panic "X86.Ppr.pprInstr: NEWBLOCK"
259 = panic "PprMach.pprInstr: LDATA"
261 pprInstr (SPILL reg slot)
263 ptext (sLit "\tSPILL"),
267 ptext (sLit "SLOT") <> parens (int slot)]
269 pprInstr (RELOAD slot reg)
271 ptext (sLit "\tRELOAD"),
273 ptext (sLit "SLOT") <> parens (int slot),
278 -- a clumsy hack for now, to handle possible double alignment problems
279 -- even clumsier, to allow for RegReg regs that show when doing indexed
280 -- reads (bytearrays).
282 -- Translate to the following:
286 -- sub g1,g2,g1 -- to restore g1
288 pprInstr (LD FF64 (AddrRegReg g1 g2) reg)
289 = let Just regH = fPair reg
291 hcat [ptext (sLit "\tadd\t"), pprReg g1, comma, pprReg g2, comma, pprReg g1],
292 hcat [pp_ld_lbracket, pprReg g1, pp_rbracket_comma, pprReg reg],
293 hcat [pp_ld_lbracket, pprReg g1, ptext (sLit "+4]"), comma, pprReg regH],
294 hcat [ptext (sLit "\tsub\t"), pprReg g1, comma, pprReg g2, comma, pprReg g1]
299 -- ld [addr+4],%f(n+1)
300 pprInstr (LD FF64 addr reg)
301 = let Just addr2 = addrOffset addr 4
302 Just regH = fPair reg
304 hcat [pp_ld_lbracket, pprAddr addr, pp_rbracket_comma, pprReg reg],
305 hcat [pp_ld_lbracket, pprAddr addr2, pp_rbracket_comma,pprReg regH]
309 pprInstr (LD size addr reg)
320 -- The same clumsy hack as above
321 -- Translate to the following:
325 -- sub g1,g2,g1 -- to restore g1
327 pprInstr (ST FF64 reg (AddrRegReg g1 g2))
328 = let Just regH = fPair reg
330 hcat [ptext (sLit "\tadd\t"), pprReg g1, comma, pprReg g2, comma, pprReg g1],
331 hcat [ptext (sLit "\tst\t"), pprReg reg, pp_comma_lbracket,
333 hcat [ptext (sLit "\tst\t"), pprReg regH, pp_comma_lbracket,
334 pprReg g1, ptext (sLit "+4]")],
335 hcat [ptext (sLit "\tsub\t"), pprReg g1, comma, pprReg g2, comma, pprReg g1]
340 -- st %f(n+1),[addr+4]
341 pprInstr (ST FF64 reg addr)
342 = let Just addr2 = addrOffset addr 4
343 Just regH = fPair reg
345 hcat [ptext (sLit "\tst\t"), pprReg reg, pp_comma_lbracket,
346 pprAddr addr, rbrack],
347 hcat [ptext (sLit "\tst\t"), pprReg regH, pp_comma_lbracket,
348 pprAddr addr2, rbrack]
352 -- no distinction is made between signed and unsigned bytes on stores for the
353 -- Sparc opcodes (at least I cannot see any, and gas is nagging me --SOF),
354 -- so we call a special-purpose pprSize for ST..
355 pprInstr (ST size reg addr)
367 pprInstr (ADD x cc reg1 ri reg2)
368 | not x && not cc && riZero ri
369 = hcat [ ptext (sLit "\tmov\t"), pprReg reg1, comma, pprReg reg2 ]
372 = pprRegRIReg (if x then sLit "addx" else sLit "add") cc reg1 ri reg2
375 pprInstr (SUB x cc reg1 ri reg2)
376 | not x && cc && reg2 == g0
377 = hcat [ ptext (sLit "\tcmp\t"), pprReg reg1, comma, pprRI ri ]
379 | not x && not cc && riZero ri
380 = hcat [ ptext (sLit "\tmov\t"), pprReg reg1, comma, pprReg reg2 ]
383 = pprRegRIReg (if x then sLit "subx" else sLit "sub") cc reg1 ri reg2
385 pprInstr (AND b reg1 ri reg2) = pprRegRIReg (sLit "and") b reg1 ri reg2
387 pprInstr (ANDN b reg1 ri reg2) = pprRegRIReg (sLit "andn") b reg1 ri reg2
389 pprInstr (OR b reg1 ri reg2)
390 | not b && reg1 == g0
391 = let doit = hcat [ ptext (sLit "\tmov\t"), pprRI ri, comma, pprReg reg2 ]
393 RIReg rrr | rrr == reg2 -> empty
397 = pprRegRIReg (sLit "or") b reg1 ri reg2
399 pprInstr (ORN b reg1 ri reg2) = pprRegRIReg (sLit "orn") b reg1 ri reg2
401 pprInstr (XOR b reg1 ri reg2) = pprRegRIReg (sLit "xor") b reg1 ri reg2
402 pprInstr (XNOR b reg1 ri reg2) = pprRegRIReg (sLit "xnor") b reg1 ri reg2
404 pprInstr (SLL reg1 ri reg2) = pprRegRIReg (sLit "sll") False reg1 ri reg2
405 pprInstr (SRL reg1 ri reg2) = pprRegRIReg (sLit "srl") False reg1 ri reg2
406 pprInstr (SRA reg1 ri reg2) = pprRegRIReg (sLit "sra") False reg1 ri reg2
408 pprInstr (RDY rd) = ptext (sLit "\trd\t%y,") <> pprReg rd
409 pprInstr (WRY reg1 reg2)
410 = ptext (sLit "\twr\t")
417 pprInstr (SMUL b reg1 ri reg2) = pprRegRIReg (sLit "smul") b reg1 ri reg2
418 pprInstr (UMUL b reg1 ri reg2) = pprRegRIReg (sLit "umul") b reg1 ri reg2
419 pprInstr (SDIV b reg1 ri reg2) = pprRegRIReg (sLit "sdiv") b reg1 ri reg2
420 pprInstr (UDIV b reg1 ri reg2) = pprRegRIReg (sLit "udiv") b reg1 ri reg2
422 pprInstr (SETHI imm reg)
424 ptext (sLit "\tsethi\t"),
430 pprInstr NOP = ptext (sLit "\tnop")
432 pprInstr (FABS FF32 reg1 reg2) = pprSizeRegReg (sLit "fabs") FF32 reg1 reg2
433 pprInstr (FABS FF64 reg1 reg2)
434 = let Just reg1H = fPair reg1
435 Just reg2H = fPair reg2
437 (<>) (pprSizeRegReg (sLit "fabs") FF32 reg1 reg2)
438 (if (reg1 == reg2) then empty
439 else (<>) (char '\n')
440 (pprSizeRegReg (sLit "fmov") FF32 reg1H reg2H))
442 pprInstr (FABS _ _ _)
443 =panic "SPARC.Ppr.pprInstr(FABS): no match"
445 pprInstr (FADD size reg1 reg2 reg3)
446 = pprSizeRegRegReg (sLit "fadd") size reg1 reg2 reg3
448 pprInstr (FCMP e size reg1 reg2)
449 = pprSizeRegReg (if e then sLit "fcmpe" else sLit "fcmp") size reg1 reg2
451 pprInstr (FDIV size reg1 reg2 reg3)
452 = pprSizeRegRegReg (sLit "fdiv") size reg1 reg2 reg3
454 pprInstr (FMOV FF32 reg1 reg2) = pprSizeRegReg (sLit "fmov") FF32 reg1 reg2
455 pprInstr (FMOV FF64 reg1 reg2) = pprSizeRegReg (sLit "fmov") FF64 reg1 reg2
457 pprInstr (FMOV _ _ _)
458 = panic "SPARC.Ppr.pprInstr(FMOV): no match"
461 pprInstr (FMOV FF64 reg1 reg2)
462 = let Just reg1H = fPair reg1
463 Just reg2H = fPair reg2
465 (<>) (pprSizeRegReg (sLit "fmov") FF32 reg1 reg2)
466 (if (reg1 == reg2) then empty
467 else (<>) (char '\n')
468 (pprSizeRegReg (sLit "fmov") FF32 reg1H reg2H))
471 pprInstr (FMUL size reg1 reg2 reg3)
472 = pprSizeRegRegReg (sLit "fmul") size reg1 reg2 reg3
474 pprInstr (FNEG FF32 reg1 reg2)
475 = pprSizeRegReg (sLit "fneg") FF32 reg1 reg2
477 pprInstr (FNEG FF64 reg1 reg2)
478 = let Just reg1H = fPair reg1
479 Just reg2H = fPair reg2
481 (<>) (pprSizeRegReg (sLit "fneg") FF32 reg1 reg2)
482 (if (reg1 == reg2) then empty
483 else (<>) (char '\n')
484 (pprSizeRegReg (sLit "fmov") FF32 reg1H reg2H))
486 pprInstr (FNEG _ _ _)
487 = panic "SPARC.Ppr.pprInstr(FNEG): no match"
489 pprInstr (FSQRT size reg1 reg2)
490 = pprSizeRegReg (sLit "fsqrt") size reg1 reg2
492 pprInstr (FSUB size reg1 reg2 reg3)
493 = pprSizeRegRegReg (sLit "fsub") size reg1 reg2 reg3
495 pprInstr (FxTOy size1 size2 reg1 reg2)
503 _ -> panic "SPARC.Ppr.pprInstr.FxToY: no match"),
510 _ -> panic "SPARC.Ppr.pprInstr.FxToY: no match"),
511 pprReg reg1, comma, pprReg reg2
515 pprInstr (BI cond b (BlockId id))
517 ptext (sLit "\tb"), pprCond cond,
518 if b then pp_comma_a else empty,
520 pprCLabel_asm (mkAsmTempLabel id)
523 pprInstr (BF cond b (BlockId id))
525 ptext (sLit "\tfb"), pprCond cond,
526 if b then pp_comma_a else empty,
528 pprCLabel_asm (mkAsmTempLabel id)
531 pprInstr (JMP addr) = (<>) (ptext (sLit "\tjmp\t")) (pprAddr addr)
532 pprInstr (JMP_TBL op _) = pprInstr (JMP op)
534 pprInstr (CALL (Left imm) n _)
535 = hcat [ ptext (sLit "\tcall\t"), pprImm imm, comma, int n ]
536 pprInstr (CALL (Right reg) n _)
537 = hcat [ ptext (sLit "\tcall\t"), pprReg reg, comma, int n ]
540 -- | Pretty print a RI
542 pprRI (RIReg r) = pprReg r
543 pprRI (RIImm r) = pprImm r
546 -- | Pretty print a two reg instruction.
547 pprSizeRegReg :: LitString -> Size -> Reg -> Reg -> Doc
548 pprSizeRegReg name size reg1 reg2
553 FF32 -> ptext (sLit "s\t")
554 FF64 -> ptext (sLit "d\t")
555 _ -> panic "SPARC.Ppr.pprSizeRegReg: no match"),
563 -- | Pretty print a three reg instruction.
564 pprSizeRegRegReg :: LitString -> Size -> Reg -> Reg -> Reg -> Doc
565 pprSizeRegRegReg name size reg1 reg2 reg3
570 FF32 -> ptext (sLit "s\t")
571 FF64 -> ptext (sLit "d\t")
572 _ -> panic "SPARC.Ppr.pprSizeRegReg: no match"),
581 -- | Pretty print an instruction of two regs and a ri.
582 pprRegRIReg :: LitString -> Bool -> Reg -> RI -> Reg -> Doc
583 pprRegRIReg name b reg1 ri reg2
587 if b then ptext (sLit "cc\t") else char '\t',
596 pprRIReg :: LitString -> Bool -> RI -> Reg -> Doc
597 pprRIReg name b ri reg1
601 if b then ptext (sLit "cc\t") else char '\t',
609 pp_ld_lbracket :: Doc
610 pp_ld_lbracket = ptext (sLit "\tld\t[")
613 pp_rbracket_comma :: Doc
614 pp_rbracket_comma = text "],"
617 pp_comma_lbracket :: Doc
618 pp_comma_lbracket = text ",["
622 pp_comma_a = text ",a"