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