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