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