Reduce the size of string literals in binaries.
[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] in X86/Ppr.hs
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 -- TODO: This is copied from the ReadOnlyData case, but it can likely be
352 -- made more efficient.
353 CString
354 | osDarwin -> sLit ".align 2"
355 | ppc64 -> sLit ".align 3"
356 | otherwise -> sLit ".align 2"
357 OtherSection _ -> panic "PprMach.pprSectionAlign: unknown section"
358
359 pprDataItem :: CmmLit -> SDoc
360 pprDataItem lit
361 = sdocWithDynFlags $ \dflags ->
362 vcat (ppr_item (cmmTypeFormat $ cmmLitType dflags lit) lit dflags)
363 where
364 imm = litToImm lit
365 archPPC_64 dflags = not $ target32Bit $ targetPlatform dflags
366
367 ppr_item II8 _ _ = [text "\t.byte\t" <> pprImm imm]
368
369 ppr_item II32 _ _ = [text "\t.long\t" <> pprImm imm]
370
371 ppr_item II64 _ dflags
372 | archPPC_64 dflags = [text "\t.quad\t" <> pprImm imm]
373
374
375 ppr_item FF32 (CmmFloat r _) _
376 = let bs = floatToBytes (fromRational r)
377 in map (\b -> text "\t.byte\t" <> pprImm (ImmInt b)) bs
378
379 ppr_item FF64 (CmmFloat r _) _
380 = let bs = doubleToBytes (fromRational r)
381 in map (\b -> text "\t.byte\t" <> pprImm (ImmInt b)) bs
382
383 ppr_item II16 _ _ = [text "\t.short\t" <> pprImm imm]
384
385 ppr_item II64 (CmmInt x _) dflags
386 | not(archPPC_64 dflags) =
387 [text "\t.long\t"
388 <> int (fromIntegral
389 (fromIntegral (x `shiftR` 32) :: Word32)),
390 text "\t.long\t"
391 <> int (fromIntegral (fromIntegral x :: Word32))]
392
393 ppr_item _ _ _
394 = panic "PPC.Ppr.pprDataItem: no match"
395
396
397 pprInstr :: Instr -> SDoc
398
399 pprInstr (COMMENT _) = empty -- nuke 'em
400 {-
401 pprInstr (COMMENT s) =
402 if platformOS platform == OSLinux
403 then text "# " <> ftext s
404 else text "; " <> ftext s
405 -}
406 pprInstr (DELTA d)
407 = pprInstr (COMMENT (mkFastString ("\tdelta = " ++ show d)))
408
409 pprInstr (NEWBLOCK _)
410 = panic "PprMach.pprInstr: NEWBLOCK"
411
412 pprInstr (LDATA _ _)
413 = panic "PprMach.pprInstr: LDATA"
414
415 {-
416 pprInstr (SPILL reg slot)
417 = hcat [
418 text "\tSPILL",
419 char '\t',
420 pprReg reg,
421 comma,
422 text "SLOT" <> parens (int slot)]
423
424 pprInstr (RELOAD slot reg)
425 = hcat [
426 text "\tRELOAD",
427 char '\t',
428 text "SLOT" <> parens (int slot),
429 comma,
430 pprReg reg]
431 -}
432
433 pprInstr (LD fmt reg addr) = hcat [
434 char '\t',
435 text "l",
436 ptext (case fmt of
437 II8 -> sLit "bz"
438 II16 -> sLit "hz"
439 II32 -> sLit "wz"
440 II64 -> sLit "d"
441 FF32 -> sLit "fs"
442 FF64 -> sLit "fd"
443 _ -> panic "PPC.Ppr.pprInstr: no match"
444 ),
445 case addr of AddrRegImm _ _ -> empty
446 AddrRegReg _ _ -> char 'x',
447 char '\t',
448 pprReg reg,
449 text ", ",
450 pprAddr addr
451 ]
452 pprInstr (LDFAR fmt reg (AddrRegImm source off)) =
453 sdocWithPlatform $ \platform -> vcat [
454 pprInstr (ADDIS (tmpReg platform) source (HA off)),
455 pprInstr (LD fmt reg (AddrRegImm (tmpReg platform) (LO off)))
456 ]
457
458 pprInstr (LDFAR _ _ _) =
459 panic "PPC.Ppr.pprInstr LDFAR: no match"
460
461 pprInstr (LA fmt reg addr) = hcat [
462 char '\t',
463 text "l",
464 ptext (case fmt of
465 II8 -> sLit "ba"
466 II16 -> sLit "ha"
467 II32 -> sLit "wa"
468 II64 -> sLit "d"
469 FF32 -> sLit "fs"
470 FF64 -> sLit "fd"
471 _ -> panic "PPC.Ppr.pprInstr: no match"
472 ),
473 case addr of AddrRegImm _ _ -> empty
474 AddrRegReg _ _ -> char 'x',
475 char '\t',
476 pprReg reg,
477 text ", ",
478 pprAddr addr
479 ]
480 pprInstr (ST fmt reg addr) = hcat [
481 char '\t',
482 text "st",
483 pprFormat fmt,
484 case addr of AddrRegImm _ _ -> empty
485 AddrRegReg _ _ -> char 'x',
486 char '\t',
487 pprReg reg,
488 text ", ",
489 pprAddr addr
490 ]
491 pprInstr (STFAR fmt reg (AddrRegImm source off)) =
492 sdocWithPlatform $ \platform -> vcat [
493 pprInstr (ADDIS (tmpReg platform) source (HA off)),
494 pprInstr (ST fmt reg (AddrRegImm (tmpReg platform) (LO off)))
495 ]
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 (ADDI reg1 reg2 imm) = hcat [
642 char '\t',
643 text "addi",
644 char '\t',
645 pprReg reg1,
646 text ", ",
647 pprReg reg2,
648 text ", ",
649 pprImm imm
650 ]
651 pprInstr (ADDIS reg1 reg2 imm) = hcat [
652 char '\t',
653 text "addis",
654 char '\t',
655 pprReg reg1,
656 text ", ",
657 pprReg reg2,
658 text ", ",
659 pprImm imm
660 ]
661
662 pprInstr (ADDC reg1 reg2 reg3) = pprLogic (sLit "addc") reg1 reg2 (RIReg reg3)
663 pprInstr (ADDE reg1 reg2 reg3) = pprLogic (sLit "adde") reg1 reg2 (RIReg reg3)
664 pprInstr (SUBF reg1 reg2 reg3) = pprLogic (sLit "subf") reg1 reg2 (RIReg reg3)
665 pprInstr (SUBFC reg1 reg2 reg3) = pprLogic (sLit "subfc") reg1 reg2 (RIReg reg3)
666 pprInstr (SUBFE reg1 reg2 reg3) = pprLogic (sLit "subfe") reg1 reg2 (RIReg reg3)
667 pprInstr (MULLD reg1 reg2 ri@(RIReg _)) = pprLogic (sLit "mulld") reg1 reg2 ri
668 pprInstr (MULLW reg1 reg2 ri@(RIReg _)) = pprLogic (sLit "mullw") reg1 reg2 ri
669 pprInstr (MULLD reg1 reg2 ri@(RIImm _)) = pprLogic (sLit "mull") reg1 reg2 ri
670 pprInstr (MULLW reg1 reg2 ri@(RIImm _)) = pprLogic (sLit "mull") reg1 reg2 ri
671 pprInstr (DIVW reg1 reg2 reg3) = pprLogic (sLit "divw") reg1 reg2 (RIReg reg3)
672 pprInstr (DIVD reg1 reg2 reg3) = pprLogic (sLit "divd") reg1 reg2 (RIReg reg3)
673 pprInstr (DIVWU reg1 reg2 reg3) = pprLogic (sLit "divwu") reg1 reg2 (RIReg reg3)
674 pprInstr (DIVDU reg1 reg2 reg3) = pprLogic (sLit "divdu") reg1 reg2 (RIReg reg3)
675
676 pprInstr (MULLW_MayOflo reg1 reg2 reg3) = vcat [
677 hcat [ text "\tmullwo\t", pprReg reg1, ptext (sLit ", "),
678 pprReg reg2, text ", ",
679 pprReg reg3 ],
680 hcat [ text "\tmfxer\t", pprReg reg1 ],
681 hcat [ text "\trlwinm\t", pprReg reg1, ptext (sLit ", "),
682 pprReg reg1, text ", ",
683 text "2, 31, 31" ]
684 ]
685 pprInstr (MULLD_MayOflo reg1 reg2 reg3) = vcat [
686 hcat [ text "\tmulldo\t", pprReg reg1, ptext (sLit ", "),
687 pprReg reg2, text ", ",
688 pprReg reg3 ],
689 hcat [ text "\tmfxer\t", pprReg reg1 ],
690 hcat [ text "\trlwinm\t", pprReg reg1, ptext (sLit ", "),
691 pprReg reg1, text ", ",
692 text "2, 31, 31" ]
693 ]
694
695 -- for some reason, "andi" doesn't exist.
696 -- we'll use "andi." instead.
697 pprInstr (AND reg1 reg2 (RIImm imm)) = hcat [
698 char '\t',
699 text "andi.",
700 char '\t',
701 pprReg reg1,
702 text ", ",
703 pprReg reg2,
704 text ", ",
705 pprImm imm
706 ]
707 pprInstr (AND reg1 reg2 ri) = pprLogic (sLit "and") reg1 reg2 ri
708
709 pprInstr (OR reg1 reg2 ri) = pprLogic (sLit "or") reg1 reg2 ri
710 pprInstr (XOR reg1 reg2 ri) = pprLogic (sLit "xor") reg1 reg2 ri
711
712 pprInstr (ORIS reg1 reg2 imm) = hcat [
713 char '\t',
714 text "oris",
715 char '\t',
716 pprReg reg1,
717 text ", ",
718 pprReg reg2,
719 text ", ",
720 pprImm imm
721 ]
722
723 pprInstr (XORIS reg1 reg2 imm) = hcat [
724 char '\t',
725 text "xoris",
726 char '\t',
727 pprReg reg1,
728 text ", ",
729 pprReg reg2,
730 text ", ",
731 pprImm imm
732 ]
733
734 pprInstr (EXTS fmt reg1 reg2) = hcat [
735 char '\t',
736 text "exts",
737 pprFormat fmt,
738 char '\t',
739 pprReg reg1,
740 text ", ",
741 pprReg reg2
742 ]
743
744 pprInstr (NEG reg1 reg2) = pprUnary (sLit "neg") reg1 reg2
745 pprInstr (NOT reg1 reg2) = pprUnary (sLit "not") reg1 reg2
746
747 pprInstr (SR II32 reg1 reg2 (RIImm (ImmInt i))) | i < 0 || i > 31 =
748 -- Handle the case where we are asked to shift a 32 bit register by
749 -- less than zero or more than 31 bits. We convert this into a clear
750 -- of the destination register.
751 -- Fixes ticket http://ghc.haskell.org/trac/ghc/ticket/5900
752 pprInstr (XOR reg1 reg2 (RIReg reg2))
753
754 pprInstr (SL II32 reg1 reg2 (RIImm (ImmInt i))) | i < 0 || i > 31 =
755 -- As above for SR, but for left shifts.
756 -- Fixes ticket http://ghc.haskell.org/trac/ghc/ticket/10870
757 pprInstr (XOR reg1 reg2 (RIReg reg2))
758
759 pprInstr (SRA II32 reg1 reg2 (RIImm (ImmInt i))) | i > 31 =
760 -- PT: I don't know what to do for negative shift amounts:
761 -- For now just panic.
762 --
763 -- For shift amounts greater than 31 set all bit to the
764 -- value of the sign bit, this also what sraw does.
765 pprInstr (SRA II32 reg1 reg2 (RIImm (ImmInt 31)))
766
767 pprInstr (SL fmt reg1 reg2 ri) =
768 let op = case fmt of
769 II32 -> "slw"
770 II64 -> "sld"
771 _ -> panic "PPC.Ppr.pprInstr: shift illegal size"
772 in pprLogic (sLit op) reg1 reg2 (limitShiftRI fmt ri)
773
774 pprInstr (SR fmt reg1 reg2 ri) =
775 let op = case fmt of
776 II32 -> "srw"
777 II64 -> "srd"
778 _ -> panic "PPC.Ppr.pprInstr: shift illegal size"
779 in pprLogic (sLit op) reg1 reg2 (limitShiftRI fmt ri)
780
781 pprInstr (SRA fmt reg1 reg2 ri) =
782 let op = case fmt of
783 II32 -> "sraw"
784 II64 -> "srad"
785 _ -> panic "PPC.Ppr.pprInstr: shift illegal size"
786 in pprLogic (sLit op) reg1 reg2 (limitShiftRI fmt ri)
787
788 pprInstr (RLWINM reg1 reg2 sh mb me) = hcat [
789 text "\trlwinm\t",
790 pprReg reg1,
791 text ", ",
792 pprReg reg2,
793 text ", ",
794 int sh,
795 text ", ",
796 int mb,
797 text ", ",
798 int me
799 ]
800
801 pprInstr (CLRRI fmt reg1 reg2 n) = hcat [
802 text "\tclrr",
803 pprFormat fmt,
804 text "i ",
805 pprReg reg1,
806 text ", ",
807 pprReg reg2,
808 text ", ",
809 int n
810 ]
811
812 pprInstr (FADD fmt reg1 reg2 reg3) = pprBinaryF (sLit "fadd") fmt reg1 reg2 reg3
813 pprInstr (FSUB fmt reg1 reg2 reg3) = pprBinaryF (sLit "fsub") fmt reg1 reg2 reg3
814 pprInstr (FMUL fmt reg1 reg2 reg3) = pprBinaryF (sLit "fmul") fmt reg1 reg2 reg3
815 pprInstr (FDIV fmt reg1 reg2 reg3) = pprBinaryF (sLit "fdiv") fmt reg1 reg2 reg3
816 pprInstr (FNEG reg1 reg2) = pprUnary (sLit "fneg") reg1 reg2
817
818 pprInstr (FCMP reg1 reg2) = hcat [
819 char '\t',
820 text "fcmpu\t0, ",
821 -- Note: we're using fcmpu, not fcmpo
822 -- The difference is with fcmpo, compare with NaN is an invalid operation.
823 -- We don't handle invalid fp ops, so we don't care.
824 -- Morever, we use `fcmpu 0, ...` rather than `fcmpu cr0, ...` for
825 -- better portability since some non-GNU assembler (such as
826 -- IBM's `as`) tend not to support the symbolic register name cr0.
827 -- This matches the syntax that GCC seems to emit for PPC targets.
828 pprReg reg1,
829 text ", ",
830 pprReg reg2
831 ]
832
833 pprInstr (FCTIWZ reg1 reg2) = pprUnary (sLit "fctiwz") reg1 reg2
834 pprInstr (FCTIDZ reg1 reg2) = pprUnary (sLit "fctidz") reg1 reg2
835 pprInstr (FCFID reg1 reg2) = pprUnary (sLit "fcfid") reg1 reg2
836 pprInstr (FRSP reg1 reg2) = pprUnary (sLit "frsp") reg1 reg2
837
838 pprInstr (CRNOR dst src1 src2) = hcat [
839 text "\tcrnor\t",
840 int dst,
841 text ", ",
842 int src1,
843 text ", ",
844 int src2
845 ]
846
847 pprInstr (MFCR reg) = hcat [
848 char '\t',
849 text "mfcr",
850 char '\t',
851 pprReg reg
852 ]
853
854 pprInstr (MFLR reg) = hcat [
855 char '\t',
856 text "mflr",
857 char '\t',
858 pprReg reg
859 ]
860
861 pprInstr (FETCHPC reg) = vcat [
862 text "\tbcl\t20,31,1f",
863 hcat [ text "1:\tmflr\t", pprReg reg ]
864 ]
865
866 pprInstr (FETCHTOC reg lab) = vcat [
867 hcat [ text "0:\taddis\t", pprReg reg,
868 text ",12,.TOC.-0b@ha" ],
869 hcat [ text "\taddi\t", pprReg reg,
870 char ',', pprReg reg,
871 text ",.TOC.-0b@l" ],
872 hcat [ text "\t.localentry\t",
873 ppr lab,
874 text ",.-",
875 ppr lab]
876 ]
877
878 pprInstr LWSYNC = text "\tlwsync"
879
880 pprInstr NOP = text "\tnop"
881
882 pprInstr (UPDATE_SP fmt amount@(ImmInt offset))
883 | fits16Bits offset = vcat [
884 pprInstr (LD fmt r0 (AddrRegImm sp (ImmInt 0))),
885 pprInstr (STU fmt r0 (AddrRegImm sp amount))
886 ]
887
888 pprInstr (UPDATE_SP fmt amount)
889 = sdocWithPlatform $ \platform ->
890 let tmp = tmpReg platform in
891 vcat [
892 pprInstr (LD fmt r0 (AddrRegImm sp (ImmInt 0))),
893 pprInstr (ADDIS tmp sp (HA amount)),
894 pprInstr (ADD tmp tmp (RIImm (LO amount))),
895 pprInstr (STU fmt r0 (AddrRegReg sp tmp))
896 ]
897
898 -- pprInstr _ = panic "pprInstr (ppc)"
899
900
901 pprLogic :: LitString -> Reg -> Reg -> RI -> SDoc
902 pprLogic op reg1 reg2 ri = hcat [
903 char '\t',
904 ptext op,
905 case ri of
906 RIReg _ -> empty
907 RIImm _ -> char 'i',
908 char '\t',
909 pprReg reg1,
910 text ", ",
911 pprReg reg2,
912 text ", ",
913 pprRI ri
914 ]
915
916
917 pprUnary :: LitString -> Reg -> Reg -> SDoc
918 pprUnary op reg1 reg2 = hcat [
919 char '\t',
920 ptext op,
921 char '\t',
922 pprReg reg1,
923 text ", ",
924 pprReg reg2
925 ]
926
927
928 pprBinaryF :: LitString -> Format -> Reg -> Reg -> Reg -> SDoc
929 pprBinaryF op fmt reg1 reg2 reg3 = hcat [
930 char '\t',
931 ptext op,
932 pprFFormat fmt,
933 char '\t',
934 pprReg reg1,
935 text ", ",
936 pprReg reg2,
937 text ", ",
938 pprReg reg3
939 ]
940
941 pprRI :: RI -> SDoc
942 pprRI (RIReg r) = pprReg r
943 pprRI (RIImm r) = pprImm r
944
945
946 pprFFormat :: Format -> SDoc
947 pprFFormat FF64 = empty
948 pprFFormat FF32 = char 's'
949 pprFFormat _ = panic "PPC.Ppr.pprFFormat: no match"
950
951 -- limit immediate argument for shift instruction to range 0..63
952 -- for 64 bit size and 0..32 otherwise
953 limitShiftRI :: Format -> RI -> RI
954 limitShiftRI II64 (RIImm (ImmInt i)) | i > 63 || i < 0 =
955 panic $ "PPC.Ppr: Shift by " ++ show i ++ " bits is not allowed."
956 limitShiftRI II32 (RIImm (ImmInt i)) | i > 31 || i < 0 =
957 panic $ "PPC.Ppr: 32 bit: Shift by " ++ show i ++ " bits is not allowed."
958 limitShiftRI _ x = x