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