Fix AIX/ppc codegen in `-prof` compilation mode
[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 ->
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 -- Moreover, the PPC NCG only ever emits a BL instruction
615 -- for calling C ABI functions. Most of the time these calls
616 -- originate from FFI imports and have a 'ForeignLabel',
617 -- but when profiling the codegen inserts calls via
618 -- 'emitRtsCallGen' which are 'CmmLabel's even though
619 -- they'd technically be more like 'ForeignLabel's.
620 hcat [
621 text "\tbl\t.",
622 ppr lbl
623 ]
624 _ ->
625 hcat [
626 text "\tbl\t",
627 ppr lbl
628 ]
629 pprInstr (BCTRL _) = hcat [
630 char '\t',
631 text "bctrl"
632 ]
633 pprInstr (ADD reg1 reg2 ri) = pprLogic (sLit "add") reg1 reg2 ri
634 pprInstr (ADDI reg1 reg2 imm) = hcat [
635 char '\t',
636 text "addi",
637 char '\t',
638 pprReg reg1,
639 text ", ",
640 pprReg reg2,
641 text ", ",
642 pprImm imm
643 ]
644 pprInstr (ADDIS reg1 reg2 imm) = hcat [
645 char '\t',
646 text "addis",
647 char '\t',
648 pprReg reg1,
649 text ", ",
650 pprReg reg2,
651 text ", ",
652 pprImm imm
653 ]
654
655 pprInstr (ADDC reg1 reg2 reg3) = pprLogic (sLit "addc") reg1 reg2 (RIReg reg3)
656 pprInstr (ADDE reg1 reg2 reg3) = pprLogic (sLit "adde") reg1 reg2 (RIReg reg3)
657 pprInstr (SUBF reg1 reg2 reg3) = pprLogic (sLit "subf") reg1 reg2 (RIReg reg3)
658 pprInstr (SUBFC reg1 reg2 reg3) = pprLogic (sLit "subfc") reg1 reg2 (RIReg reg3)
659 pprInstr (SUBFE reg1 reg2 reg3) = pprLogic (sLit "subfe") reg1 reg2 (RIReg reg3)
660 pprInstr (MULLD reg1 reg2 ri@(RIReg _)) = pprLogic (sLit "mulld") reg1 reg2 ri
661 pprInstr (MULLW reg1 reg2 ri@(RIReg _)) = pprLogic (sLit "mullw") reg1 reg2 ri
662 pprInstr (MULLD reg1 reg2 ri@(RIImm _)) = pprLogic (sLit "mull") reg1 reg2 ri
663 pprInstr (MULLW reg1 reg2 ri@(RIImm _)) = pprLogic (sLit "mull") reg1 reg2 ri
664 pprInstr (DIVW reg1 reg2 reg3) = pprLogic (sLit "divw") reg1 reg2 (RIReg reg3)
665 pprInstr (DIVD reg1 reg2 reg3) = pprLogic (sLit "divd") reg1 reg2 (RIReg reg3)
666 pprInstr (DIVWU reg1 reg2 reg3) = pprLogic (sLit "divwu") reg1 reg2 (RIReg reg3)
667 pprInstr (DIVDU reg1 reg2 reg3) = pprLogic (sLit "divdu") reg1 reg2 (RIReg reg3)
668
669 pprInstr (MULLW_MayOflo reg1 reg2 reg3) = vcat [
670 hcat [ text "\tmullwo\t", pprReg reg1, ptext (sLit ", "),
671 pprReg reg2, text ", ",
672 pprReg reg3 ],
673 hcat [ text "\tmfxer\t", pprReg reg1 ],
674 hcat [ text "\trlwinm\t", pprReg reg1, ptext (sLit ", "),
675 pprReg reg1, text ", ",
676 text "2, 31, 31" ]
677 ]
678 pprInstr (MULLD_MayOflo reg1 reg2 reg3) = vcat [
679 hcat [ text "\tmulldo\t", pprReg reg1, ptext (sLit ", "),
680 pprReg reg2, text ", ",
681 pprReg reg3 ],
682 hcat [ text "\tmfxer\t", pprReg reg1 ],
683 hcat [ text "\trlwinm\t", pprReg reg1, ptext (sLit ", "),
684 pprReg reg1, text ", ",
685 text "2, 31, 31" ]
686 ]
687
688 -- for some reason, "andi" doesn't exist.
689 -- we'll use "andi." instead.
690 pprInstr (AND reg1 reg2 (RIImm imm)) = hcat [
691 char '\t',
692 text "andi.",
693 char '\t',
694 pprReg reg1,
695 text ", ",
696 pprReg reg2,
697 text ", ",
698 pprImm imm
699 ]
700 pprInstr (AND reg1 reg2 ri) = pprLogic (sLit "and") reg1 reg2 ri
701
702 pprInstr (OR reg1 reg2 ri) = pprLogic (sLit "or") reg1 reg2 ri
703 pprInstr (XOR reg1 reg2 ri) = pprLogic (sLit "xor") reg1 reg2 ri
704
705 pprInstr (ORIS reg1 reg2 imm) = hcat [
706 char '\t',
707 text "oris",
708 char '\t',
709 pprReg reg1,
710 text ", ",
711 pprReg reg2,
712 text ", ",
713 pprImm imm
714 ]
715
716 pprInstr (XORIS reg1 reg2 imm) = hcat [
717 char '\t',
718 text "xoris",
719 char '\t',
720 pprReg reg1,
721 text ", ",
722 pprReg reg2,
723 text ", ",
724 pprImm imm
725 ]
726
727 pprInstr (EXTS fmt reg1 reg2) = hcat [
728 char '\t',
729 text "exts",
730 pprFormat fmt,
731 char '\t',
732 pprReg reg1,
733 text ", ",
734 pprReg reg2
735 ]
736
737 pprInstr (NEG reg1 reg2) = pprUnary (sLit "neg") reg1 reg2
738 pprInstr (NOT reg1 reg2) = pprUnary (sLit "not") reg1 reg2
739
740 pprInstr (SR II32 reg1 reg2 (RIImm (ImmInt i))) | i < 0 || i > 31 =
741 -- Handle the case where we are asked to shift a 32 bit register by
742 -- less than zero or more than 31 bits. We convert this into a clear
743 -- of the destination register.
744 -- Fixes ticket http://ghc.haskell.org/trac/ghc/ticket/5900
745 pprInstr (XOR reg1 reg2 (RIReg reg2))
746
747 pprInstr (SL II32 reg1 reg2 (RIImm (ImmInt i))) | i < 0 || i > 31 =
748 -- As above for SR, but for left shifts.
749 -- Fixes ticket http://ghc.haskell.org/trac/ghc/ticket/10870
750 pprInstr (XOR reg1 reg2 (RIReg reg2))
751
752 pprInstr (SRA II32 reg1 reg2 (RIImm (ImmInt i))) | i > 31 =
753 -- PT: I don't know what to do for negative shift amounts:
754 -- For now just panic.
755 --
756 -- For shift amounts greater than 31 set all bit to the
757 -- value of the sign bit, this also what sraw does.
758 pprInstr (SRA II32 reg1 reg2 (RIImm (ImmInt 31)))
759
760 pprInstr (SL fmt reg1 reg2 ri) =
761 let op = case fmt of
762 II32 -> "slw"
763 II64 -> "sld"
764 _ -> panic "PPC.Ppr.pprInstr: shift illegal size"
765 in pprLogic (sLit op) reg1 reg2 (limitShiftRI fmt ri)
766
767 pprInstr (SR fmt reg1 reg2 ri) =
768 let op = case fmt of
769 II32 -> "srw"
770 II64 -> "srd"
771 _ -> panic "PPC.Ppr.pprInstr: shift illegal size"
772 in pprLogic (sLit op) reg1 reg2 (limitShiftRI fmt ri)
773
774 pprInstr (SRA fmt reg1 reg2 ri) =
775 let op = case fmt of
776 II32 -> "sraw"
777 II64 -> "srad"
778 _ -> panic "PPC.Ppr.pprInstr: shift illegal size"
779 in pprLogic (sLit op) reg1 reg2 (limitShiftRI fmt ri)
780
781 pprInstr (RLWINM reg1 reg2 sh mb me) = hcat [
782 text "\trlwinm\t",
783 pprReg reg1,
784 text ", ",
785 pprReg reg2,
786 text ", ",
787 int sh,
788 text ", ",
789 int mb,
790 text ", ",
791 int me
792 ]
793
794 pprInstr (FADD fmt reg1 reg2 reg3) = pprBinaryF (sLit "fadd") fmt reg1 reg2 reg3
795 pprInstr (FSUB fmt reg1 reg2 reg3) = pprBinaryF (sLit "fsub") fmt reg1 reg2 reg3
796 pprInstr (FMUL fmt reg1 reg2 reg3) = pprBinaryF (sLit "fmul") fmt reg1 reg2 reg3
797 pprInstr (FDIV fmt reg1 reg2 reg3) = pprBinaryF (sLit "fdiv") fmt reg1 reg2 reg3
798 pprInstr (FNEG reg1 reg2) = pprUnary (sLit "fneg") reg1 reg2
799
800 pprInstr (FCMP reg1 reg2) = hcat [
801 char '\t',
802 text "fcmpu\t0, ",
803 -- Note: we're using fcmpu, not fcmpo
804 -- The difference is with fcmpo, compare with NaN is an invalid operation.
805 -- We don't handle invalid fp ops, so we don't care.
806 -- Morever, we use `fcmpu 0, ...` rather than `fcmpu cr0, ...` for
807 -- better portability since some non-GNU assembler (such as
808 -- IBM's `as`) tend not to support the symbolic register name cr0.
809 -- This matches the syntax that GCC seems to emit for PPC targets.
810 pprReg reg1,
811 text ", ",
812 pprReg reg2
813 ]
814
815 pprInstr (FCTIWZ reg1 reg2) = pprUnary (sLit "fctiwz") reg1 reg2
816 pprInstr (FCTIDZ reg1 reg2) = pprUnary (sLit "fctidz") reg1 reg2
817 pprInstr (FCFID reg1 reg2) = pprUnary (sLit "fcfid") reg1 reg2
818 pprInstr (FRSP reg1 reg2) = pprUnary (sLit "frsp") reg1 reg2
819
820 pprInstr (CRNOR dst src1 src2) = hcat [
821 text "\tcrnor\t",
822 int dst,
823 text ", ",
824 int src1,
825 text ", ",
826 int src2
827 ]
828
829 pprInstr (MFCR reg) = hcat [
830 char '\t',
831 text "mfcr",
832 char '\t',
833 pprReg reg
834 ]
835
836 pprInstr (MFLR reg) = hcat [
837 char '\t',
838 text "mflr",
839 char '\t',
840 pprReg reg
841 ]
842
843 pprInstr (FETCHPC reg) = vcat [
844 text "\tbcl\t20,31,1f",
845 hcat [ text "1:\tmflr\t", pprReg reg ]
846 ]
847
848 pprInstr (FETCHTOC reg lab) = vcat [
849 hcat [ text "0:\taddis\t", pprReg reg,
850 text ",12,.TOC.-0b@ha" ],
851 hcat [ text "\taddi\t", pprReg reg,
852 char ',', pprReg reg,
853 text ",.TOC.-0b@l" ],
854 hcat [ text "\t.localentry\t",
855 ppr lab,
856 text ",.-",
857 ppr lab]
858 ]
859
860 pprInstr LWSYNC = text "\tlwsync"
861
862 pprInstr NOP = text "\tnop"
863
864 pprInstr (UPDATE_SP fmt amount@(ImmInt offset))
865 | fits16Bits offset = vcat [
866 pprInstr (LD fmt r0 (AddrRegImm sp (ImmInt 0))),
867 pprInstr (STU fmt r0 (AddrRegImm sp amount))
868 ]
869
870 pprInstr (UPDATE_SP fmt amount)
871 = sdocWithPlatform $ \platform ->
872 let tmp = tmpReg platform in
873 vcat [
874 pprInstr (LD fmt r0 (AddrRegImm sp (ImmInt 0))),
875 pprInstr (ADDIS tmp sp (HA amount)),
876 pprInstr (ADD tmp tmp (RIImm (LO amount))),
877 pprInstr (STU fmt r0 (AddrRegReg sp tmp))
878 ]
879
880 -- pprInstr _ = panic "pprInstr (ppc)"
881
882
883 pprLogic :: LitString -> Reg -> Reg -> RI -> SDoc
884 pprLogic op reg1 reg2 ri = hcat [
885 char '\t',
886 ptext op,
887 case ri of
888 RIReg _ -> empty
889 RIImm _ -> char 'i',
890 char '\t',
891 pprReg reg1,
892 text ", ",
893 pprReg reg2,
894 text ", ",
895 pprRI ri
896 ]
897
898
899 pprUnary :: LitString -> Reg -> Reg -> SDoc
900 pprUnary op reg1 reg2 = hcat [
901 char '\t',
902 ptext op,
903 char '\t',
904 pprReg reg1,
905 text ", ",
906 pprReg reg2
907 ]
908
909
910 pprBinaryF :: LitString -> Format -> Reg -> Reg -> Reg -> SDoc
911 pprBinaryF op fmt reg1 reg2 reg3 = hcat [
912 char '\t',
913 ptext op,
914 pprFFormat fmt,
915 char '\t',
916 pprReg reg1,
917 text ", ",
918 pprReg reg2,
919 text ", ",
920 pprReg reg3
921 ]
922
923 pprRI :: RI -> SDoc
924 pprRI (RIReg r) = pprReg r
925 pprRI (RIImm r) = pprImm r
926
927
928 pprFFormat :: Format -> SDoc
929 pprFFormat FF64 = empty
930 pprFFormat FF32 = char 's'
931 pprFFormat _ = panic "PPC.Ppr.pprFFormat: no match"
932
933 -- limit immediate argument for shift instruction to range 0..63
934 -- for 64 bit size and 0..32 otherwise
935 limitShiftRI :: Format -> RI -> RI
936 limitShiftRI II64 (RIImm (ImmInt i)) | i > 63 || i < 0 =
937 panic $ "PPC.Ppr: Shift by " ++ show i ++ " bits is not allowed."
938 limitShiftRI II32 (RIImm (ImmInt i)) | i > 31 || i < 0 =
939 panic $ "PPC.Ppr: 32 bit: Shift by " ++ show i ++ " bits is not allowed."
940 limitShiftRI _ x = x