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