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