c4eb0811bd983c09fb6d37444c089dafe00f47f0
[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 (pprNatCmmDecl) where
11
12 import GhcPrelude
13
14 import PPC.Regs
15 import PPC.Instr
16 import PPC.Cond
17 import PprBase
18 import Instruction
19 import Format
20 import Reg
21 import RegClass
22 import TargetReg
23
24 import Cmm hiding (topInfoTable)
25 import Hoopl.Collections
26 import Hoopl.Label
27
28 import BlockId
29 import CLabel
30
31 import Unique ( pprUniqueAlways, getUnique )
32 import Platform
33 import FastString
34 import Outputable
35 import DynFlags
36
37 import Data.Word
38 import Data.Int
39 import Data.Bits
40
41 -- -----------------------------------------------------------------------------
42 -- Printing this stuff out
43
44 pprNatCmmDecl :: NatCmmDecl CmmStatics Instr -> SDoc
45 pprNatCmmDecl (CmmData section dats) =
46 pprSectionAlign section $$ pprDatas dats
47
48 pprNatCmmDecl proc@(CmmProc top_info lbl _ (ListGraph blocks)) =
49 case topInfoTable proc of
50 Nothing ->
51 sdocWithPlatform $ \platform ->
52 -- special case for code without info table:
53 pprSectionAlign (Section Text lbl) $$
54 (case platformArch platform of
55 ArchPPC_64 ELF_V1 -> pprFunctionDescriptor lbl
56 ArchPPC_64 ELF_V2 -> pprFunctionPrologue lbl
57 _ -> pprLabel lbl) $$ -- blocks guaranteed not null,
58 -- so label needed
59 vcat (map (pprBasicBlock top_info) blocks)
60
61 Just (Statics info_lbl _) ->
62 sdocWithPlatform $ \platform ->
63 pprSectionAlign (Section Text info_lbl) $$
64 (if platformHasSubsectionsViaSymbols platform
65 then ppr (mkDeadStripPreventer info_lbl) <> char ':'
66 else empty) $$
67 vcat (map (pprBasicBlock top_info) blocks) $$
68 -- above: Even the first block gets a label, because with branch-chain
69 -- elimination, it might be the target of a goto.
70 (if platformHasSubsectionsViaSymbols platform
71 then
72 -- See Note [Subsections Via Symbols] in X86/Ppr.hs
73 text "\t.long "
74 <+> ppr info_lbl
75 <+> char '-'
76 <+> ppr (mkDeadStripPreventer info_lbl)
77 else empty)
78
79 pprFunctionDescriptor :: CLabel -> SDoc
80 pprFunctionDescriptor lab = pprGloblDecl lab
81 $$ text "\t.section \".opd\", \"aw\""
82 $$ text "\t.align 3"
83 $$ ppr lab <> char ':'
84 $$ text "\t.quad ."
85 <> ppr lab
86 <> text ",.TOC.@tocbase,0"
87 $$ text "\t.previous"
88 $$ text "\t.type"
89 <+> ppr lab
90 <> text ", @function"
91 $$ char '.' <> ppr lab <> char ':'
92
93 pprFunctionPrologue :: CLabel ->SDoc
94 pprFunctionPrologue lab = pprGloblDecl lab
95 $$ text ".type "
96 <> ppr lab
97 <> text ", @function"
98 $$ ppr lab <> char ':'
99 $$ text "0:\taddis\t" <> pprReg toc
100 <> text ",12,.TOC.-0b@ha"
101 $$ text "\taddi\t" <> pprReg toc
102 <> char ',' <> pprReg toc <> text ",.TOC.-0b@l"
103 $$ text "\t.localentry\t" <> ppr lab
104 <> text ",.-" <> ppr lab
105
106 pprBasicBlock :: LabelMap CmmStatics -> NatBasicBlock Instr -> SDoc
107 pprBasicBlock info_env (BasicBlock blockid instrs)
108 = maybe_infotable $$
109 pprLabel (blockLbl blockid) $$
110 vcat (map pprInstr instrs)
111 where
112 maybe_infotable = case mapLookup blockid info_env of
113 Nothing -> empty
114 Just (Statics info_lbl info) ->
115 pprAlignForSection Text $$
116 vcat (map pprData info) $$
117 pprLabel info_lbl
118
119
120
121 pprDatas :: CmmStatics -> SDoc
122 pprDatas (Statics lbl dats) = vcat (pprLabel lbl : map pprData dats)
123
124 pprData :: CmmStatic -> SDoc
125 pprData (CmmString str) = pprBytes str
126 pprData (CmmUninitialised bytes) = text ".space " <> int bytes
127 pprData (CmmStaticLit lit) = pprDataItem lit
128
129 pprGloblDecl :: CLabel -> SDoc
130 pprGloblDecl lbl
131 | not (externallyVisibleCLabel lbl) = empty
132 | otherwise = text ".globl " <> ppr lbl
133
134 pprTypeAndSizeDecl :: CLabel -> SDoc
135 pprTypeAndSizeDecl lbl
136 = sdocWithPlatform $ \platform ->
137 if platformOS platform == OSLinux && externallyVisibleCLabel lbl
138 then text ".type " <>
139 ppr lbl <> text ", @object"
140 else empty
141
142 pprLabel :: CLabel -> SDoc
143 pprLabel lbl = pprGloblDecl lbl
144 $$ pprTypeAndSizeDecl lbl
145 $$ (ppr lbl <> char ':')
146
147 -- -----------------------------------------------------------------------------
148 -- pprInstr: print an 'Instr'
149
150 instance Outputable Instr where
151 ppr instr = pprInstr instr
152
153
154 pprReg :: Reg -> SDoc
155
156 pprReg r
157 = case r of
158 RegReal (RealRegSingle i) -> ppr_reg_no i
159 RegReal (RealRegPair{}) -> panic "PPC.pprReg: no reg pairs on this arch"
160 RegVirtual (VirtualRegI u) -> text "%vI_" <> pprUniqueAlways u
161 RegVirtual (VirtualRegHi u) -> text "%vHi_" <> pprUniqueAlways u
162 RegVirtual (VirtualRegF u) -> text "%vF_" <> pprUniqueAlways u
163 RegVirtual (VirtualRegD u) -> text "%vD_" <> pprUniqueAlways u
164 RegVirtual (VirtualRegSSE u) -> text "%vSSE_" <> pprUniqueAlways u
165 where
166 ppr_reg_no :: Int -> SDoc
167 ppr_reg_no i
168 | i <= 31 = int i -- GPRs
169 | i <= 63 = int (i-32) -- FPRs
170 | otherwise = text "very naughty powerpc register"
171
172
173
174 pprFormat :: Format -> SDoc
175 pprFormat x
176 = ptext (case x of
177 II8 -> sLit "b"
178 II16 -> sLit "h"
179 II32 -> sLit "w"
180 II64 -> sLit "d"
181 FF32 -> sLit "fs"
182 FF64 -> sLit "fd"
183 _ -> panic "PPC.Ppr.pprFormat: no match")
184
185
186 pprCond :: Cond -> SDoc
187 pprCond c
188 = ptext (case c of {
189 ALWAYS -> sLit "";
190 EQQ -> sLit "eq"; NE -> sLit "ne";
191 LTT -> sLit "lt"; GE -> sLit "ge";
192 GTT -> sLit "gt"; LE -> sLit "le";
193 LU -> sLit "lt"; GEU -> sLit "ge";
194 GU -> sLit "gt"; LEU -> sLit "le"; })
195
196
197 pprImm :: Imm -> SDoc
198
199 pprImm (ImmInt i) = int i
200 pprImm (ImmInteger i) = integer i
201 pprImm (ImmCLbl l) = ppr l
202 pprImm (ImmIndex l i) = ppr l <> char '+' <> int i
203 pprImm (ImmLit s) = s
204
205 pprImm (ImmFloat _) = text "naughty float immediate"
206 pprImm (ImmDouble _) = text "naughty double immediate"
207
208 pprImm (ImmConstantSum a b) = pprImm a <> char '+' <> pprImm b
209 pprImm (ImmConstantDiff a b) = pprImm a <> char '-'
210 <> lparen <> pprImm b <> rparen
211
212 pprImm (LO (ImmInt i)) = pprImm (LO (ImmInteger (toInteger i)))
213 pprImm (LO (ImmInteger i)) = pprImm (ImmInteger (toInteger lo16))
214 where
215 lo16 = fromInteger (i .&. 0xffff) :: Int16
216
217 pprImm (LO i)
218 = pprImm i <> text "@l"
219
220 pprImm (HI i)
221 = pprImm i <> text "@h"
222
223 pprImm (HA (ImmInt i)) = pprImm (HA (ImmInteger (toInteger i)))
224 pprImm (HA (ImmInteger i)) = pprImm (ImmInteger ha16)
225 where
226 ha16 = if lo16 >= 0x8000 then hi16+1 else hi16
227 hi16 = (i `shiftR` 16)
228 lo16 = i .&. 0xffff
229
230 pprImm (HA i)
231 = pprImm i <> text "@ha"
232
233 pprImm (HIGHERA i)
234 = pprImm i <> text "@highera"
235
236 pprImm (HIGHESTA i)
237 = pprImm i <> text "@highesta"
238
239
240 pprAddr :: AddrMode -> SDoc
241 pprAddr (AddrRegReg r1 r2)
242 = pprReg r1 <> char ',' <+> pprReg r2
243 pprAddr (AddrRegImm r1 (ImmInt i))
244 = hcat [ int i, char '(', pprReg r1, char ')' ]
245 pprAddr (AddrRegImm r1 (ImmInteger i))
246 = hcat [ integer i, char '(', pprReg r1, char ')' ]
247 pprAddr (AddrRegImm r1 imm)
248 = hcat [ pprImm imm, char '(', pprReg r1, char ')' ]
249
250
251 pprSectionAlign :: Section -> SDoc
252 pprSectionAlign sec@(Section seg _) =
253 sdocWithPlatform $ \platform ->
254 pprSectionHeader platform sec $$
255 pprAlignForSection seg
256
257 -- | Print appropriate alignment for the given section type.
258 pprAlignForSection :: SectionType -> SDoc
259 pprAlignForSection seg =
260 sdocWithPlatform $ \platform ->
261 let ppc64 = not $ target32Bit platform
262 in ptext $ case seg of
263 Text -> sLit ".align 2"
264 Data
265 | ppc64 -> sLit ".align 3"
266 | otherwise -> sLit ".align 2"
267 ReadOnlyData
268 | ppc64 -> sLit ".align 3"
269 | otherwise -> sLit ".align 2"
270 RelocatableReadOnlyData
271 | ppc64 -> sLit ".align 3"
272 | otherwise -> sLit ".align 2"
273 UninitialisedData
274 | ppc64 -> sLit ".align 3"
275 | otherwise -> sLit ".align 2"
276 ReadOnlyData16 -> sLit ".align 4"
277 -- TODO: This is copied from the ReadOnlyData case, but it can likely be
278 -- made more efficient.
279 CString
280 | ppc64 -> sLit ".align 3"
281 | otherwise -> sLit ".align 2"
282 OtherSection _ -> panic "PprMach.pprSectionAlign: unknown section"
283
284 pprDataItem :: CmmLit -> SDoc
285 pprDataItem lit
286 = sdocWithDynFlags $ \dflags ->
287 vcat (ppr_item (cmmTypeFormat $ cmmLitType dflags lit) lit dflags)
288 where
289 imm = litToImm lit
290 archPPC_64 dflags = not $ target32Bit $ targetPlatform dflags
291
292 ppr_item II8 _ _ = [text "\t.byte\t" <> pprImm imm]
293
294 ppr_item II32 _ _ = [text "\t.long\t" <> pprImm imm]
295
296 ppr_item II64 _ dflags
297 | archPPC_64 dflags = [text "\t.quad\t" <> pprImm imm]
298
299
300 ppr_item FF32 (CmmFloat r _) _
301 = let bs = floatToBytes (fromRational r)
302 in map (\b -> text "\t.byte\t" <> pprImm (ImmInt b)) bs
303
304 ppr_item FF64 (CmmFloat r _) _
305 = let bs = doubleToBytes (fromRational r)
306 in map (\b -> text "\t.byte\t" <> pprImm (ImmInt b)) bs
307
308 ppr_item II16 _ _ = [text "\t.short\t" <> pprImm imm]
309
310 ppr_item II64 (CmmInt x _) dflags
311 | not(archPPC_64 dflags) =
312 [text "\t.long\t"
313 <> int (fromIntegral
314 (fromIntegral (x `shiftR` 32) :: Word32)),
315 text "\t.long\t"
316 <> int (fromIntegral (fromIntegral x :: Word32))]
317
318 ppr_item _ _ _
319 = panic "PPC.Ppr.pprDataItem: no match"
320
321
322 pprInstr :: Instr -> SDoc
323
324 pprInstr (COMMENT _) = empty -- nuke 'em
325 {-
326 pprInstr (COMMENT s) =
327 if platformOS platform == OSLinux
328 then text "# " <> ftext s
329 else text "; " <> ftext s
330 -}
331 pprInstr (DELTA d)
332 = pprInstr (COMMENT (mkFastString ("\tdelta = " ++ show d)))
333
334 pprInstr (NEWBLOCK _)
335 = panic "PprMach.pprInstr: NEWBLOCK"
336
337 pprInstr (LDATA _ _)
338 = panic "PprMach.pprInstr: LDATA"
339
340 {-
341 pprInstr (SPILL reg slot)
342 = hcat [
343 text "\tSPILL",
344 char '\t',
345 pprReg reg,
346 comma,
347 text "SLOT" <> parens (int slot)]
348
349 pprInstr (RELOAD slot reg)
350 = hcat [
351 text "\tRELOAD",
352 char '\t',
353 text "SLOT" <> parens (int slot),
354 comma,
355 pprReg reg]
356 -}
357
358 pprInstr (LD fmt reg addr) = hcat [
359 char '\t',
360 text "l",
361 ptext (case fmt of
362 II8 -> sLit "bz"
363 II16 -> sLit "hz"
364 II32 -> sLit "wz"
365 II64 -> sLit "d"
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 text ", ",
375 pprAddr addr
376 ]
377
378 pprInstr (LDFAR fmt reg (AddrRegImm source off)) =
379 sdocWithPlatform $ \platform -> vcat [
380 pprInstr (ADDIS (tmpReg platform) source (HA off)),
381 pprInstr (LD fmt reg (AddrRegImm (tmpReg platform) (LO off)))
382 ]
383 pprInstr (LDFAR _ _ _) =
384 panic "PPC.Ppr.pprInstr LDFAR: no match"
385
386 pprInstr (LDR fmt reg1 addr) = hcat [
387 text "\tl",
388 case fmt of
389 II32 -> char 'w'
390 II64 -> char 'd'
391 _ -> panic "PPC.Ppr.Instr LDR: no match",
392 text "arx\t",
393 pprReg reg1,
394 text ", ",
395 pprAddr addr
396 ]
397
398 pprInstr (LA fmt reg addr) = hcat [
399 char '\t',
400 text "l",
401 ptext (case fmt of
402 II8 -> sLit "ba"
403 II16 -> sLit "ha"
404 II32 -> sLit "wa"
405 II64 -> sLit "d"
406 FF32 -> sLit "fs"
407 FF64 -> sLit "fd"
408 _ -> panic "PPC.Ppr.pprInstr: no match"
409 ),
410 case addr of AddrRegImm _ _ -> empty
411 AddrRegReg _ _ -> char 'x',
412 char '\t',
413 pprReg reg,
414 text ", ",
415 pprAddr addr
416 ]
417 pprInstr (ST fmt reg addr) = hcat [
418 char '\t',
419 text "st",
420 pprFormat fmt,
421 case addr of AddrRegImm _ _ -> empty
422 AddrRegReg _ _ -> char 'x',
423 char '\t',
424 pprReg reg,
425 text ", ",
426 pprAddr addr
427 ]
428 pprInstr (STFAR fmt reg (AddrRegImm source off)) =
429 sdocWithPlatform $ \platform -> vcat [
430 pprInstr (ADDIS (tmpReg platform) source (HA off)),
431 pprInstr (ST fmt reg (AddrRegImm (tmpReg platform) (LO off)))
432 ]
433 pprInstr (STFAR _ _ _) =
434 panic "PPC.Ppr.pprInstr STFAR: no match"
435 pprInstr (STU fmt reg addr) = hcat [
436 char '\t',
437 text "st",
438 pprFormat fmt,
439 char 'u',
440 case addr of AddrRegImm _ _ -> empty
441 AddrRegReg _ _ -> char 'x',
442 char '\t',
443 pprReg reg,
444 text ", ",
445 pprAddr addr
446 ]
447 pprInstr (STC fmt reg1 addr) = hcat [
448 text "\tst",
449 case fmt of
450 II32 -> char 'w'
451 II64 -> char 'd'
452 _ -> panic "PPC.Ppr.Instr STC: no match",
453 text "cx.\t",
454 pprReg reg1,
455 text ", ",
456 pprAddr addr
457 ]
458 pprInstr (LIS reg imm) = hcat [
459 char '\t',
460 text "lis",
461 char '\t',
462 pprReg reg,
463 text ", ",
464 pprImm imm
465 ]
466 pprInstr (LI reg imm) = hcat [
467 char '\t',
468 text "li",
469 char '\t',
470 pprReg reg,
471 text ", ",
472 pprImm imm
473 ]
474 pprInstr (MR reg1 reg2)
475 | reg1 == reg2 = empty
476 | otherwise = hcat [
477 char '\t',
478 sdocWithPlatform $ \platform ->
479 case targetClassOfReg platform reg1 of
480 RcInteger -> text "mr"
481 _ -> text "fmr",
482 char '\t',
483 pprReg reg1,
484 text ", ",
485 pprReg reg2
486 ]
487 pprInstr (CMP fmt reg ri) = hcat [
488 char '\t',
489 op,
490 char '\t',
491 pprReg reg,
492 text ", ",
493 pprRI ri
494 ]
495 where
496 op = hcat [
497 text "cmp",
498 pprFormat fmt,
499 case ri of
500 RIReg _ -> empty
501 RIImm _ -> char 'i'
502 ]
503 pprInstr (CMPL fmt reg ri) = hcat [
504 char '\t',
505 op,
506 char '\t',
507 pprReg reg,
508 text ", ",
509 pprRI ri
510 ]
511 where
512 op = hcat [
513 text "cmpl",
514 pprFormat fmt,
515 case ri of
516 RIReg _ -> empty
517 RIImm _ -> char 'i'
518 ]
519 pprInstr (BCC cond blockid prediction) = hcat [
520 char '\t',
521 text "b",
522 pprCond cond,
523 pprPrediction prediction,
524 char '\t',
525 ppr lbl
526 ]
527 where lbl = mkLocalBlockLabel (getUnique blockid)
528 pprPrediction p = case p of
529 Nothing -> empty
530 Just True -> char '+'
531 Just False -> char '-'
532
533 pprInstr (BCCFAR cond blockid prediction) = vcat [
534 hcat [
535 text "\tb",
536 pprCond (condNegate cond),
537 neg_prediction,
538 text "\t$+8"
539 ],
540 hcat [
541 text "\tb\t",
542 ppr lbl
543 ]
544 ]
545 where lbl = mkLocalBlockLabel (getUnique blockid)
546 neg_prediction = case prediction of
547 Nothing -> empty
548 Just True -> char '-'
549 Just False -> char '+'
550
551 pprInstr (JMP lbl)
552 -- We never jump to ForeignLabels; if we ever do, c.f. handling for "BL"
553 | isForeignLabel lbl = panic "PPC.Ppr.pprInstr: JMP to ForeignLabel"
554 | otherwise =
555 hcat [ -- an alias for b that takes a CLabel
556 char '\t',
557 text "b",
558 char '\t',
559 ppr lbl
560 ]
561
562 pprInstr (MTCTR reg) = hcat [
563 char '\t',
564 text "mtctr",
565 char '\t',
566 pprReg reg
567 ]
568 pprInstr (BCTR _ _) = hcat [
569 char '\t',
570 text "bctr"
571 ]
572 pprInstr (BL lbl _) = do
573 sdocWithPlatform $ \platform -> case platformOS platform of
574 OSAIX ->
575 -- On AIX, "printf" denotes a function-descriptor (for use
576 -- by function pointers), whereas the actual entry-code
577 -- address is denoted by the dot-prefixed ".printf" label.
578 -- Moreover, the PPC NCG only ever emits a BL instruction
579 -- for calling C ABI functions. Most of the time these calls
580 -- originate from FFI imports and have a 'ForeignLabel',
581 -- but when profiling the codegen inserts calls via
582 -- 'emitRtsCallGen' which are 'CmmLabel's even though
583 -- they'd technically be more like 'ForeignLabel's.
584 hcat [
585 text "\tbl\t.",
586 ppr lbl
587 ]
588 _ ->
589 hcat [
590 text "\tbl\t",
591 ppr lbl
592 ]
593 pprInstr (BCTRL _) = hcat [
594 char '\t',
595 text "bctrl"
596 ]
597 pprInstr (ADD reg1 reg2 ri) = pprLogic (sLit "add") reg1 reg2 ri
598 pprInstr (ADDIS reg1 reg2 imm) = hcat [
599 char '\t',
600 text "addis",
601 char '\t',
602 pprReg reg1,
603 text ", ",
604 pprReg reg2,
605 text ", ",
606 pprImm imm
607 ]
608
609 pprInstr (ADDO reg1 reg2 reg3) = pprLogic (sLit "addo") reg1 reg2 (RIReg reg3)
610 pprInstr (ADDC reg1 reg2 reg3) = pprLogic (sLit "addc") reg1 reg2 (RIReg reg3)
611 pprInstr (ADDE reg1 reg2 reg3) = pprLogic (sLit "adde") reg1 reg2 (RIReg reg3)
612 pprInstr (ADDZE reg1 reg2) = pprUnary (sLit "addze") reg1 reg2
613 pprInstr (SUBF reg1 reg2 reg3) = pprLogic (sLit "subf") reg1 reg2 (RIReg reg3)
614 pprInstr (SUBFO reg1 reg2 reg3) = pprLogic (sLit "subfo") reg1 reg2 (RIReg reg3)
615 pprInstr (SUBFC reg1 reg2 ri) = hcat [
616 char '\t',
617 text "subf",
618 case ri of
619 RIReg _ -> empty
620 RIImm _ -> char 'i',
621 text "c\t",
622 pprReg reg1,
623 text ", ",
624 pprReg reg2,
625 text ", ",
626 pprRI ri
627 ]
628 pprInstr (SUBFE reg1 reg2 reg3) = pprLogic (sLit "subfe") reg1 reg2 (RIReg reg3)
629 pprInstr (MULL fmt reg1 reg2 ri) = pprMul fmt reg1 reg2 ri
630 pprInstr (MULLO fmt reg1 reg2 reg3) = hcat [
631 char '\t',
632 text "mull",
633 case fmt of
634 II32 -> char 'w'
635 II64 -> char 'd'
636 _ -> panic "PPC: illegal format",
637 text "o\t",
638 pprReg reg1,
639 text ", ",
640 pprReg reg2,
641 text ", ",
642 pprReg reg3
643 ]
644 pprInstr (MFOV fmt reg) = vcat [
645 hcat [
646 char '\t',
647 text "mfxer",
648 char '\t',
649 pprReg reg
650 ],
651 hcat [
652 char '\t',
653 text "extr",
654 case fmt of
655 II32 -> char 'w'
656 II64 -> char 'd'
657 _ -> panic "PPC: illegal format",
658 text "i\t",
659 pprReg reg,
660 text ", ",
661 pprReg reg,
662 text ", 1, ",
663 case fmt of
664 II32 -> text "1"
665 II64 -> text "33"
666 _ -> panic "PPC: illegal format"
667 ]
668 ]
669
670 pprInstr (MULHU fmt reg1 reg2 reg3) = hcat [
671 char '\t',
672 text "mulh",
673 case fmt of
674 II32 -> char 'w'
675 II64 -> char 'd'
676 _ -> panic "PPC: illegal format",
677 text "u\t",
678 pprReg reg1,
679 text ", ",
680 pprReg reg2,
681 text ", ",
682 pprReg reg3
683 ]
684
685 pprInstr (DIV fmt sgn reg1 reg2 reg3) = pprDiv fmt sgn reg1 reg2 reg3
686
687 -- for some reason, "andi" doesn't exist.
688 -- we'll use "andi." instead.
689 pprInstr (AND reg1 reg2 (RIImm imm)) = hcat [
690 char '\t',
691 text "andi.",
692 char '\t',
693 pprReg reg1,
694 text ", ",
695 pprReg reg2,
696 text ", ",
697 pprImm imm
698 ]
699 pprInstr (AND reg1 reg2 ri) = pprLogic (sLit "and") reg1 reg2 ri
700 pprInstr (ANDC reg1 reg2 reg3) = pprLogic (sLit "andc") reg1 reg2 (RIReg reg3)
701 pprInstr (NAND reg1 reg2 reg3) = pprLogic (sLit "nand") reg1 reg2 (RIReg reg3)
702
703 pprInstr (OR reg1 reg2 ri) = pprLogic (sLit "or") reg1 reg2 ri
704 pprInstr (XOR reg1 reg2 ri) = pprLogic (sLit "xor") reg1 reg2 ri
705
706 pprInstr (ORIS reg1 reg2 imm) = hcat [
707 char '\t',
708 text "oris",
709 char '\t',
710 pprReg reg1,
711 text ", ",
712 pprReg reg2,
713 text ", ",
714 pprImm imm
715 ]
716
717 pprInstr (XORIS reg1 reg2 imm) = hcat [
718 char '\t',
719 text "xoris",
720 char '\t',
721 pprReg reg1,
722 text ", ",
723 pprReg reg2,
724 text ", ",
725 pprImm imm
726 ]
727
728 pprInstr (EXTS fmt reg1 reg2) = hcat [
729 char '\t',
730 text "exts",
731 pprFormat fmt,
732 char '\t',
733 pprReg reg1,
734 text ", ",
735 pprReg reg2
736 ]
737 pprInstr (CNTLZ fmt reg1 reg2) = hcat [
738 char '\t',
739 text "cntlz",
740 case fmt of
741 II32 -> char 'w'
742 II64 -> char 'd'
743 _ -> panic "PPC: illegal format",
744 char '\t',
745 pprReg reg1,
746 text ", ",
747 pprReg reg2
748 ]
749
750 pprInstr (NEG reg1 reg2) = pprUnary (sLit "neg") reg1 reg2
751 pprInstr (NOT reg1 reg2) = pprUnary (sLit "not") reg1 reg2
752
753 pprInstr (SR II32 reg1 reg2 (RIImm (ImmInt i))) | i < 0 || i > 31 =
754 -- Handle the case where we are asked to shift a 32 bit register by
755 -- less than zero or more than 31 bits. We convert this into a clear
756 -- of the destination register.
757 -- Fixes ticket https://gitlab.haskell.org/ghc/ghc/issues/5900
758 pprInstr (XOR reg1 reg2 (RIReg reg2))
759
760 pprInstr (SL II32 reg1 reg2 (RIImm (ImmInt i))) | i < 0 || i > 31 =
761 -- As above for SR, but for left shifts.
762 -- Fixes ticket https://gitlab.haskell.org/ghc/ghc/issues/10870
763 pprInstr (XOR reg1 reg2 (RIReg reg2))
764
765 pprInstr (SRA II32 reg1 reg2 (RIImm (ImmInt i))) | i > 31 =
766 -- PT: I don't know what to do for negative shift amounts:
767 -- For now just panic.
768 --
769 -- For shift amounts greater than 31 set all bit to the
770 -- value of the sign bit, this also what sraw does.
771 pprInstr (SRA II32 reg1 reg2 (RIImm (ImmInt 31)))
772
773 pprInstr (SL fmt reg1 reg2 ri) =
774 let op = case fmt of
775 II32 -> "slw"
776 II64 -> "sld"
777 _ -> panic "PPC.Ppr.pprInstr: shift illegal size"
778 in pprLogic (sLit op) reg1 reg2 (limitShiftRI fmt ri)
779
780 pprInstr (SR fmt reg1 reg2 ri) =
781 let op = case fmt of
782 II32 -> "srw"
783 II64 -> "srd"
784 _ -> panic "PPC.Ppr.pprInstr: shift illegal size"
785 in pprLogic (sLit op) reg1 reg2 (limitShiftRI fmt ri)
786
787 pprInstr (SRA fmt reg1 reg2 ri) =
788 let op = case fmt of
789 II32 -> "sraw"
790 II64 -> "srad"
791 _ -> panic "PPC.Ppr.pprInstr: shift illegal size"
792 in pprLogic (sLit op) reg1 reg2 (limitShiftRI fmt ri)
793
794 pprInstr (RLWINM reg1 reg2 sh mb me) = hcat [
795 text "\trlwinm\t",
796 pprReg reg1,
797 text ", ",
798 pprReg reg2,
799 text ", ",
800 int sh,
801 text ", ",
802 int mb,
803 text ", ",
804 int me
805 ]
806
807 pprInstr (CLRLI fmt reg1 reg2 n) = hcat [
808 text "\tclrl",
809 pprFormat fmt,
810 text "i ",
811 pprReg reg1,
812 text ", ",
813 pprReg reg2,
814 text ", ",
815 int n
816 ]
817 pprInstr (CLRRI fmt reg1 reg2 n) = hcat [
818 text "\tclrr",
819 pprFormat fmt,
820 text "i ",
821 pprReg reg1,
822 text ", ",
823 pprReg reg2,
824 text ", ",
825 int n
826 ]
827
828 pprInstr (FADD fmt reg1 reg2 reg3) = pprBinaryF (sLit "fadd") fmt reg1 reg2 reg3
829 pprInstr (FSUB fmt reg1 reg2 reg3) = pprBinaryF (sLit "fsub") fmt reg1 reg2 reg3
830 pprInstr (FMUL fmt reg1 reg2 reg3) = pprBinaryF (sLit "fmul") fmt reg1 reg2 reg3
831 pprInstr (FDIV fmt reg1 reg2 reg3) = pprBinaryF (sLit "fdiv") fmt reg1 reg2 reg3
832 pprInstr (FABS reg1 reg2) = pprUnary (sLit "fabs") reg1 reg2
833 pprInstr (FNEG reg1 reg2) = pprUnary (sLit "fneg") reg1 reg2
834
835 pprInstr (FCMP reg1 reg2) = hcat [
836 char '\t',
837 text "fcmpu\t0, ",
838 -- Note: we're using fcmpu, not fcmpo
839 -- The difference is with fcmpo, compare with NaN is an invalid operation.
840 -- We don't handle invalid fp ops, so we don't care.
841 -- Morever, we use `fcmpu 0, ...` rather than `fcmpu cr0, ...` for
842 -- better portability since some non-GNU assembler (such as
843 -- IBM's `as`) tend not to support the symbolic register name cr0.
844 -- This matches the syntax that GCC seems to emit for PPC targets.
845 pprReg reg1,
846 text ", ",
847 pprReg reg2
848 ]
849
850 pprInstr (FCTIWZ reg1 reg2) = pprUnary (sLit "fctiwz") reg1 reg2
851 pprInstr (FCTIDZ reg1 reg2) = pprUnary (sLit "fctidz") reg1 reg2
852 pprInstr (FCFID reg1 reg2) = pprUnary (sLit "fcfid") reg1 reg2
853 pprInstr (FRSP reg1 reg2) = pprUnary (sLit "frsp") reg1 reg2
854
855 pprInstr (CRNOR dst src1 src2) = hcat [
856 text "\tcrnor\t",
857 int dst,
858 text ", ",
859 int src1,
860 text ", ",
861 int src2
862 ]
863
864 pprInstr (MFCR reg) = hcat [
865 char '\t',
866 text "mfcr",
867 char '\t',
868 pprReg reg
869 ]
870
871 pprInstr (MFLR reg) = hcat [
872 char '\t',
873 text "mflr",
874 char '\t',
875 pprReg reg
876 ]
877
878 pprInstr (FETCHPC reg) = vcat [
879 text "\tbcl\t20,31,1f",
880 hcat [ text "1:\tmflr\t", pprReg reg ]
881 ]
882
883 pprInstr HWSYNC = text "\tsync"
884
885 pprInstr ISYNC = text "\tisync"
886
887 pprInstr LWSYNC = text "\tlwsync"
888
889 pprInstr NOP = text "\tnop"
890
891
892 pprLogic :: PtrString -> Reg -> Reg -> RI -> SDoc
893 pprLogic op reg1 reg2 ri = hcat [
894 char '\t',
895 ptext op,
896 case ri of
897 RIReg _ -> empty
898 RIImm _ -> char 'i',
899 char '\t',
900 pprReg reg1,
901 text ", ",
902 pprReg reg2,
903 text ", ",
904 pprRI ri
905 ]
906
907
908 pprMul :: Format -> Reg -> Reg -> RI -> SDoc
909 pprMul fmt reg1 reg2 ri = hcat [
910 char '\t',
911 text "mull",
912 case ri of
913 RIReg _ -> case fmt of
914 II32 -> char 'w'
915 II64 -> char 'd'
916 _ -> panic "PPC: illegal format"
917 RIImm _ -> char 'i',
918 char '\t',
919 pprReg reg1,
920 text ", ",
921 pprReg reg2,
922 text ", ",
923 pprRI ri
924 ]
925
926
927 pprDiv :: Format -> Bool -> Reg -> Reg -> Reg -> SDoc
928 pprDiv fmt sgn reg1 reg2 reg3 = hcat [
929 char '\t',
930 text "div",
931 case fmt of
932 II32 -> char 'w'
933 II64 -> char 'd'
934 _ -> panic "PPC: illegal format",
935 if sgn then empty else char 'u',
936 char '\t',
937 pprReg reg1,
938 text ", ",
939 pprReg reg2,
940 text ", ",
941 pprReg reg3
942 ]
943
944
945 pprUnary :: PtrString -> Reg -> Reg -> SDoc
946 pprUnary op reg1 reg2 = hcat [
947 char '\t',
948 ptext op,
949 char '\t',
950 pprReg reg1,
951 text ", ",
952 pprReg reg2
953 ]
954
955
956 pprBinaryF :: PtrString -> Format -> Reg -> Reg -> Reg -> SDoc
957 pprBinaryF op fmt reg1 reg2 reg3 = hcat [
958 char '\t',
959 ptext op,
960 pprFFormat fmt,
961 char '\t',
962 pprReg reg1,
963 text ", ",
964 pprReg reg2,
965 text ", ",
966 pprReg reg3
967 ]
968
969 pprRI :: RI -> SDoc
970 pprRI (RIReg r) = pprReg r
971 pprRI (RIImm r) = pprImm r
972
973
974 pprFFormat :: Format -> SDoc
975 pprFFormat FF64 = empty
976 pprFFormat FF32 = char 's'
977 pprFFormat _ = panic "PPC.Ppr.pprFFormat: no match"
978
979 -- limit immediate argument for shift instruction to range 0..63
980 -- for 64 bit size and 0..32 otherwise
981 limitShiftRI :: Format -> RI -> RI
982 limitShiftRI II64 (RIImm (ImmInt i)) | i > 63 || i < 0 =
983 panic $ "PPC.Ppr: Shift by " ++ show i ++ " bits is not allowed."
984 limitShiftRI II32 (RIImm (ImmInt i)) | i > 31 || i < 0 =
985 panic $ "PPC.Ppr: 32 bit: Shift by " ++ show i ++ " bits is not allowed."
986 limitShiftRI _ x = x