99f9ab77ea155f3787ee06496a5a90cb95be6064
[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 pprFormat,
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 Format
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 pprFormat :: Format -> SDoc
240 pprFormat 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.pprFormat: 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 (cmmTypeFormat $ 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 fmt reg addr) = hcat [
422 char '\t',
423 ptext (sLit "l"),
424 ptext (case fmt 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 (LDFAR fmt reg (AddrRegImm source off)) =
441 sdocWithPlatform $ \platform -> vcat [
442 pprInstr (ADDIS (tmpReg platform) source (HA off)),
443 pprInstr (LD fmt reg (AddrRegImm (tmpReg platform) (LO off)))
444 ]
445
446 pprInstr (LDFAR _ _ _) =
447 panic "PPC.Ppr.pprInstr LDFAR: no match"
448
449 pprInstr (LA fmt reg addr) = hcat [
450 char '\t',
451 ptext (sLit "l"),
452 ptext (case fmt of
453 II8 -> sLit "ba"
454 II16 -> sLit "ha"
455 II32 -> sLit "wa"
456 II64 -> sLit "d"
457 FF32 -> sLit "fs"
458 FF64 -> sLit "fd"
459 _ -> panic "PPC.Ppr.pprInstr: no match"
460 ),
461 case addr of AddrRegImm _ _ -> empty
462 AddrRegReg _ _ -> char 'x',
463 char '\t',
464 pprReg reg,
465 ptext (sLit ", "),
466 pprAddr addr
467 ]
468 pprInstr (ST fmt reg addr) = hcat [
469 char '\t',
470 ptext (sLit "st"),
471 pprFormat fmt,
472 case addr of AddrRegImm _ _ -> empty
473 AddrRegReg _ _ -> char 'x',
474 char '\t',
475 pprReg reg,
476 ptext (sLit ", "),
477 pprAddr addr
478 ]
479 pprInstr (STFAR fmt reg (AddrRegImm source off)) =
480 sdocWithPlatform $ \platform -> vcat [
481 pprInstr (ADDIS (tmpReg platform) source (HA off)),
482 pprInstr (ST fmt reg (AddrRegImm (tmpReg platform) (LO off)))
483 ]
484
485 pprInstr (STFAR _ _ _) =
486 panic "PPC.Ppr.pprInstr STFAR: no match"
487 pprInstr (STU fmt reg addr) = hcat [
488 char '\t',
489 ptext (sLit "st"),
490 pprFormat fmt,
491 ptext (sLit "u\t"),
492 case addr of AddrRegImm _ _ -> empty
493 AddrRegReg _ _ -> char 'x',
494 pprReg reg,
495 ptext (sLit ", "),
496 pprAddr addr
497 ]
498 pprInstr (LIS reg imm) = hcat [
499 char '\t',
500 ptext (sLit "lis"),
501 char '\t',
502 pprReg reg,
503 ptext (sLit ", "),
504 pprImm imm
505 ]
506 pprInstr (LI reg imm) = hcat [
507 char '\t',
508 ptext (sLit "li"),
509 char '\t',
510 pprReg reg,
511 ptext (sLit ", "),
512 pprImm imm
513 ]
514 pprInstr (MR reg1 reg2)
515 | reg1 == reg2 = empty
516 | otherwise = hcat [
517 char '\t',
518 sdocWithPlatform $ \platform ->
519 case targetClassOfReg platform reg1 of
520 RcInteger -> ptext (sLit "mr")
521 _ -> ptext (sLit "fmr"),
522 char '\t',
523 pprReg reg1,
524 ptext (sLit ", "),
525 pprReg reg2
526 ]
527 pprInstr (CMP fmt reg ri) = hcat [
528 char '\t',
529 op,
530 char '\t',
531 pprReg reg,
532 ptext (sLit ", "),
533 pprRI ri
534 ]
535 where
536 op = hcat [
537 ptext (sLit "cmp"),
538 pprFormat fmt,
539 case ri of
540 RIReg _ -> empty
541 RIImm _ -> char 'i'
542 ]
543 pprInstr (CMPL fmt reg ri) = hcat [
544 char '\t',
545 op,
546 char '\t',
547 pprReg reg,
548 ptext (sLit ", "),
549 pprRI ri
550 ]
551 where
552 op = hcat [
553 ptext (sLit "cmpl"),
554 pprFormat fmt,
555 case ri of
556 RIReg _ -> empty
557 RIImm _ -> char 'i'
558 ]
559 pprInstr (BCC cond blockid) = hcat [
560 char '\t',
561 ptext (sLit "b"),
562 pprCond cond,
563 char '\t',
564 ppr lbl
565 ]
566 where lbl = mkAsmTempLabel (getUnique blockid)
567
568 pprInstr (BCCFAR cond blockid) = vcat [
569 hcat [
570 ptext (sLit "\tb"),
571 pprCond (condNegate cond),
572 ptext (sLit "\t$+8")
573 ],
574 hcat [
575 ptext (sLit "\tb\t"),
576 ppr lbl
577 ]
578 ]
579 where lbl = mkAsmTempLabel (getUnique blockid)
580
581 pprInstr (JMP lbl) = hcat [ -- an alias for b that takes a CLabel
582 char '\t',
583 ptext (sLit "b"),
584 char '\t',
585 ppr lbl
586 ]
587
588 pprInstr (MTCTR reg) = hcat [
589 char '\t',
590 ptext (sLit "mtctr"),
591 char '\t',
592 pprReg reg
593 ]
594 pprInstr (BCTR _ _) = hcat [
595 char '\t',
596 ptext (sLit "bctr")
597 ]
598 pprInstr (BL lbl _) = hcat [
599 ptext (sLit "\tbl\t"),
600 ppr lbl
601 ]
602 pprInstr (BCTRL _) = hcat [
603 char '\t',
604 ptext (sLit "bctrl")
605 ]
606 pprInstr (ADD reg1 reg2 ri) = pprLogic (sLit "add") reg1 reg2 ri
607 pprInstr (ADDI reg1 reg2 imm) = hcat [
608 char '\t',
609 ptext (sLit "addi"),
610 char '\t',
611 pprReg reg1,
612 ptext (sLit ", "),
613 pprReg reg2,
614 ptext (sLit ", "),
615 pprImm imm
616 ]
617 pprInstr (ADDIS reg1 reg2 imm) = hcat [
618 char '\t',
619 ptext (sLit "addis"),
620 char '\t',
621 pprReg reg1,
622 ptext (sLit ", "),
623 pprReg reg2,
624 ptext (sLit ", "),
625 pprImm imm
626 ]
627
628 pprInstr (ADDC reg1 reg2 reg3) = pprLogic (sLit "addc") reg1 reg2 (RIReg reg3)
629 pprInstr (ADDE reg1 reg2 reg3) = pprLogic (sLit "adde") reg1 reg2 (RIReg reg3)
630 pprInstr (SUBF reg1 reg2 reg3) = pprLogic (sLit "subf") reg1 reg2 (RIReg reg3)
631 pprInstr (SUBFC reg1 reg2 reg3) = pprLogic (sLit "subfc") reg1 reg2 (RIReg reg3)
632 pprInstr (SUBFE reg1 reg2 reg3) = pprLogic (sLit "subfe") reg1 reg2 (RIReg reg3)
633 pprInstr (MULLD reg1 reg2 ri@(RIReg _)) = pprLogic (sLit "mulld") reg1 reg2 ri
634 pprInstr (MULLW reg1 reg2 ri@(RIReg _)) = pprLogic (sLit "mullw") reg1 reg2 ri
635 pprInstr (MULLD reg1 reg2 ri@(RIImm _)) = pprLogic (sLit "mull") reg1 reg2 ri
636 pprInstr (MULLW reg1 reg2 ri@(RIImm _)) = pprLogic (sLit "mull") reg1 reg2 ri
637 pprInstr (DIVW reg1 reg2 reg3) = pprLogic (sLit "divw") reg1 reg2 (RIReg reg3)
638 pprInstr (DIVD reg1 reg2 reg3) = pprLogic (sLit "divd") reg1 reg2 (RIReg reg3)
639 pprInstr (DIVWU reg1 reg2 reg3) = pprLogic (sLit "divwu") reg1 reg2 (RIReg reg3)
640 pprInstr (DIVDU reg1 reg2 reg3) = pprLogic (sLit "divdu") reg1 reg2 (RIReg reg3)
641
642 pprInstr (MULLW_MayOflo reg1 reg2 reg3) = vcat [
643 hcat [ ptext (sLit "\tmullwo\t"), pprReg reg1, ptext (sLit ", "),
644 pprReg reg2, ptext (sLit ", "),
645 pprReg reg3 ],
646 hcat [ ptext (sLit "\tmfxer\t"), pprReg reg1 ],
647 hcat [ ptext (sLit "\trlwinm\t"), pprReg reg1, ptext (sLit ", "),
648 pprReg reg1, ptext (sLit ", "),
649 ptext (sLit "2, 31, 31") ]
650 ]
651 pprInstr (MULLD_MayOflo reg1 reg2 reg3) = vcat [
652 hcat [ ptext (sLit "\tmulldo\t"), pprReg reg1, ptext (sLit ", "),
653 pprReg reg2, ptext (sLit ", "),
654 pprReg reg3 ],
655 hcat [ ptext (sLit "\tmfxer\t"), pprReg reg1 ],
656 hcat [ ptext (sLit "\trlwinm\t"), pprReg reg1, ptext (sLit ", "),
657 pprReg reg1, ptext (sLit ", "),
658 ptext (sLit "2, 31, 31") ]
659 ]
660
661 -- for some reason, "andi" doesn't exist.
662 -- we'll use "andi." instead.
663 pprInstr (AND reg1 reg2 (RIImm imm)) = hcat [
664 char '\t',
665 ptext (sLit "andi."),
666 char '\t',
667 pprReg reg1,
668 ptext (sLit ", "),
669 pprReg reg2,
670 ptext (sLit ", "),
671 pprImm imm
672 ]
673 pprInstr (AND reg1 reg2 ri) = pprLogic (sLit "and") reg1 reg2 ri
674
675 pprInstr (OR reg1 reg2 ri) = pprLogic (sLit "or") reg1 reg2 ri
676 pprInstr (XOR reg1 reg2 ri) = pprLogic (sLit "xor") reg1 reg2 ri
677
678 pprInstr (ORIS reg1 reg2 imm) = hcat [
679 char '\t',
680 ptext (sLit "oris"),
681 char '\t',
682 pprReg reg1,
683 ptext (sLit ", "),
684 pprReg reg2,
685 ptext (sLit ", "),
686 pprImm imm
687 ]
688
689 pprInstr (XORIS reg1 reg2 imm) = hcat [
690 char '\t',
691 ptext (sLit "xoris"),
692 char '\t',
693 pprReg reg1,
694 ptext (sLit ", "),
695 pprReg reg2,
696 ptext (sLit ", "),
697 pprImm imm
698 ]
699
700 pprInstr (EXTS fmt reg1 reg2) = hcat [
701 char '\t',
702 ptext (sLit "exts"),
703 pprFormat fmt,
704 char '\t',
705 pprReg reg1,
706 ptext (sLit ", "),
707 pprReg reg2
708 ]
709
710 pprInstr (NEG reg1 reg2) = pprUnary (sLit "neg") reg1 reg2
711 pprInstr (NOT reg1 reg2) = pprUnary (sLit "not") reg1 reg2
712
713 pprInstr (SR II32 reg1 reg2 (RIImm (ImmInt i))) | i < 0 || i > 31 =
714 -- Handle the case where we are asked to shift a 32 bit register by
715 -- less than zero or more than 31 bits. We convert this into a clear
716 -- of the destination register.
717 -- Fixes ticket http://ghc.haskell.org/trac/ghc/ticket/5900
718 pprInstr (XOR reg1 reg2 (RIReg reg2))
719
720 pprInstr (SL II32 reg1 reg2 (RIImm (ImmInt i))) | i < 0 || i > 31 =
721 -- As above for SR, but for left shifts.
722 -- Fixes ticket http://ghc.haskell.org/trac/ghc/ticket/10870
723 pprInstr (XOR reg1 reg2 (RIReg reg2))
724
725 pprInstr (SRA II32 reg1 reg2 (RIImm (ImmInt i))) | i > 31 =
726 -- PT: I don't know what to do for negative shift amounts:
727 -- For now just panic.
728 --
729 -- For shift amounts greater than 31 set all bit to the
730 -- value of the sign bit, this also what sraw does.
731 pprInstr (SRA II32 reg1 reg2 (RIImm (ImmInt 31)))
732
733 pprInstr (SL fmt reg1 reg2 ri) =
734 let op = case fmt of
735 II32 -> "slw"
736 II64 -> "sld"
737 _ -> panic "PPC.Ppr.pprInstr: shift illegal size"
738 in pprLogic (sLit op) reg1 reg2 (limitShiftRI fmt ri)
739
740 pprInstr (SR fmt reg1 reg2 ri) =
741 let op = case fmt of
742 II32 -> "srw"
743 II64 -> "srd"
744 _ -> panic "PPC.Ppr.pprInstr: shift illegal size"
745 in pprLogic (sLit op) reg1 reg2 (limitShiftRI fmt ri)
746
747 pprInstr (SRA fmt reg1 reg2 ri) =
748 let op = case fmt of
749 II32 -> "sraw"
750 II64 -> "srad"
751 _ -> panic "PPC.Ppr.pprInstr: shift illegal size"
752 in pprLogic (sLit op) reg1 reg2 (limitShiftRI fmt ri)
753
754 pprInstr (RLWINM reg1 reg2 sh mb me) = hcat [
755 ptext (sLit "\trlwinm\t"),
756 pprReg reg1,
757 ptext (sLit ", "),
758 pprReg reg2,
759 ptext (sLit ", "),
760 int sh,
761 ptext (sLit ", "),
762 int mb,
763 ptext (sLit ", "),
764 int me
765 ]
766
767 pprInstr (FADD fmt reg1 reg2 reg3) = pprBinaryF (sLit "fadd") fmt reg1 reg2 reg3
768 pprInstr (FSUB fmt reg1 reg2 reg3) = pprBinaryF (sLit "fsub") fmt reg1 reg2 reg3
769 pprInstr (FMUL fmt reg1 reg2 reg3) = pprBinaryF (sLit "fmul") fmt reg1 reg2 reg3
770 pprInstr (FDIV fmt reg1 reg2 reg3) = pprBinaryF (sLit "fdiv") fmt reg1 reg2 reg3
771 pprInstr (FNEG reg1 reg2) = pprUnary (sLit "fneg") reg1 reg2
772
773 pprInstr (FCMP reg1 reg2) = hcat [
774 char '\t',
775 ptext (sLit "fcmpu\tcr0, "),
776 -- Note: we're using fcmpu, not fcmpo
777 -- The difference is with fcmpo, compare with NaN is an invalid operation.
778 -- We don't handle invalid fp ops, so we don't care
779 pprReg reg1,
780 ptext (sLit ", "),
781 pprReg reg2
782 ]
783
784 pprInstr (FCTIWZ reg1 reg2) = pprUnary (sLit "fctiwz") reg1 reg2
785 pprInstr (FCTIDZ reg1 reg2) = pprUnary (sLit "fctidz") reg1 reg2
786 pprInstr (FCFID reg1 reg2) = pprUnary (sLit "fcfid") reg1 reg2
787 pprInstr (FRSP reg1 reg2) = pprUnary (sLit "frsp") reg1 reg2
788
789 pprInstr (CRNOR dst src1 src2) = hcat [
790 ptext (sLit "\tcrnor\t"),
791 int dst,
792 ptext (sLit ", "),
793 int src1,
794 ptext (sLit ", "),
795 int src2
796 ]
797
798 pprInstr (MFCR reg) = hcat [
799 char '\t',
800 ptext (sLit "mfcr"),
801 char '\t',
802 pprReg reg
803 ]
804
805 pprInstr (MFLR reg) = hcat [
806 char '\t',
807 ptext (sLit "mflr"),
808 char '\t',
809 pprReg reg
810 ]
811
812 pprInstr (FETCHPC reg) = vcat [
813 ptext (sLit "\tbcl\t20,31,1f"),
814 hcat [ ptext (sLit "1:\tmflr\t"), pprReg reg ]
815 ]
816
817 pprInstr (FETCHTOC reg lab) = vcat [
818 hcat [ ptext (sLit "0:\taddis\t"), pprReg reg,
819 ptext (sLit ",12,.TOC.-0b@ha") ],
820 hcat [ ptext (sLit "\taddi\t"), pprReg reg,
821 char ',', pprReg reg,
822 ptext (sLit ",.TOC.-0b@l") ],
823 hcat [ ptext (sLit "\t.localentry\t"),
824 ppr lab,
825 ptext (sLit ",.-"),
826 ppr lab]
827 ]
828
829 pprInstr LWSYNC = ptext (sLit "\tlwsync")
830
831 pprInstr NOP = ptext (sLit "\tnop")
832
833 pprInstr (UPDATE_SP fmt amount@(ImmInt offset))
834 | fits16Bits offset = vcat [
835 pprInstr (LD fmt r0 (AddrRegImm sp (ImmInt 0))),
836 pprInstr (STU fmt r0 (AddrRegImm sp amount))
837 ]
838
839 pprInstr (UPDATE_SP fmt amount)
840 = sdocWithPlatform $ \platform ->
841 let tmp = tmpReg platform in
842 vcat [
843 pprInstr (LD fmt r0 (AddrRegImm sp (ImmInt 0))),
844 pprInstr (ADDIS tmp sp (HA amount)),
845 pprInstr (ADD tmp tmp (RIImm (LO amount))),
846 pprInstr (STU fmt r0 (AddrRegReg sp tmp))
847 ]
848
849 -- pprInstr _ = panic "pprInstr (ppc)"
850
851
852 pprLogic :: LitString -> Reg -> Reg -> RI -> SDoc
853 pprLogic op reg1 reg2 ri = hcat [
854 char '\t',
855 ptext op,
856 case ri of
857 RIReg _ -> empty
858 RIImm _ -> char 'i',
859 char '\t',
860 pprReg reg1,
861 ptext (sLit ", "),
862 pprReg reg2,
863 ptext (sLit ", "),
864 pprRI ri
865 ]
866
867
868 pprUnary :: LitString -> Reg -> Reg -> SDoc
869 pprUnary op reg1 reg2 = hcat [
870 char '\t',
871 ptext op,
872 char '\t',
873 pprReg reg1,
874 ptext (sLit ", "),
875 pprReg reg2
876 ]
877
878
879 pprBinaryF :: LitString -> Format -> Reg -> Reg -> Reg -> SDoc
880 pprBinaryF op fmt reg1 reg2 reg3 = hcat [
881 char '\t',
882 ptext op,
883 pprFFormat fmt,
884 char '\t',
885 pprReg reg1,
886 ptext (sLit ", "),
887 pprReg reg2,
888 ptext (sLit ", "),
889 pprReg reg3
890 ]
891
892 pprRI :: RI -> SDoc
893 pprRI (RIReg r) = pprReg r
894 pprRI (RIImm r) = pprImm r
895
896
897 pprFFormat :: Format -> SDoc
898 pprFFormat FF64 = empty
899 pprFFormat FF32 = char 's'
900 pprFFormat _ = panic "PPC.Ppr.pprFFormat: no match"
901
902 -- limit immediate argument for shift instruction to range 0..63
903 -- for 64 bit size and 0..32 otherwise
904 limitShiftRI :: Format -> RI -> RI
905 limitShiftRI II64 (RIImm (ImmInt i)) | i > 63 || i < 0 =
906 panic $ "PPC.Ppr: Shift by " ++ show i ++ " bits is not allowed."
907 limitShiftRI II32 (RIImm (ImmInt i)) | i > 31 || i < 0 =
908 panic $ "PPC.Ppr: 32 bit: Shift by " ++ show i ++ " bits is not allowed."
909 limitShiftRI _ x = x
910