Merge branch 'master' of darcs.haskell.org:/srv/darcs//ghc
[ghc.git] / compiler / nativeGen / PPC / Ppr.hs
1 -----------------------------------------------------------------------------
2 --
3 -- Pretty-printing assembly language
4 --
5 -- (c) The University of Glasgow 1993-2005
6 --
7 -----------------------------------------------------------------------------
8
9 {-# OPTIONS_GHC -fno-warn-orphans #-}
10 module PPC.Ppr (
11 pprNatCmmDecl,
12 pprBasicBlock,
13 pprSectionHeader,
14 pprData,
15 pprInstr,
16 pprSize,
17 pprImm,
18 pprDataItem,
19 )
20
21 where
22
23 import PPC.Regs
24 import PPC.Instr
25 import PPC.Cond
26 import PprBase
27 import Instruction
28 import Size
29 import Reg
30 import RegClass
31 import TargetReg
32
33 import OldCmm
34
35 import CLabel
36
37 import Unique ( pprUnique, Uniquable(..) )
38 import Platform
39 import FastString
40 import Outputable
41
42 import Data.Word
43 import Data.Bits
44
45
46 -- -----------------------------------------------------------------------------
47 -- Printing this stuff out
48
49 pprNatCmmDecl :: NatCmmDecl CmmStatics Instr -> SDoc
50 pprNatCmmDecl (CmmData section dats) =
51 pprSectionHeader section $$ pprDatas dats
52
53 -- special case for split markers:
54 pprNatCmmDecl (CmmProc Nothing lbl (ListGraph []))
55 = pprLabel lbl
56
57 -- special case for code without an info table:
58 pprNatCmmDecl (CmmProc Nothing lbl (ListGraph blocks)) =
59 pprSectionHeader Text $$
60 pprLabel lbl $$ -- blocks guaranteed not null, so label needed
61 vcat (map pprBasicBlock blocks)
62
63 pprNatCmmDecl (CmmProc (Just (Statics info_lbl info)) _entry_lbl (ListGraph blocks)) =
64 sdocWithPlatform $ \platform ->
65 pprSectionHeader Text $$
66 (
67 (if platformHasSubsectionsViaSymbols platform
68 then ppr (mkDeadStripPreventer info_lbl) <> char ':'
69 else empty) $$
70 vcat (map pprData info) $$
71 pprLabel info_lbl
72 ) $$
73 vcat (map pprBasicBlock blocks) $$
74 -- above: Even the first block gets a label, because with branch-chain
75 -- elimination, it might be the target of a goto.
76 (if platformHasSubsectionsViaSymbols platform
77 then
78 -- If we are using the .subsections_via_symbols directive
79 -- (available on recent versions of Darwin),
80 -- we have to make sure that there is some kind of reference
81 -- from the entry code to a label on the _top_ of of the info table,
82 -- so that the linker will not think it is unreferenced and dead-strip
83 -- it. That's why the label is called a DeadStripPreventer (_dsp).
84 text "\t.long "
85 <+> ppr info_lbl
86 <+> char '-'
87 <+> ppr (mkDeadStripPreventer info_lbl)
88 else empty)
89
90
91 pprBasicBlock :: NatBasicBlock Instr -> SDoc
92 pprBasicBlock (BasicBlock blockid instrs) =
93 pprLabel (mkAsmTempLabel (getUnique blockid)) $$
94 vcat (map pprInstr instrs)
95
96
97
98 pprDatas :: CmmStatics -> SDoc
99 pprDatas (Statics lbl dats) = vcat (pprLabel lbl : map pprData dats)
100
101 pprData :: CmmStatic -> SDoc
102 pprData (CmmString str) = pprASCII str
103 pprData (CmmUninitialised bytes) = keyword <> int bytes
104 where keyword = sdocWithPlatform $ \platform ->
105 case platformOS platform of
106 OSDarwin -> ptext (sLit ".space ")
107 _ -> ptext (sLit ".skip ")
108 pprData (CmmStaticLit lit) = pprDataItem lit
109
110 pprGloblDecl :: CLabel -> SDoc
111 pprGloblDecl lbl
112 | not (externallyVisibleCLabel lbl) = empty
113 | otherwise = ptext (sLit ".globl ") <> ppr lbl
114
115 pprTypeAndSizeDecl :: CLabel -> SDoc
116 pprTypeAndSizeDecl lbl
117 = sdocWithPlatform $ \platform ->
118 if platformOS platform == OSLinux && externallyVisibleCLabel lbl
119 then ptext (sLit ".type ") <>
120 ppr lbl <> ptext (sLit ", @object")
121 else empty
122
123 pprLabel :: CLabel -> SDoc
124 pprLabel lbl = pprGloblDecl lbl
125 $$ pprTypeAndSizeDecl lbl
126 $$ (ppr lbl <> char ':')
127
128
129 pprASCII :: [Word8] -> SDoc
130 pprASCII str
131 = vcat (map do1 str) $$ do1 0
132 where
133 do1 :: Word8 -> SDoc
134 do1 w = ptext (sLit "\t.byte\t") <> int (fromIntegral w)
135
136
137 -- -----------------------------------------------------------------------------
138 -- pprInstr: print an 'Instr'
139
140 instance Outputable Instr where
141 ppr instr = pprInstr instr
142
143
144 pprReg :: Reg -> SDoc
145
146 pprReg r
147 = case r of
148 RegReal (RealRegSingle i) -> ppr_reg_no i
149 RegReal (RealRegPair{}) -> panic "PPC.pprReg: no reg pairs on this arch"
150 RegVirtual (VirtualRegI u) -> text "%vI_" <> pprUnique u
151 RegVirtual (VirtualRegHi u) -> text "%vHi_" <> pprUnique u
152 RegVirtual (VirtualRegF u) -> text "%vF_" <> pprUnique u
153 RegVirtual (VirtualRegD u) -> text "%vD_" <> pprUnique u
154 RegVirtual (VirtualRegSSE u) -> text "%vSSE_" <> pprUnique u
155 where
156 ppr_reg_no :: Int -> SDoc
157 ppr_reg_no i =
158 sdocWithPlatform $ \platform ->
159 case platformOS platform of
160 OSDarwin ->
161 ptext
162 (case i of {
163 0 -> sLit "r0"; 1 -> sLit "r1";
164 2 -> sLit "r2"; 3 -> sLit "r3";
165 4 -> sLit "r4"; 5 -> sLit "r5";
166 6 -> sLit "r6"; 7 -> sLit "r7";
167 8 -> sLit "r8"; 9 -> sLit "r9";
168 10 -> sLit "r10"; 11 -> sLit "r11";
169 12 -> sLit "r12"; 13 -> sLit "r13";
170 14 -> sLit "r14"; 15 -> sLit "r15";
171 16 -> sLit "r16"; 17 -> sLit "r17";
172 18 -> sLit "r18"; 19 -> sLit "r19";
173 20 -> sLit "r20"; 21 -> sLit "r21";
174 22 -> sLit "r22"; 23 -> sLit "r23";
175 24 -> sLit "r24"; 25 -> sLit "r25";
176 26 -> sLit "r26"; 27 -> sLit "r27";
177 28 -> sLit "r28"; 29 -> sLit "r29";
178 30 -> sLit "r30"; 31 -> sLit "r31";
179 32 -> sLit "f0"; 33 -> sLit "f1";
180 34 -> sLit "f2"; 35 -> sLit "f3";
181 36 -> sLit "f4"; 37 -> sLit "f5";
182 38 -> sLit "f6"; 39 -> sLit "f7";
183 40 -> sLit "f8"; 41 -> sLit "f9";
184 42 -> sLit "f10"; 43 -> sLit "f11";
185 44 -> sLit "f12"; 45 -> sLit "f13";
186 46 -> sLit "f14"; 47 -> sLit "f15";
187 48 -> sLit "f16"; 49 -> sLit "f17";
188 50 -> sLit "f18"; 51 -> sLit "f19";
189 52 -> sLit "f20"; 53 -> sLit "f21";
190 54 -> sLit "f22"; 55 -> sLit "f23";
191 56 -> sLit "f24"; 57 -> sLit "f25";
192 58 -> sLit "f26"; 59 -> sLit "f27";
193 60 -> sLit "f28"; 61 -> sLit "f29";
194 62 -> sLit "f30"; 63 -> sLit "f31";
195 _ -> sLit "very naughty powerpc register"
196 })
197 _
198 | i <= 31 -> int i -- GPRs
199 | i <= 63 -> int (i-32) -- FPRs
200 | otherwise -> ptext (sLit "very naughty powerpc register")
201
202
203
204 pprSize :: Size -> SDoc
205 pprSize x
206 = ptext (case x of
207 II8 -> sLit "b"
208 II16 -> sLit "h"
209 II32 -> sLit "w"
210 FF32 -> sLit "fs"
211 FF64 -> sLit "fd"
212 _ -> panic "PPC.Ppr.pprSize: no match")
213
214
215 pprCond :: Cond -> SDoc
216 pprCond c
217 = ptext (case c of {
218 ALWAYS -> sLit "";
219 EQQ -> sLit "eq"; NE -> sLit "ne";
220 LTT -> sLit "lt"; GE -> sLit "ge";
221 GTT -> sLit "gt"; LE -> sLit "le";
222 LU -> sLit "lt"; GEU -> sLit "ge";
223 GU -> sLit "gt"; LEU -> sLit "le"; })
224
225
226 pprImm :: Imm -> SDoc
227
228 pprImm (ImmInt i) = int i
229 pprImm (ImmInteger i) = integer i
230 pprImm (ImmCLbl l) = ppr l
231 pprImm (ImmIndex l i) = ppr l <> char '+' <> int i
232 pprImm (ImmLit s) = s
233
234 pprImm (ImmFloat _) = ptext (sLit "naughty float immediate")
235 pprImm (ImmDouble _) = ptext (sLit "naughty double immediate")
236
237 pprImm (ImmConstantSum a b) = pprImm a <> char '+' <> pprImm b
238 pprImm (ImmConstantDiff a b) = pprImm a <> char '-'
239 <> lparen <> pprImm b <> rparen
240
241 pprImm (LO i)
242 = sdocWithPlatform $ \platform ->
243 if platformOS platform == OSDarwin
244 then hcat [ text "lo16(", pprImm i, rparen ]
245 else pprImm i <> text "@l"
246
247 pprImm (HI i)
248 = sdocWithPlatform $ \platform ->
249 if platformOS platform == OSDarwin
250 then hcat [ text "hi16(", pprImm i, rparen ]
251 else pprImm i <> text "@h"
252
253 pprImm (HA i)
254 = sdocWithPlatform $ \platform ->
255 if platformOS platform == OSDarwin
256 then hcat [ text "ha16(", pprImm i, rparen ]
257 else pprImm i <> text "@ha"
258
259
260 pprAddr :: AddrMode -> SDoc
261 pprAddr (AddrRegReg r1 r2)
262 = pprReg r1 <+> ptext (sLit ", ") <+> pprReg r2
263
264 pprAddr (AddrRegImm r1 (ImmInt i)) = hcat [ int i, char '(', pprReg r1, char ')' ]
265 pprAddr (AddrRegImm r1 (ImmInteger i)) = hcat [ integer i, char '(', pprReg r1, char ')' ]
266 pprAddr (AddrRegImm r1 imm) = hcat [ pprImm imm, char '(', pprReg r1, char ')' ]
267
268
269 pprSectionHeader :: Section -> SDoc
270 pprSectionHeader seg
271 = sdocWithPlatform $ \platform ->
272 let osDarwin = platformOS platform == OSDarwin
273 in case seg of
274 Text -> ptext (sLit ".text\n.align 2")
275 Data -> ptext (sLit ".data\n.align 2")
276 ReadOnlyData
277 | osDarwin -> ptext (sLit ".const\n.align 2")
278 | otherwise -> ptext (sLit ".section .rodata\n\t.align 2")
279 RelocatableReadOnlyData
280 | osDarwin -> ptext (sLit ".const_data\n.align 2")
281 | otherwise -> ptext (sLit ".data\n\t.align 2")
282 UninitialisedData
283 | osDarwin -> ptext (sLit ".const_data\n.align 2")
284 | otherwise -> ptext (sLit ".section .bss\n\t.align 2")
285 ReadOnlyData16
286 | osDarwin -> ptext (sLit ".const\n.align 4")
287 | otherwise -> ptext (sLit ".section .rodata\n\t.align 4")
288 OtherSection _ ->
289 panic "PprMach.pprSectionHeader: unknown section"
290
291
292 pprDataItem :: CmmLit -> SDoc
293 pprDataItem lit
294 = vcat (ppr_item (cmmTypeSize $ cmmLitType lit) lit)
295 where
296 imm = litToImm lit
297
298 ppr_item II8 _ = [ptext (sLit "\t.byte\t") <> pprImm imm]
299
300 ppr_item II32 _ = [ptext (sLit "\t.long\t") <> pprImm imm]
301
302 ppr_item FF32 (CmmFloat r _)
303 = let bs = floatToBytes (fromRational r)
304 in map (\b -> ptext (sLit "\t.byte\t") <> pprImm (ImmInt b)) bs
305
306 ppr_item FF64 (CmmFloat r _)
307 = let bs = doubleToBytes (fromRational r)
308 in map (\b -> ptext (sLit "\t.byte\t") <> pprImm (ImmInt b)) bs
309
310 ppr_item II16 _ = [ptext (sLit "\t.short\t") <> pprImm imm]
311
312 ppr_item II64 (CmmInt x _) =
313 [ptext (sLit "\t.long\t")
314 <> int (fromIntegral
315 (fromIntegral (x `shiftR` 32) :: Word32)),
316 ptext (sLit "\t.long\t")
317 <> int (fromIntegral (fromIntegral x :: Word32))]
318
319 ppr_item _ _
320 = panic "PPC.Ppr.pprDataItem: no match"
321
322
323 pprInstr :: Instr -> SDoc
324
325 pprInstr (COMMENT _) = empty -- nuke 'em
326 {-
327 pprInstr (COMMENT s) =
328 if platformOS platform == OSLinux
329 then ptext (sLit "# ") <> ftext s
330 else ptext (sLit "; ") <> ftext s
331 -}
332 pprInstr (DELTA d)
333 = pprInstr (COMMENT (mkFastString ("\tdelta = " ++ show d)))
334
335 pprInstr (NEWBLOCK _)
336 = panic "PprMach.pprInstr: NEWBLOCK"
337
338 pprInstr (LDATA _ _)
339 = panic "PprMach.pprInstr: LDATA"
340
341 {-
342 pprInstr (SPILL reg slot)
343 = hcat [
344 ptext (sLit "\tSPILL"),
345 char '\t',
346 pprReg reg,
347 comma,
348 ptext (sLit "SLOT") <> parens (int slot)]
349
350 pprInstr (RELOAD slot reg)
351 = hcat [
352 ptext (sLit "\tRELOAD"),
353 char '\t',
354 ptext (sLit "SLOT") <> parens (int slot),
355 comma,
356 pprReg reg]
357 -}
358
359 pprInstr (LD sz reg addr) = hcat [
360 char '\t',
361 ptext (sLit "l"),
362 ptext (case sz of
363 II8 -> sLit "bz"
364 II16 -> sLit "hz"
365 II32 -> sLit "wz"
366 FF32 -> sLit "fs"
367 FF64 -> sLit "fd"
368 _ -> panic "PPC.Ppr.pprInstr: no match"
369 ),
370 case addr of AddrRegImm _ _ -> empty
371 AddrRegReg _ _ -> char 'x',
372 char '\t',
373 pprReg reg,
374 ptext (sLit ", "),
375 pprAddr addr
376 ]
377 pprInstr (LA sz reg addr) = hcat [
378 char '\t',
379 ptext (sLit "l"),
380 ptext (case sz of
381 II8 -> sLit "ba"
382 II16 -> sLit "ha"
383 II32 -> sLit "wa"
384 FF32 -> sLit "fs"
385 FF64 -> sLit "fd"
386 _ -> panic "PPC.Ppr.pprInstr: no match"
387 ),
388 case addr of AddrRegImm _ _ -> empty
389 AddrRegReg _ _ -> char 'x',
390 char '\t',
391 pprReg reg,
392 ptext (sLit ", "),
393 pprAddr addr
394 ]
395 pprInstr (ST sz reg addr) = hcat [
396 char '\t',
397 ptext (sLit "st"),
398 pprSize sz,
399 case addr of AddrRegImm _ _ -> empty
400 AddrRegReg _ _ -> char 'x',
401 char '\t',
402 pprReg reg,
403 ptext (sLit ", "),
404 pprAddr addr
405 ]
406 pprInstr (STU sz reg addr) = hcat [
407 char '\t',
408 ptext (sLit "st"),
409 pprSize sz,
410 ptext (sLit "u\t"),
411 case addr of AddrRegImm _ _ -> empty
412 AddrRegReg _ _ -> char 'x',
413 pprReg reg,
414 ptext (sLit ", "),
415 pprAddr addr
416 ]
417 pprInstr (LIS reg imm) = hcat [
418 char '\t',
419 ptext (sLit "lis"),
420 char '\t',
421 pprReg reg,
422 ptext (sLit ", "),
423 pprImm imm
424 ]
425 pprInstr (LI reg imm) = hcat [
426 char '\t',
427 ptext (sLit "li"),
428 char '\t',
429 pprReg reg,
430 ptext (sLit ", "),
431 pprImm imm
432 ]
433 pprInstr (MR reg1 reg2)
434 | reg1 == reg2 = empty
435 | otherwise = hcat [
436 char '\t',
437 sdocWithPlatform $ \platform ->
438 case targetClassOfReg platform reg1 of
439 RcInteger -> ptext (sLit "mr")
440 _ -> ptext (sLit "fmr"),
441 char '\t',
442 pprReg reg1,
443 ptext (sLit ", "),
444 pprReg reg2
445 ]
446 pprInstr (CMP sz reg ri) = hcat [
447 char '\t',
448 op,
449 char '\t',
450 pprReg reg,
451 ptext (sLit ", "),
452 pprRI ri
453 ]
454 where
455 op = hcat [
456 ptext (sLit "cmp"),
457 pprSize sz,
458 case ri of
459 RIReg _ -> empty
460 RIImm _ -> char 'i'
461 ]
462 pprInstr (CMPL sz reg ri) = hcat [
463 char '\t',
464 op,
465 char '\t',
466 pprReg reg,
467 ptext (sLit ", "),
468 pprRI ri
469 ]
470 where
471 op = hcat [
472 ptext (sLit "cmpl"),
473 pprSize sz,
474 case ri of
475 RIReg _ -> empty
476 RIImm _ -> char 'i'
477 ]
478 pprInstr (BCC cond blockid) = hcat [
479 char '\t',
480 ptext (sLit "b"),
481 pprCond cond,
482 char '\t',
483 ppr lbl
484 ]
485 where lbl = mkAsmTempLabel (getUnique blockid)
486
487 pprInstr (BCCFAR cond blockid) = vcat [
488 hcat [
489 ptext (sLit "\tb"),
490 pprCond (condNegate cond),
491 ptext (sLit "\t$+8")
492 ],
493 hcat [
494 ptext (sLit "\tb\t"),
495 ppr lbl
496 ]
497 ]
498 where lbl = mkAsmTempLabel (getUnique blockid)
499
500 pprInstr (JMP lbl) = hcat [ -- an alias for b that takes a CLabel
501 char '\t',
502 ptext (sLit "b"),
503 char '\t',
504 ppr lbl
505 ]
506
507 pprInstr (MTCTR reg) = hcat [
508 char '\t',
509 ptext (sLit "mtctr"),
510 char '\t',
511 pprReg reg
512 ]
513 pprInstr (BCTR _ _) = hcat [
514 char '\t',
515 ptext (sLit "bctr")
516 ]
517 pprInstr (BL lbl _) = hcat [
518 ptext (sLit "\tbl\t"),
519 ppr lbl
520 ]
521 pprInstr (BCTRL _) = hcat [
522 char '\t',
523 ptext (sLit "bctrl")
524 ]
525 pprInstr (ADD reg1 reg2 ri) = pprLogic (sLit "add") reg1 reg2 ri
526 pprInstr (ADDIS reg1 reg2 imm) = hcat [
527 char '\t',
528 ptext (sLit "addis"),
529 char '\t',
530 pprReg reg1,
531 ptext (sLit ", "),
532 pprReg reg2,
533 ptext (sLit ", "),
534 pprImm imm
535 ]
536
537 pprInstr (ADDC reg1 reg2 reg3) = pprLogic (sLit "addc") reg1 reg2 (RIReg reg3)
538 pprInstr (ADDE reg1 reg2 reg3) = pprLogic (sLit "adde") reg1 reg2 (RIReg reg3)
539 pprInstr (SUBF reg1 reg2 reg3) = pprLogic (sLit "subf") reg1 reg2 (RIReg reg3)
540 pprInstr (MULLW reg1 reg2 ri@(RIReg _)) = pprLogic (sLit "mullw") reg1 reg2 ri
541 pprInstr (MULLW reg1 reg2 ri@(RIImm _)) = pprLogic (sLit "mull") reg1 reg2 ri
542 pprInstr (DIVW reg1 reg2 reg3) = pprLogic (sLit "divw") reg1 reg2 (RIReg reg3)
543 pprInstr (DIVWU reg1 reg2 reg3) = pprLogic (sLit "divwu") reg1 reg2 (RIReg reg3)
544
545 pprInstr (MULLW_MayOflo reg1 reg2 reg3) = vcat [
546 hcat [ ptext (sLit "\tmullwo\t"), pprReg reg1, ptext (sLit ", "),
547 pprReg reg2, ptext (sLit ", "),
548 pprReg reg3 ],
549 hcat [ ptext (sLit "\tmfxer\t"), pprReg reg1 ],
550 hcat [ ptext (sLit "\trlwinm\t"), pprReg reg1, ptext (sLit ", "),
551 pprReg reg1, ptext (sLit ", "),
552 ptext (sLit "2, 31, 31") ]
553 ]
554
555 -- for some reason, "andi" doesn't exist.
556 -- we'll use "andi." instead.
557 pprInstr (AND reg1 reg2 (RIImm imm)) = hcat [
558 char '\t',
559 ptext (sLit "andi."),
560 char '\t',
561 pprReg reg1,
562 ptext (sLit ", "),
563 pprReg reg2,
564 ptext (sLit ", "),
565 pprImm imm
566 ]
567 pprInstr (AND reg1 reg2 ri) = pprLogic (sLit "and") reg1 reg2 ri
568
569 pprInstr (OR reg1 reg2 ri) = pprLogic (sLit "or") reg1 reg2 ri
570 pprInstr (XOR reg1 reg2 ri) = pprLogic (sLit "xor") reg1 reg2 ri
571
572 pprInstr (XORIS reg1 reg2 imm) = hcat [
573 char '\t',
574 ptext (sLit "xoris"),
575 char '\t',
576 pprReg reg1,
577 ptext (sLit ", "),
578 pprReg reg2,
579 ptext (sLit ", "),
580 pprImm imm
581 ]
582
583 pprInstr (EXTS sz reg1 reg2) = hcat [
584 char '\t',
585 ptext (sLit "exts"),
586 pprSize sz,
587 char '\t',
588 pprReg reg1,
589 ptext (sLit ", "),
590 pprReg reg2
591 ]
592
593 pprInstr (NEG reg1 reg2) = pprUnary (sLit "neg") reg1 reg2
594 pprInstr (NOT reg1 reg2) = pprUnary (sLit "not") reg1 reg2
595
596 pprInstr (SLW reg1 reg2 ri) = pprLogic (sLit "slw") reg1 reg2 (limitShiftRI ri)
597
598 pprInstr (SRW reg1 reg2 (RIImm (ImmInt i))) | i > 31 || i < 0 =
599 -- Handle the case where we are asked to shift a 32 bit register by
600 -- less than zero or more than 31 bits. We convert this into a clear
601 -- of the destination register.
602 -- Fixes ticket http://hackage.haskell.org/trac/ghc/ticket/5900
603 pprInstr (XOR reg1 reg2 (RIReg reg2))
604 pprInstr (SRW reg1 reg2 ri) = pprLogic (sLit "srw") reg1 reg2 (limitShiftRI ri)
605
606 pprInstr (SRAW reg1 reg2 ri) = pprLogic (sLit "sraw") reg1 reg2 (limitShiftRI ri)
607 pprInstr (RLWINM reg1 reg2 sh mb me) = hcat [
608 ptext (sLit "\trlwinm\t"),
609 pprReg reg1,
610 ptext (sLit ", "),
611 pprReg reg2,
612 ptext (sLit ", "),
613 int sh,
614 ptext (sLit ", "),
615 int mb,
616 ptext (sLit ", "),
617 int me
618 ]
619
620 pprInstr (FADD sz reg1 reg2 reg3) = pprBinaryF (sLit "fadd") sz reg1 reg2 reg3
621 pprInstr (FSUB sz reg1 reg2 reg3) = pprBinaryF (sLit "fsub") sz reg1 reg2 reg3
622 pprInstr (FMUL sz reg1 reg2 reg3) = pprBinaryF (sLit "fmul") sz reg1 reg2 reg3
623 pprInstr (FDIV sz reg1 reg2 reg3) = pprBinaryF (sLit "fdiv") sz reg1 reg2 reg3
624 pprInstr (FNEG reg1 reg2) = pprUnary (sLit "fneg") reg1 reg2
625
626 pprInstr (FCMP reg1 reg2) = hcat [
627 char '\t',
628 ptext (sLit "fcmpu\tcr0, "),
629 -- Note: we're using fcmpu, not fcmpo
630 -- The difference is with fcmpo, compare with NaN is an invalid operation.
631 -- We don't handle invalid fp ops, so we don't care
632 pprReg reg1,
633 ptext (sLit ", "),
634 pprReg reg2
635 ]
636
637 pprInstr (FCTIWZ reg1 reg2) = pprUnary (sLit "fctiwz") reg1 reg2
638 pprInstr (FRSP reg1 reg2) = pprUnary (sLit "frsp") reg1 reg2
639
640 pprInstr (CRNOR dst src1 src2) = hcat [
641 ptext (sLit "\tcrnor\t"),
642 int dst,
643 ptext (sLit ", "),
644 int src1,
645 ptext (sLit ", "),
646 int src2
647 ]
648
649 pprInstr (MFCR reg) = hcat [
650 char '\t',
651 ptext (sLit "mfcr"),
652 char '\t',
653 pprReg reg
654 ]
655
656 pprInstr (MFLR reg) = hcat [
657 char '\t',
658 ptext (sLit "mflr"),
659 char '\t',
660 pprReg reg
661 ]
662
663 pprInstr (FETCHPC reg) = vcat [
664 ptext (sLit "\tbcl\t20,31,1f"),
665 hcat [ ptext (sLit "1:\tmflr\t"), pprReg reg ]
666 ]
667
668 pprInstr LWSYNC = ptext (sLit "\tlwsync")
669
670 -- pprInstr _ = panic "pprInstr (ppc)"
671
672
673 pprLogic :: LitString -> Reg -> Reg -> RI -> SDoc
674 pprLogic op reg1 reg2 ri = hcat [
675 char '\t',
676 ptext op,
677 case ri of
678 RIReg _ -> empty
679 RIImm _ -> char 'i',
680 char '\t',
681 pprReg reg1,
682 ptext (sLit ", "),
683 pprReg reg2,
684 ptext (sLit ", "),
685 pprRI ri
686 ]
687
688
689 pprUnary :: LitString -> Reg -> Reg -> SDoc
690 pprUnary op reg1 reg2 = hcat [
691 char '\t',
692 ptext op,
693 char '\t',
694 pprReg reg1,
695 ptext (sLit ", "),
696 pprReg reg2
697 ]
698
699
700 pprBinaryF :: LitString -> Size -> Reg -> Reg -> Reg -> SDoc
701 pprBinaryF op sz reg1 reg2 reg3 = hcat [
702 char '\t',
703 ptext op,
704 pprFSize sz,
705 char '\t',
706 pprReg reg1,
707 ptext (sLit ", "),
708 pprReg reg2,
709 ptext (sLit ", "),
710 pprReg reg3
711 ]
712
713 pprRI :: RI -> SDoc
714 pprRI (RIReg r) = pprReg r
715 pprRI (RIImm r) = pprImm r
716
717
718 pprFSize :: Size -> SDoc
719 pprFSize FF64 = empty
720 pprFSize FF32 = char 's'
721 pprFSize _ = panic "PPC.Ppr.pprFSize: no match"
722
723 -- limit immediate argument for shift instruction to range 0..31
724 limitShiftRI :: RI -> RI
725 limitShiftRI (RIImm (ImmInt i)) | i > 31 || i < 0 =
726 panic $ "PPC.Ppr: Shift by " ++ show i ++ " bits is not allowed."
727 limitShiftRI x = x
728