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