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