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