1 -----------------------------------------------------------------------------
3 -- Pretty-printing assembly language
5 -- (c) The University of Glasgow 1993-2005
7 -----------------------------------------------------------------------------
23 #include "HsVersions.h"
24 #include "nativeGen/NCG.h"
39 import Unique ( pprUnique )
40 import qualified Outputable
41 import Outputable (Outputable, panic)
46 -- -----------------------------------------------------------------------------
47 -- Printing this stuff out
49 pprNatCmmTop :: NatCmmTop Instr -> Doc
50 pprNatCmmTop (CmmData section dats) =
51 pprSectionHeader section $$ vcat (map pprData dats)
53 -- special case for split markers:
54 pprNatCmmTop (CmmProc [] lbl _ (ListGraph [])) = pprLabel lbl
56 pprNatCmmTop (CmmProc info lbl _ (ListGraph blocks)) =
57 pprSectionHeader Text $$
58 (if null info then -- blocks guaranteed not null, so label needed
61 #if HAVE_SUBSECTIONS_VIA_SYMBOLS
62 pprCLabel_asm (mkDeadStripPreventer $ entryLblToInfoLbl lbl)
65 vcat (map pprData info) $$
66 pprLabel (entryLblToInfoLbl lbl)
68 vcat (map pprBasicBlock blocks)
69 -- above: Even the first block gets a label, because with branch-chain
70 -- elimination, it might be the target of a goto.
71 #if HAVE_SUBSECTIONS_VIA_SYMBOLS
72 -- If we are using the .subsections_via_symbols directive
73 -- (available on recent versions of Darwin),
74 -- we have to make sure that there is some kind of reference
75 -- from the entry code to a label on the _top_ of of the info table,
76 -- so that the linker will not think it is unreferenced and dead-strip
77 -- it. That's why the label is called a DeadStripPreventer (_dsp).
80 <+> pprCLabel_asm (entryLblToInfoLbl lbl)
82 <+> pprCLabel_asm (mkDeadStripPreventer $ entryLblToInfoLbl lbl)
87 pprBasicBlock :: NatBasicBlock Instr -> Doc
88 pprBasicBlock (BasicBlock (BlockId id) instrs) =
89 pprLabel (mkAsmTempLabel id) $$
90 vcat (map pprInstr instrs)
93 pprData :: CmmStatic -> Doc
94 pprData (CmmAlign bytes) = pprAlign bytes
95 pprData (CmmDataLabel lbl) = pprLabel lbl
96 pprData (CmmString str) = pprASCII str
97 pprData (CmmUninitialised bytes) = ptext (sLit ".skip ") <> int bytes
98 pprData (CmmStaticLit lit) = pprDataItem lit
100 pprGloblDecl :: CLabel -> Doc
102 | not (externallyVisibleCLabel lbl) = empty
103 | otherwise = ptext IF_ARCH_sparc((sLit ".global "),
107 pprTypeAndSizeDecl :: CLabel -> Doc
109 pprTypeAndSizeDecl lbl
110 | not (externallyVisibleCLabel lbl) = empty
111 | otherwise = ptext (sLit ".type ") <>
112 pprCLabel_asm lbl <> ptext (sLit ", @object")
118 pprLabel :: CLabel -> Doc
119 pprLabel lbl = pprGloblDecl lbl $$ pprTypeAndSizeDecl lbl $$ (pprCLabel_asm lbl <> char ':')
122 pprASCII :: [Word8] -> Doc
124 = vcat (map do1 str) $$ do1 0
127 do1 w = ptext (sLit "\t.byte\t") <> int (fromIntegral w)
129 pprAlign :: Int -> Doc
131 ptext (sLit ".align ") <> int bytes
134 -- -----------------------------------------------------------------------------
135 -- pprInstr: print an 'Instr'
137 instance Outputable Instr where
138 ppr instr = Outputable.docToSDoc $ pprInstr instr
141 -- | Pretty print a register.
142 -- This is an alias of pprReg for legacy reasons, should remove it.
143 pprUserReg :: Reg -> Doc
147 -- | Pretty print a register.
151 RealReg i -> pprReg_ofRegNo i
152 VirtualRegI u -> text "%vI_" <> asmSDoc (pprUnique u)
153 VirtualRegHi u -> text "%vHi_" <> asmSDoc (pprUnique u)
154 VirtualRegF u -> text "%vF_" <> asmSDoc (pprUnique u)
155 VirtualRegD u -> text "%vD_" <> asmSDoc (pprUnique u)
158 -- | Pretty print a register name, based on this register number.
159 -- The definition has been unfolded so we get a jump-table in the
160 -- object code. This function is called quite a lot when emitting the asm file..
162 pprReg_ofRegNo :: Int -> Doc
166 0 -> sLit "%g0"; 1 -> sLit "%g1";
167 2 -> sLit "%g2"; 3 -> sLit "%g3";
168 4 -> sLit "%g4"; 5 -> sLit "%g5";
169 6 -> sLit "%g6"; 7 -> sLit "%g7";
170 8 -> sLit "%o0"; 9 -> sLit "%o1";
171 10 -> sLit "%o2"; 11 -> sLit "%o3";
172 12 -> sLit "%o4"; 13 -> sLit "%o5";
173 14 -> sLit "%o6"; 15 -> sLit "%o7";
174 16 -> sLit "%l0"; 17 -> sLit "%l1";
175 18 -> sLit "%l2"; 19 -> sLit "%l3";
176 20 -> sLit "%l4"; 21 -> sLit "%l5";
177 22 -> sLit "%l6"; 23 -> sLit "%l7";
178 24 -> sLit "%i0"; 25 -> sLit "%i1";
179 26 -> sLit "%i2"; 27 -> sLit "%i3";
180 28 -> sLit "%i4"; 29 -> sLit "%i5";
181 30 -> sLit "%i6"; 31 -> sLit "%i7";
182 32 -> sLit "%f0"; 33 -> sLit "%f1";
183 34 -> sLit "%f2"; 35 -> sLit "%f3";
184 36 -> sLit "%f4"; 37 -> sLit "%f5";
185 38 -> sLit "%f6"; 39 -> sLit "%f7";
186 40 -> sLit "%f8"; 41 -> sLit "%f9";
187 42 -> sLit "%f10"; 43 -> sLit "%f11";
188 44 -> sLit "%f12"; 45 -> sLit "%f13";
189 46 -> sLit "%f14"; 47 -> sLit "%f15";
190 48 -> sLit "%f16"; 49 -> sLit "%f17";
191 50 -> sLit "%f18"; 51 -> sLit "%f19";
192 52 -> sLit "%f20"; 53 -> sLit "%f21";
193 54 -> sLit "%f22"; 55 -> sLit "%f23";
194 56 -> sLit "%f24"; 57 -> sLit "%f25";
195 58 -> sLit "%f26"; 59 -> sLit "%f27";
196 60 -> sLit "%f28"; 61 -> sLit "%f29";
197 62 -> sLit "%f30"; 63 -> sLit "%f31";
198 _ -> sLit "very naughty sparc register" })
201 -- | Pretty print a size for an instruction suffix.
202 pprSize :: Size -> Doc
212 _ -> panic "SPARC.Ppr.pprSize: no match")
215 -- | Pretty print a size for an instruction suffix.
216 -- eg LD is 32bit on sparc, but LDD is 64 bit.
217 pprStSize :: Size -> Doc
227 _ -> panic "SPARC.Ppr.pprSize: no match")
230 -- | Pretty print a condition code.
231 pprCond :: Cond -> Doc
253 -- | Pretty print an address mode.
254 pprAddr :: AddrMode -> Doc
257 AddrRegReg r1 (RealReg 0)
261 -> hcat [ pprReg r1, char '+', pprReg r2 ]
263 AddrRegImm r1 (ImmInt i)
264 | i == 0 -> pprReg r1
265 | not (fits13Bits i) -> largeOffsetError i
266 | otherwise -> hcat [ pprReg r1, pp_sign, int i ]
268 pp_sign = if i > 0 then char '+' else empty
270 AddrRegImm r1 (ImmInteger i)
271 | i == 0 -> pprReg r1
272 | not (fits13Bits i) -> largeOffsetError i
273 | otherwise -> hcat [ pprReg r1, pp_sign, integer i ]
275 pp_sign = if i > 0 then char '+' else empty
278 -> hcat [ pprReg r1, char '+', pprImm imm ]
281 -- | Pretty print an immediate value.
286 ImmInteger i -> integer i
287 ImmCLbl l -> pprCLabel_asm l
288 ImmIndex l i -> pprCLabel_asm l <> char '+' <> int i
292 -> pprImm a <> char '+' <> pprImm b
295 -> pprImm a <> char '-' <> lparen <> pprImm b <> rparen
298 -> hcat [ text "%lo(", pprImm i, rparen ]
301 -> hcat [ text "%hi(", pprImm i, rparen ]
303 -- these should have been converted to bytes and placed
304 -- in the data section.
305 ImmFloat _ -> ptext (sLit "naughty float immediate")
306 ImmDouble _ -> ptext (sLit "naughty double immediate")
309 -- | Pretty print a section \/ segment header.
310 -- On SPARC all the data sections must be at least 8 byte aligned
311 -- incase we store doubles in them.
313 pprSectionHeader :: Section -> Doc
316 Text -> ptext (sLit ".text\n\t.align 4")
317 Data -> ptext (sLit ".data\n\t.align 8")
318 ReadOnlyData -> ptext (sLit ".text\n\t.align 8")
319 RelocatableReadOnlyData -> ptext (sLit ".text\n\t.align 8")
320 UninitialisedData -> ptext (sLit ".bss\n\t.align 8")
321 ReadOnlyData16 -> ptext (sLit ".data\n\t.align 16")
322 OtherSection _ -> panic "PprMach.pprSectionHeader: unknown section"
325 -- | Pretty print a data item.
326 pprDataItem :: CmmLit -> Doc
328 = vcat (ppr_item (cmmTypeSize $ cmmLitType lit) lit)
332 ppr_item II8 _ = [ptext (sLit "\t.byte\t") <> pprImm imm]
333 ppr_item II32 _ = [ptext (sLit "\t.long\t") <> pprImm imm]
335 ppr_item FF32 (CmmFloat r _)
336 = let bs = floatToBytes (fromRational r)
337 in map (\b -> ptext (sLit "\t.byte\t") <> pprImm (ImmInt b)) bs
339 ppr_item FF64 (CmmFloat r _)
340 = let bs = doubleToBytes (fromRational r)
341 in map (\b -> ptext (sLit "\t.byte\t") <> pprImm (ImmInt b)) bs
343 ppr_item II16 _ = [ptext (sLit "\t.short\t") <> pprImm imm]
344 ppr_item II64 _ = [ptext (sLit "\t.quad\t") <> pprImm imm]
345 ppr_item _ _ = panic "SPARC.Ppr.pprDataItem: no match"
348 -- | Pretty print an instruction.
349 pprInstr :: Instr -> Doc
356 = pprInstr (COMMENT (mkFastString ("\tdelta = " ++ show d)))
358 -- Newblocks and LData should have been slurped out before producing the .s file.
359 pprInstr (NEWBLOCK _)
360 = panic "X86.Ppr.pprInstr: NEWBLOCK"
363 = panic "PprMach.pprInstr: LDATA"
366 pprInstr (SPILL reg slot)
368 ptext (sLit "\tSPILL"),
372 ptext (sLit "SLOT") <> parens (int slot)]
374 pprInstr (RELOAD slot reg)
376 ptext (sLit "\tRELOAD"),
378 ptext (sLit "SLOT") <> parens (int slot),
383 -- a clumsy hack for now, to handle possible double alignment problems
384 -- even clumsier, to allow for RegReg regs that show when doing indexed
385 -- reads (bytearrays).
387 -- Translate to the following:
391 -- sub g1,g2,g1 -- to restore g1
393 pprInstr (LD FF64 (AddrRegReg g1 g2) reg)
394 = let Just regH = fPair reg
396 hcat [ptext (sLit "\tadd\t"), pprReg g1, comma, pprReg g2, comma, pprReg g1],
397 hcat [pp_ld_lbracket, pprReg g1, pp_rbracket_comma, pprReg reg],
398 hcat [pp_ld_lbracket, pprReg g1, ptext (sLit "+4]"), comma, pprReg regH],
399 hcat [ptext (sLit "\tsub\t"), pprReg g1, comma, pprReg g2, comma, pprReg g1]
404 -- ld [addr+4],%f(n+1)
405 pprInstr (LD FF64 addr reg)
406 = let Just addr2 = addrOffset addr 4
407 Just regH = fPair reg
409 hcat [pp_ld_lbracket, pprAddr addr, pp_rbracket_comma, pprReg reg],
410 hcat [pp_ld_lbracket, pprAddr addr2, pp_rbracket_comma,pprReg regH]
414 pprInstr (LD size addr reg)
425 -- The same clumsy hack as above
426 -- Translate to the following:
430 -- sub g1,g2,g1 -- to restore g1
432 pprInstr (ST FF64 reg (AddrRegReg g1 g2))
433 = let Just regH = fPair reg
435 hcat [ptext (sLit "\tadd\t"), pprReg g1, comma, pprReg g2, comma, pprReg g1],
436 hcat [ptext (sLit "\tst\t"), pprReg reg, pp_comma_lbracket,
438 hcat [ptext (sLit "\tst\t"), pprReg regH, pp_comma_lbracket,
439 pprReg g1, ptext (sLit "+4]")],
440 hcat [ptext (sLit "\tsub\t"), pprReg g1, comma, pprReg g2, comma, pprReg g1]
445 -- st %f(n+1),[addr+4]
446 pprInstr (ST FF64 reg addr)
447 = let Just addr2 = addrOffset addr 4
448 Just regH = fPair reg
450 hcat [ptext (sLit "\tst\t"), pprReg reg, pp_comma_lbracket,
451 pprAddr addr, rbrack],
452 hcat [ptext (sLit "\tst\t"), pprReg regH, pp_comma_lbracket,
453 pprAddr addr2, rbrack]
457 -- no distinction is made between signed and unsigned bytes on stores for the
458 -- Sparc opcodes (at least I cannot see any, and gas is nagging me --SOF),
459 -- so we call a special-purpose pprSize for ST..
460 pprInstr (ST size reg addr)
472 pprInstr (ADD x cc reg1 ri reg2)
473 | not x && not cc && riZero ri
474 = hcat [ ptext (sLit "\tmov\t"), pprReg reg1, comma, pprReg reg2 ]
477 = pprRegRIReg (if x then sLit "addx" else sLit "add") cc reg1 ri reg2
480 pprInstr (SUB x cc reg1 ri reg2)
481 | not x && cc && reg2 == g0
482 = hcat [ ptext (sLit "\tcmp\t"), pprReg reg1, comma, pprRI ri ]
484 | not x && not cc && riZero ri
485 = hcat [ ptext (sLit "\tmov\t"), pprReg reg1, comma, pprReg reg2 ]
488 = pprRegRIReg (if x then sLit "subx" else sLit "sub") cc reg1 ri reg2
490 pprInstr (AND b reg1 ri reg2) = pprRegRIReg (sLit "and") b reg1 ri reg2
492 pprInstr (ANDN b reg1 ri reg2) = pprRegRIReg (sLit "andn") b reg1 ri reg2
494 pprInstr (OR b reg1 ri reg2)
495 | not b && reg1 == g0
496 = let doit = hcat [ ptext (sLit "\tmov\t"), pprRI ri, comma, pprReg reg2 ]
498 RIReg rrr | rrr == reg2 -> empty
502 = pprRegRIReg (sLit "or") b reg1 ri reg2
504 pprInstr (ORN b reg1 ri reg2) = pprRegRIReg (sLit "orn") b reg1 ri reg2
506 pprInstr (XOR b reg1 ri reg2) = pprRegRIReg (sLit "xor") b reg1 ri reg2
507 pprInstr (XNOR b reg1 ri reg2) = pprRegRIReg (sLit "xnor") b reg1 ri reg2
509 pprInstr (SLL reg1 ri reg2) = pprRegRIReg (sLit "sll") False reg1 ri reg2
510 pprInstr (SRL reg1 ri reg2) = pprRegRIReg (sLit "srl") False reg1 ri reg2
511 pprInstr (SRA reg1 ri reg2) = pprRegRIReg (sLit "sra") False reg1 ri reg2
513 pprInstr (RDY rd) = ptext (sLit "\trd\t%y,") <> pprReg rd
514 pprInstr (WRY reg1 reg2)
515 = ptext (sLit "\twr\t")
522 pprInstr (SMUL b reg1 ri reg2) = pprRegRIReg (sLit "smul") b reg1 ri reg2
523 pprInstr (UMUL b reg1 ri reg2) = pprRegRIReg (sLit "umul") b reg1 ri reg2
524 pprInstr (SDIV b reg1 ri reg2) = pprRegRIReg (sLit "sdiv") b reg1 ri reg2
525 pprInstr (UDIV b reg1 ri reg2) = pprRegRIReg (sLit "udiv") b reg1 ri reg2
527 pprInstr (SETHI imm reg)
529 ptext (sLit "\tsethi\t"),
535 pprInstr NOP = ptext (sLit "\tnop")
537 pprInstr (FABS FF32 reg1 reg2) = pprSizeRegReg (sLit "fabs") FF32 reg1 reg2
538 pprInstr (FABS FF64 reg1 reg2)
539 = let Just reg1H = fPair reg1
540 Just reg2H = fPair reg2
542 (<>) (pprSizeRegReg (sLit "fabs") FF32 reg1 reg2)
543 (if (reg1 == reg2) then empty
544 else (<>) (char '\n')
545 (pprSizeRegReg (sLit "fmov") FF32 reg1H reg2H))
547 pprInstr (FABS _ _ _)
548 =panic "SPARC.Ppr.pprInstr(FABS): no match"
550 pprInstr (FADD size reg1 reg2 reg3)
551 = pprSizeRegRegReg (sLit "fadd") size reg1 reg2 reg3
553 pprInstr (FCMP e size reg1 reg2)
554 = pprSizeRegReg (if e then sLit "fcmpe" else sLit "fcmp") size reg1 reg2
556 pprInstr (FDIV size reg1 reg2 reg3)
557 = pprSizeRegRegReg (sLit "fdiv") size reg1 reg2 reg3
559 pprInstr (FMOV FF32 reg1 reg2) = pprSizeRegReg (sLit "fmov") FF32 reg1 reg2
560 pprInstr (FMOV FF64 reg1 reg2) = pprSizeRegReg (sLit "fmov") FF64 reg1 reg2
562 pprInstr (FMOV _ _ _)
563 = panic "SPARC.Ppr.pprInstr(FMOV): no match"
566 pprInstr (FMOV FF64 reg1 reg2)
567 = let Just reg1H = fPair reg1
568 Just reg2H = fPair reg2
570 (<>) (pprSizeRegReg (sLit "fmov") FF32 reg1 reg2)
571 (if (reg1 == reg2) then empty
572 else (<>) (char '\n')
573 (pprSizeRegReg (sLit "fmov") FF32 reg1H reg2H))
576 pprInstr (FMUL size reg1 reg2 reg3)
577 = pprSizeRegRegReg (sLit "fmul") size reg1 reg2 reg3
579 pprInstr (FNEG FF32 reg1 reg2)
580 = pprSizeRegReg (sLit "fneg") FF32 reg1 reg2
582 pprInstr (FNEG FF64 reg1 reg2)
583 = let Just reg1H = fPair reg1
584 Just reg2H = fPair reg2
586 (<>) (pprSizeRegReg (sLit "fneg") FF32 reg1 reg2)
587 (if (reg1 == reg2) then empty
588 else (<>) (char '\n')
589 (pprSizeRegReg (sLit "fmov") FF32 reg1H reg2H))
591 pprInstr (FNEG _ _ _)
592 = panic "SPARC.Ppr.pprInstr(FNEG): no match"
594 pprInstr (FSQRT size reg1 reg2)
595 = pprSizeRegReg (sLit "fsqrt") size reg1 reg2
597 pprInstr (FSUB size reg1 reg2 reg3)
598 = pprSizeRegRegReg (sLit "fsub") size reg1 reg2 reg3
600 pprInstr (FxTOy size1 size2 reg1 reg2)
608 _ -> panic "SPARC.Ppr.pprInstr.FxToY: no match"),
615 _ -> panic "SPARC.Ppr.pprInstr.FxToY: no match"),
616 pprReg reg1, comma, pprReg reg2
620 pprInstr (BI cond b (BlockId id))
622 ptext (sLit "\tb"), pprCond cond,
623 if b then pp_comma_a else empty,
625 pprCLabel_asm (mkAsmTempLabel id)
628 pprInstr (BF cond b (BlockId id))
630 ptext (sLit "\tfb"), pprCond cond,
631 if b then pp_comma_a else empty,
633 pprCLabel_asm (mkAsmTempLabel id)
636 pprInstr (JMP addr) = (<>) (ptext (sLit "\tjmp\t")) (pprAddr addr)
637 pprInstr (JMP_TBL op _) = pprInstr (JMP op)
639 pprInstr (CALL (Left imm) n _)
640 = hcat [ ptext (sLit "\tcall\t"), pprImm imm, comma, int n ]
641 pprInstr (CALL (Right reg) n _)
642 = hcat [ ptext (sLit "\tcall\t"), pprReg reg, comma, int n ]
645 -- | Pretty print a RI
647 pprRI (RIReg r) = pprReg r
648 pprRI (RIImm r) = pprImm r
651 -- | Pretty print a two reg instruction.
652 pprSizeRegReg :: LitString -> Size -> Reg -> Reg -> Doc
653 pprSizeRegReg name size reg1 reg2
658 FF32 -> ptext (sLit "s\t")
659 FF64 -> ptext (sLit "d\t")
660 _ -> panic "SPARC.Ppr.pprSizeRegReg: no match"),
668 -- | Pretty print a three reg instruction.
669 pprSizeRegRegReg :: LitString -> Size -> Reg -> Reg -> Reg -> Doc
670 pprSizeRegRegReg name size reg1 reg2 reg3
675 FF32 -> ptext (sLit "s\t")
676 FF64 -> ptext (sLit "d\t")
677 _ -> panic "SPARC.Ppr.pprSizeRegReg: no match"),
686 -- | Pretty print an instruction of two regs and a ri.
687 pprRegRIReg :: LitString -> Bool -> Reg -> RI -> Reg -> Doc
688 pprRegRIReg name b reg1 ri reg2
692 if b then ptext (sLit "cc\t") else char '\t',
701 pprRIReg :: LitString -> Bool -> RI -> Reg -> Doc
702 pprRIReg name b ri reg1
706 if b then ptext (sLit "cc\t") else char '\t',
714 pp_ld_lbracket :: Doc
715 pp_ld_lbracket = ptext (sLit "\tld\t[")
718 pp_rbracket_comma :: Doc
719 pp_rbracket_comma = text "],"
722 pp_comma_lbracket :: Doc
723 pp_comma_lbracket = text ",["
727 pp_comma_a = text ",a"