Implement function-sections for Haskell code, #8405
[ghc.git] / compiler / nativeGen / X86 / Ppr.hs
1 {-# LANGUAGE CPP #-}
2
3 -----------------------------------------------------------------------------
4 --
5 -- Pretty-printing assembly language
6 --
7 -- (c) The University of Glasgow 1993-2005
8 --
9 -----------------------------------------------------------------------------
10
11 {-# OPTIONS_GHC -fno-warn-orphans #-}
12 module X86.Ppr (
13 pprNatCmmDecl,
14 pprData,
15 pprInstr,
16 pprFormat,
17 pprImm,
18 pprDataItem,
19 )
20
21 where
22
23 #include "HsVersions.h"
24 #include "nativeGen/NCG.h"
25
26 import X86.Regs
27 import X86.Instr
28 import X86.Cond
29 import Instruction
30 import Format
31 import Reg
32 import PprBase
33
34
35 import BlockId
36 import BasicTypes (Alignment)
37 import DynFlags
38 import Cmm hiding (topInfoTable)
39 import CLabel
40 import Unique ( pprUnique, Uniquable(..) )
41 import Platform
42 import FastString
43 import Outputable
44
45 import Data.Word
46
47 import Data.Bits
48
49 -- -----------------------------------------------------------------------------
50 -- Printing this stuff out
51
52 pprNatCmmDecl :: NatCmmDecl (Alignment, CmmStatics) Instr -> SDoc
53 pprNatCmmDecl (CmmData section dats) =
54 pprSectionAlign section $$ pprDatas dats
55
56 pprNatCmmDecl proc@(CmmProc top_info lbl _ (ListGraph blocks)) =
57 sdocWithDynFlags $ \dflags ->
58 case topInfoTable proc of
59 Nothing ->
60 case blocks of
61 [] -> -- special case for split markers:
62 pprLabel lbl
63 blocks -> -- special case for code without info table:
64 pprSectionAlign (Section Text lbl) $$
65 pprLabel lbl $$ -- blocks guaranteed not null, so label needed
66 vcat (map (pprBasicBlock top_info) blocks) $$
67 (if gopt Opt_Debug dflags
68 then ppr (mkAsmTempEndLabel lbl) <> char ':' else empty) $$
69 pprSizeDecl lbl
70
71 Just (Statics info_lbl _) ->
72 sdocWithPlatform $ \platform ->
73 pprSectionAlign (Section Text info_lbl) $$
74 (if platformHasSubsectionsViaSymbols platform
75 then ppr (mkDeadStripPreventer info_lbl) <> char ':'
76 else empty) $$
77 vcat (map (pprBasicBlock top_info) blocks) $$
78 -- above: Even the first block gets a label, because with branch-chain
79 -- elimination, it might be the target of a goto.
80 (if platformHasSubsectionsViaSymbols platform
81 then -- See Note [Subsections Via Symbols]
82 text "\t.long "
83 <+> ppr info_lbl
84 <+> char '-'
85 <+> ppr (mkDeadStripPreventer info_lbl)
86 else empty) $$
87 (if gopt Opt_Debug dflags
88 then ppr (mkAsmTempEndLabel info_lbl) <> char ':' else empty) $$
89 pprSizeDecl info_lbl
90
91 -- | Output the ELF .size directive.
92 pprSizeDecl :: CLabel -> SDoc
93 pprSizeDecl lbl
94 = sdocWithPlatform $ \platform ->
95 if osElfTarget (platformOS platform)
96 then ptext (sLit "\t.size") <+> ppr lbl <> ptext (sLit ", .-") <> ppr lbl
97 else empty
98
99 pprBasicBlock :: BlockEnv CmmStatics -> NatBasicBlock Instr -> SDoc
100 pprBasicBlock info_env (BasicBlock blockid instrs)
101 = sdocWithDynFlags $ \dflags ->
102 maybe_infotable $$
103 pprLabel asmLbl $$
104 vcat (map pprInstr instrs) $$
105 (if gopt Opt_Debug dflags
106 then ppr (mkAsmTempEndLabel asmLbl) <> char ':' else empty)
107 where
108 asmLbl = mkAsmTempLabel (getUnique blockid)
109 maybe_infotable = case mapLookup blockid info_env of
110 Nothing -> empty
111 Just (Statics info_lbl info) ->
112 infoTableLoc $$
113 vcat (map pprData info) $$
114 pprLabel info_lbl
115 -- Make sure the info table has the right .loc for the block
116 -- coming right after it. See [Note: Info Offset]
117 infoTableLoc = case instrs of
118 (l@LOCATION{} : _) -> pprInstr l
119 _other -> empty
120
121 pprDatas :: (Alignment, CmmStatics) -> SDoc
122 pprDatas (align, (Statics lbl dats))
123 = vcat (pprAlign align : pprLabel lbl : map pprData dats)
124 -- TODO: could remove if align == 1
125
126 pprData :: CmmStatic -> SDoc
127 pprData (CmmString str) = pprASCII str
128
129 pprData (CmmUninitialised bytes)
130 = sdocWithPlatform $ \platform ->
131 if platformOS platform == OSDarwin then ptext (sLit ".space ") <> int bytes
132 else ptext (sLit ".skip ") <> int bytes
133
134 pprData (CmmStaticLit lit) = pprDataItem lit
135
136 pprGloblDecl :: CLabel -> SDoc
137 pprGloblDecl lbl
138 | not (externallyVisibleCLabel lbl) = empty
139 | otherwise = ptext (sLit ".globl ") <> ppr lbl
140
141 pprTypeAndSizeDecl :: CLabel -> SDoc
142 pprTypeAndSizeDecl lbl
143 = sdocWithPlatform $ \platform ->
144 if osElfTarget (platformOS platform) && externallyVisibleCLabel lbl
145 then ptext (sLit ".type ") <> ppr lbl <> ptext (sLit ", @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 = ptext (sLit "\t.byte\t") <> int (fromIntegral w)
160
161 pprAlign :: Int -> SDoc
162 pprAlign bytes
163 = sdocWithPlatform $ \platform ->
164 ptext (sLit ".align ") <> int (alignment platform)
165 where
166 alignment platform = if platformOS platform == OSDarwin
167 then log2 bytes
168 else bytes
169
170 log2 :: Int -> Int -- cache the common ones
171 log2 1 = 0
172 log2 2 = 1
173 log2 4 = 2
174 log2 8 = 3
175 log2 n = 1 + log2 (n `quot` 2)
176
177 -- -----------------------------------------------------------------------------
178 -- pprInstr: print an 'Instr'
179
180 instance Outputable Instr where
181 ppr instr = pprInstr instr
182
183
184 pprReg :: Format -> Reg -> SDoc
185 pprReg f r
186 = case r of
187 RegReal (RealRegSingle i) ->
188 sdocWithPlatform $ \platform ->
189 if target32Bit platform then ppr32_reg_no f i
190 else ppr64_reg_no f i
191 RegReal (RealRegPair _ _) -> panic "X86.Ppr: no reg pairs on this arch"
192 RegVirtual (VirtualRegI u) -> text "%vI_" <> pprUnique u
193 RegVirtual (VirtualRegHi u) -> text "%vHi_" <> pprUnique u
194 RegVirtual (VirtualRegF u) -> text "%vF_" <> pprUnique u
195 RegVirtual (VirtualRegD u) -> text "%vD_" <> pprUnique u
196 RegVirtual (VirtualRegSSE u) -> text "%vSSE_" <> pprUnique u
197 where
198 ppr32_reg_no :: Format -> Int -> SDoc
199 ppr32_reg_no II8 = ppr32_reg_byte
200 ppr32_reg_no II16 = ppr32_reg_word
201 ppr32_reg_no _ = ppr32_reg_long
202
203 ppr32_reg_byte i = ptext
204 (case i of {
205 0 -> sLit "%al"; 1 -> sLit "%bl";
206 2 -> sLit "%cl"; 3 -> sLit "%dl";
207 _ -> sLit "very naughty I386 byte register"
208 })
209
210 ppr32_reg_word i = ptext
211 (case i of {
212 0 -> sLit "%ax"; 1 -> sLit "%bx";
213 2 -> sLit "%cx"; 3 -> sLit "%dx";
214 4 -> sLit "%si"; 5 -> sLit "%di";
215 6 -> sLit "%bp"; 7 -> sLit "%sp";
216 _ -> sLit "very naughty I386 word register"
217 })
218
219 ppr32_reg_long i = ptext
220 (case i of {
221 0 -> sLit "%eax"; 1 -> sLit "%ebx";
222 2 -> sLit "%ecx"; 3 -> sLit "%edx";
223 4 -> sLit "%esi"; 5 -> sLit "%edi";
224 6 -> sLit "%ebp"; 7 -> sLit "%esp";
225 _ -> ppr_reg_float i
226 })
227
228 ppr64_reg_no :: Format -> Int -> SDoc
229 ppr64_reg_no II8 = ppr64_reg_byte
230 ppr64_reg_no II16 = ppr64_reg_word
231 ppr64_reg_no II32 = ppr64_reg_long
232 ppr64_reg_no _ = ppr64_reg_quad
233
234 ppr64_reg_byte i = ptext
235 (case i of {
236 0 -> sLit "%al"; 1 -> sLit "%bl";
237 2 -> sLit "%cl"; 3 -> sLit "%dl";
238 4 -> sLit "%sil"; 5 -> sLit "%dil"; -- new 8-bit regs!
239 6 -> sLit "%bpl"; 7 -> sLit "%spl";
240 8 -> sLit "%r8b"; 9 -> sLit "%r9b";
241 10 -> sLit "%r10b"; 11 -> sLit "%r11b";
242 12 -> sLit "%r12b"; 13 -> sLit "%r13b";
243 14 -> sLit "%r14b"; 15 -> sLit "%r15b";
244 _ -> sLit "very naughty x86_64 byte register"
245 })
246
247 ppr64_reg_word i = ptext
248 (case i of {
249 0 -> sLit "%ax"; 1 -> sLit "%bx";
250 2 -> sLit "%cx"; 3 -> sLit "%dx";
251 4 -> sLit "%si"; 5 -> sLit "%di";
252 6 -> sLit "%bp"; 7 -> sLit "%sp";
253 8 -> sLit "%r8w"; 9 -> sLit "%r9w";
254 10 -> sLit "%r10w"; 11 -> sLit "%r11w";
255 12 -> sLit "%r12w"; 13 -> sLit "%r13w";
256 14 -> sLit "%r14w"; 15 -> sLit "%r15w";
257 _ -> sLit "very naughty x86_64 word register"
258 })
259
260 ppr64_reg_long i = ptext
261 (case i of {
262 0 -> sLit "%eax"; 1 -> sLit "%ebx";
263 2 -> sLit "%ecx"; 3 -> sLit "%edx";
264 4 -> sLit "%esi"; 5 -> sLit "%edi";
265 6 -> sLit "%ebp"; 7 -> sLit "%esp";
266 8 -> sLit "%r8d"; 9 -> sLit "%r9d";
267 10 -> sLit "%r10d"; 11 -> sLit "%r11d";
268 12 -> sLit "%r12d"; 13 -> sLit "%r13d";
269 14 -> sLit "%r14d"; 15 -> sLit "%r15d";
270 _ -> sLit "very naughty x86_64 register"
271 })
272
273 ppr64_reg_quad i = ptext
274 (case i of {
275 0 -> sLit "%rax"; 1 -> sLit "%rbx";
276 2 -> sLit "%rcx"; 3 -> sLit "%rdx";
277 4 -> sLit "%rsi"; 5 -> sLit "%rdi";
278 6 -> sLit "%rbp"; 7 -> sLit "%rsp";
279 8 -> sLit "%r8"; 9 -> sLit "%r9";
280 10 -> sLit "%r10"; 11 -> sLit "%r11";
281 12 -> sLit "%r12"; 13 -> sLit "%r13";
282 14 -> sLit "%r14"; 15 -> sLit "%r15";
283 _ -> ppr_reg_float i
284 })
285
286 ppr_reg_float :: Int -> LitString
287 ppr_reg_float i = case i of
288 16 -> sLit "%fake0"; 17 -> sLit "%fake1"
289 18 -> sLit "%fake2"; 19 -> sLit "%fake3"
290 20 -> sLit "%fake4"; 21 -> sLit "%fake5"
291 24 -> sLit "%xmm0"; 25 -> sLit "%xmm1"
292 26 -> sLit "%xmm2"; 27 -> sLit "%xmm3"
293 28 -> sLit "%xmm4"; 29 -> sLit "%xmm5"
294 30 -> sLit "%xmm6"; 31 -> sLit "%xmm7"
295 32 -> sLit "%xmm8"; 33 -> sLit "%xmm9"
296 34 -> sLit "%xmm10"; 35 -> sLit "%xmm11"
297 36 -> sLit "%xmm12"; 37 -> sLit "%xmm13"
298 38 -> sLit "%xmm14"; 39 -> sLit "%xmm15"
299 _ -> sLit "very naughty x86 register"
300
301 pprFormat :: Format -> SDoc
302 pprFormat x
303 = ptext (case x of
304 II8 -> sLit "b"
305 II16 -> sLit "w"
306 II32 -> sLit "l"
307 II64 -> sLit "q"
308 FF32 -> sLit "ss" -- "scalar single-precision float" (SSE2)
309 FF64 -> sLit "sd" -- "scalar double-precision float" (SSE2)
310 FF80 -> sLit "t"
311 )
312
313 pprFormat_x87 :: Format -> SDoc
314 pprFormat_x87 x
315 = ptext $ case x of
316 FF32 -> sLit "s"
317 FF64 -> sLit "l"
318 FF80 -> sLit "t"
319 _ -> panic "X86.Ppr.pprFormat_x87"
320
321 pprCond :: Cond -> SDoc
322 pprCond c
323 = ptext (case c of {
324 GEU -> sLit "ae"; LU -> sLit "b";
325 EQQ -> sLit "e"; GTT -> sLit "g";
326 GE -> sLit "ge"; GU -> sLit "a";
327 LTT -> sLit "l"; LE -> sLit "le";
328 LEU -> sLit "be"; NE -> sLit "ne";
329 NEG -> sLit "s"; POS -> sLit "ns";
330 CARRY -> sLit "c"; OFLO -> sLit "o";
331 PARITY -> sLit "p"; NOTPARITY -> sLit "np";
332 ALWAYS -> sLit "mp"})
333
334
335 pprImm :: Imm -> SDoc
336 pprImm (ImmInt i) = int i
337 pprImm (ImmInteger i) = integer i
338 pprImm (ImmCLbl l) = ppr l
339 pprImm (ImmIndex l i) = ppr l <> char '+' <> int i
340 pprImm (ImmLit s) = s
341
342 pprImm (ImmFloat _) = ptext (sLit "naughty float immediate")
343 pprImm (ImmDouble _) = ptext (sLit "naughty double immediate")
344
345 pprImm (ImmConstantSum a b) = pprImm a <> char '+' <> pprImm b
346 pprImm (ImmConstantDiff a b) = pprImm a <> char '-'
347 <> lparen <> pprImm b <> rparen
348
349
350
351 pprAddr :: AddrMode -> SDoc
352 pprAddr (ImmAddr imm off)
353 = let pp_imm = pprImm imm
354 in
355 if (off == 0) then
356 pp_imm
357 else if (off < 0) then
358 pp_imm <> int off
359 else
360 pp_imm <> char '+' <> int off
361
362 pprAddr (AddrBaseIndex base index displacement)
363 = sdocWithPlatform $ \platform ->
364 let
365 pp_disp = ppr_disp displacement
366 pp_off p = pp_disp <> char '(' <> p <> char ')'
367 pp_reg r = pprReg (archWordFormat (target32Bit platform)) r
368 in
369 case (base, index) of
370 (EABaseNone, EAIndexNone) -> pp_disp
371 (EABaseReg b, EAIndexNone) -> pp_off (pp_reg b)
372 (EABaseRip, EAIndexNone) -> pp_off (ptext (sLit "%rip"))
373 (EABaseNone, EAIndex r i) -> pp_off (comma <> pp_reg r <> comma <> int i)
374 (EABaseReg b, EAIndex r i) -> pp_off (pp_reg b <> comma <> pp_reg r
375 <> comma <> int i)
376 _ -> panic "X86.Ppr.pprAddr: no match"
377
378 where
379 ppr_disp (ImmInt 0) = empty
380 ppr_disp imm = pprImm imm
381
382 -- | Print section header and appropriate alignment for that section.
383 pprSectionAlign :: Section -> SDoc
384 pprSectionAlign (Section (OtherSection _) _) =
385 panic "X86.Ppr.pprSectionAlign: unknown section"
386 pprSectionAlign sec@(Section seg _) =
387 sdocWithPlatform $ \platform ->
388 pprSectionHeader platform sec $$
389 ptext (sLit ".align ") <>
390 case platformOS platform of
391 OSDarwin
392 | target32Bit platform ->
393 case seg of
394 ReadOnlyData16 -> int 4
395 _ -> int 2
396 | otherwise ->
397 case seg of
398 ReadOnlyData16 -> int 4
399 _ -> int 3
400 _
401 | target32Bit platform ->
402 case seg of
403 Text -> ptext (sLit "4,0x90")
404 ReadOnlyData16 -> int 16
405 _ -> int 4
406 | otherwise ->
407 case seg of
408 ReadOnlyData16 -> int 16
409 _ -> int 8
410
411 pprDataItem :: CmmLit -> SDoc
412 pprDataItem lit = sdocWithDynFlags $ \dflags -> pprDataItem' dflags lit
413
414 pprDataItem' :: DynFlags -> CmmLit -> SDoc
415 pprDataItem' dflags lit
416 = vcat (ppr_item (cmmTypeFormat $ cmmLitType dflags lit) lit)
417 where
418 platform = targetPlatform dflags
419 imm = litToImm lit
420
421 -- These seem to be common:
422 ppr_item II8 _ = [ptext (sLit "\t.byte\t") <> pprImm imm]
423 ppr_item II16 _ = [ptext (sLit "\t.word\t") <> pprImm imm]
424 ppr_item II32 _ = [ptext (sLit "\t.long\t") <> pprImm imm]
425
426 ppr_item FF32 (CmmFloat r _)
427 = let bs = floatToBytes (fromRational r)
428 in map (\b -> ptext (sLit "\t.byte\t") <> pprImm (ImmInt b)) bs
429
430 ppr_item FF64 (CmmFloat r _)
431 = let bs = doubleToBytes (fromRational r)
432 in map (\b -> ptext (sLit "\t.byte\t") <> pprImm (ImmInt b)) bs
433
434 ppr_item II64 _
435 = case platformOS platform of
436 OSDarwin
437 | target32Bit platform ->
438 case lit of
439 CmmInt x _ ->
440 [ptext (sLit "\t.long\t")
441 <> int (fromIntegral (fromIntegral x :: Word32)),
442 ptext (sLit "\t.long\t")
443 <> int (fromIntegral
444 (fromIntegral (x `shiftR` 32) :: Word32))]
445 _ -> panic "X86.Ppr.ppr_item: no match for II64"
446 | otherwise ->
447 [ptext (sLit "\t.quad\t") <> pprImm imm]
448 _
449 | target32Bit platform ->
450 [ptext (sLit "\t.quad\t") <> pprImm imm]
451 | otherwise ->
452 -- x86_64: binutils can't handle the R_X86_64_PC64
453 -- relocation type, which means we can't do
454 -- pc-relative 64-bit addresses. Fortunately we're
455 -- assuming the small memory model, in which all such
456 -- offsets will fit into 32 bits, so we have to stick
457 -- to 32-bit offset fields and modify the RTS
458 -- appropriately
459 --
460 -- See Note [x86-64-relative] in includes/rts/storage/InfoTables.h
461 --
462 case lit of
463 -- A relative relocation:
464 CmmLabelDiffOff _ _ _ ->
465 [ptext (sLit "\t.long\t") <> pprImm imm,
466 ptext (sLit "\t.long\t0")]
467 _ ->
468 [ptext (sLit "\t.quad\t") <> pprImm imm]
469
470 ppr_item _ _
471 = panic "X86.Ppr.ppr_item: no match"
472
473
474
475 pprInstr :: Instr -> SDoc
476
477 pprInstr (COMMENT _) = empty -- nuke 'em
478 {-
479 pprInstr (COMMENT s) = ptext (sLit "# ") <> ftext s
480 -}
481
482 pprInstr (LOCATION file line col _name)
483 = ptext (sLit "\t.loc ") <> ppr file <+> ppr line <+> ppr col
484
485 pprInstr (DELTA d)
486 = pprInstr (COMMENT (mkFastString ("\tdelta = " ++ show d)))
487
488 pprInstr (NEWBLOCK _)
489 = panic "PprMach.pprInstr: NEWBLOCK"
490
491 pprInstr (LDATA _ _)
492 = panic "PprMach.pprInstr: LDATA"
493
494 {-
495 pprInstr (SPILL reg slot)
496 = hcat [
497 ptext (sLit "\tSPILL"),
498 char ' ',
499 pprUserReg reg,
500 comma,
501 ptext (sLit "SLOT") <> parens (int slot)]
502
503 pprInstr (RELOAD slot reg)
504 = hcat [
505 ptext (sLit "\tRELOAD"),
506 char ' ',
507 ptext (sLit "SLOT") <> parens (int slot),
508 comma,
509 pprUserReg reg]
510 -}
511
512 -- Replace 'mov $0x0,%reg' by 'xor %reg,%reg', which is smaller and cheaper.
513 -- The code generator catches most of these already, but not all.
514 pprInstr (MOV format (OpImm (ImmInt 0)) dst@(OpReg _))
515 = pprInstr (XOR format' dst dst)
516 where format' = case format of
517 II64 -> II32 -- 32-bit version is equivalent, and smaller
518 _ -> format
519 pprInstr (MOV format src dst)
520 = pprFormatOpOp (sLit "mov") format src dst
521
522 pprInstr (CMOV cc format src dst)
523 = pprCondOpReg (sLit "cmov") format cc src dst
524
525 pprInstr (MOVZxL II32 src dst) = pprFormatOpOp (sLit "mov") II32 src dst
526 -- 32-to-64 bit zero extension on x86_64 is accomplished by a simple
527 -- movl. But we represent it as a MOVZxL instruction, because
528 -- the reg alloc would tend to throw away a plain reg-to-reg
529 -- move, and we still want it to do that.
530
531 pprInstr (MOVZxL formats src dst)
532 = pprFormatOpOpCoerce (sLit "movz") formats II32 src dst
533 -- zero-extension only needs to extend to 32 bits: on x86_64,
534 -- the remaining zero-extension to 64 bits is automatic, and the 32-bit
535 -- instruction is shorter.
536
537 pprInstr (MOVSxL formats src dst)
538 = sdocWithPlatform $ \platform ->
539 pprFormatOpOpCoerce (sLit "movs") formats (archWordFormat (target32Bit platform)) src dst
540
541 -- here we do some patching, since the physical registers are only set late
542 -- in the code generation.
543 pprInstr (LEA format (OpAddr (AddrBaseIndex (EABaseReg reg1) (EAIndex reg2 1) (ImmInt 0))) dst@(OpReg reg3))
544 | reg1 == reg3
545 = pprFormatOpOp (sLit "add") format (OpReg reg2) dst
546
547 pprInstr (LEA format (OpAddr (AddrBaseIndex (EABaseReg reg1) (EAIndex reg2 1) (ImmInt 0))) dst@(OpReg reg3))
548 | reg2 == reg3
549 = pprFormatOpOp (sLit "add") format (OpReg reg1) dst
550
551 pprInstr (LEA format (OpAddr (AddrBaseIndex (EABaseReg reg1) EAIndexNone displ)) dst@(OpReg reg3))
552 | reg1 == reg3
553 = pprInstr (ADD format (OpImm displ) dst)
554
555 pprInstr (LEA format src dst) = pprFormatOpOp (sLit "lea") format src dst
556
557 pprInstr (ADD format (OpImm (ImmInt (-1))) dst)
558 = pprFormatOp (sLit "dec") format dst
559 pprInstr (ADD format (OpImm (ImmInt 1)) dst)
560 = pprFormatOp (sLit "inc") format dst
561 pprInstr (ADD format src dst) = pprFormatOpOp (sLit "add") format src dst
562 pprInstr (ADC format src dst) = pprFormatOpOp (sLit "adc") format src dst
563 pprInstr (SUB format src dst) = pprFormatOpOp (sLit "sub") format src dst
564 pprInstr (SBB format src dst) = pprFormatOpOp (sLit "sbb") format src dst
565 pprInstr (IMUL format op1 op2) = pprFormatOpOp (sLit "imul") format op1 op2
566
567 pprInstr (ADD_CC format src dst)
568 = pprFormatOpOp (sLit "add") format src dst
569 pprInstr (SUB_CC format src dst)
570 = pprFormatOpOp (sLit "sub") format src dst
571
572 {- A hack. The Intel documentation says that "The two and three
573 operand forms [of IMUL] may also be used with unsigned operands
574 because the lower half of the product is the same regardless if
575 (sic) the operands are signed or unsigned. The CF and OF flags,
576 however, cannot be used to determine if the upper half of the
577 result is non-zero." So there.
578 -}
579
580 -- Use a 32-bit instruction when possible as it saves a byte.
581 -- Notably, extracting the tag bits of a pointer has this form.
582 -- TODO: we could save a byte in a subsequent CMP instruction too,
583 -- but need something like a peephole pass for this
584 pprInstr (AND II64 src@(OpImm (ImmInteger mask)) dst)
585 | 0 <= mask && mask < 0xffffffff
586 = pprInstr (AND II32 src dst)
587 pprInstr (AND format src dst) = pprFormatOpOp (sLit "and") format src dst
588 pprInstr (OR format src dst) = pprFormatOpOp (sLit "or") format src dst
589
590 pprInstr (XOR FF32 src dst) = pprOpOp (sLit "xorps") FF32 src dst
591 pprInstr (XOR FF64 src dst) = pprOpOp (sLit "xorpd") FF64 src dst
592 pprInstr (XOR format src dst) = pprFormatOpOp (sLit "xor") format src dst
593
594 pprInstr (POPCNT format src dst) = pprOpOp (sLit "popcnt") format src (OpReg dst)
595 pprInstr (BSF format src dst) = pprOpOp (sLit "bsf") format src (OpReg dst)
596 pprInstr (BSR format src dst) = pprOpOp (sLit "bsr") format src (OpReg dst)
597
598 pprInstr (PREFETCH NTA format src ) = pprFormatOp_ (sLit "prefetchnta") format src
599 pprInstr (PREFETCH Lvl0 format src) = pprFormatOp_ (sLit "prefetcht0") format src
600 pprInstr (PREFETCH Lvl1 format src) = pprFormatOp_ (sLit "prefetcht1") format src
601 pprInstr (PREFETCH Lvl2 format src) = pprFormatOp_ (sLit "prefetcht2") format src
602
603 pprInstr (NOT format op) = pprFormatOp (sLit "not") format op
604 pprInstr (BSWAP format op) = pprFormatOp (sLit "bswap") format (OpReg op)
605 pprInstr (NEGI format op) = pprFormatOp (sLit "neg") format op
606
607 pprInstr (SHL format src dst) = pprShift (sLit "shl") format src dst
608 pprInstr (SAR format src dst) = pprShift (sLit "sar") format src dst
609 pprInstr (SHR format src dst) = pprShift (sLit "shr") format src dst
610
611 pprInstr (BT format imm src) = pprFormatImmOp (sLit "bt") format imm src
612
613 pprInstr (CMP format src dst)
614 | isFloatFormat format = pprFormatOpOp (sLit "ucomi") format src dst -- SSE2
615 | otherwise = pprFormatOpOp (sLit "cmp") format src dst
616
617 pprInstr (TEST format src dst) = sdocWithPlatform $ \platform ->
618 let format' = case (src,dst) of
619 -- Match instructions like 'test $0x3,%esi' or 'test $0x7,%rbx'.
620 -- We can replace them by equivalent, but smaller instructions
621 -- by reducing the size of the immediate operand as far as possible.
622 -- (We could handle masks larger than a single byte too,
623 -- but it would complicate the code considerably
624 -- and tag checks are by far the most common case.)
625 (OpImm (ImmInteger mask), OpReg dstReg)
626 | 0 <= mask && mask < 256 -> minSizeOfReg platform dstReg
627 _ -> format
628 in pprFormatOpOp (sLit "test") format' src dst
629 where
630 minSizeOfReg platform (RegReal (RealRegSingle i))
631 | target32Bit platform && i <= 3 = II8 -- al, bl, cl, dl
632 | target32Bit platform && i <= 7 = II16 -- si, di, bp, sp
633 | not (target32Bit platform) && i <= 15 = II8 -- al .. r15b
634 minSizeOfReg _ _ = format -- other
635
636 pprInstr (PUSH format op) = pprFormatOp (sLit "push") format op
637 pprInstr (POP format op) = pprFormatOp (sLit "pop") format op
638
639 -- both unused (SDM):
640 -- pprInstr PUSHA = ptext (sLit "\tpushal")
641 -- pprInstr POPA = ptext (sLit "\tpopal")
642
643 pprInstr NOP = ptext (sLit "\tnop")
644 pprInstr (CLTD II32) = ptext (sLit "\tcltd")
645 pprInstr (CLTD II64) = ptext (sLit "\tcqto")
646
647 pprInstr (SETCC cond op) = pprCondInstr (sLit "set") cond (pprOperand II8 op)
648
649 pprInstr (JXX cond blockid)
650 = pprCondInstr (sLit "j") cond (ppr lab)
651 where lab = mkAsmTempLabel (getUnique blockid)
652
653 pprInstr (JXX_GBL cond imm) = pprCondInstr (sLit "j") cond (pprImm imm)
654
655 pprInstr (JMP (OpImm imm) _) = ptext (sLit "\tjmp ") <> pprImm imm
656 pprInstr (JMP op _) = sdocWithPlatform $ \platform ->
657 ptext (sLit "\tjmp *")
658 <> pprOperand (archWordFormat (target32Bit platform)) op
659 pprInstr (JMP_TBL op _ _ _) = pprInstr (JMP op [])
660 pprInstr (CALL (Left imm) _) = ptext (sLit "\tcall ") <> pprImm imm
661 pprInstr (CALL (Right reg) _) = sdocWithPlatform $ \platform ->
662 ptext (sLit "\tcall *")
663 <> pprReg (archWordFormat (target32Bit platform)) reg
664
665 pprInstr (IDIV fmt op) = pprFormatOp (sLit "idiv") fmt op
666 pprInstr (DIV fmt op) = pprFormatOp (sLit "div") fmt op
667 pprInstr (IMUL2 fmt op) = pprFormatOp (sLit "imul") fmt op
668
669 -- x86_64 only
670 pprInstr (MUL format op1 op2) = pprFormatOpOp (sLit "mul") format op1 op2
671 pprInstr (MUL2 format op) = pprFormatOp (sLit "mul") format op
672
673 pprInstr (FDIV format op1 op2) = pprFormatOpOp (sLit "div") format op1 op2
674
675 pprInstr (CVTSS2SD from to) = pprRegReg (sLit "cvtss2sd") from to
676 pprInstr (CVTSD2SS from to) = pprRegReg (sLit "cvtsd2ss") from to
677 pprInstr (CVTTSS2SIQ fmt from to) = pprFormatFormatOpReg (sLit "cvttss2si") FF32 fmt from to
678 pprInstr (CVTTSD2SIQ fmt from to) = pprFormatFormatOpReg (sLit "cvttsd2si") FF64 fmt from to
679 pprInstr (CVTSI2SS fmt from to) = pprFormatOpReg (sLit "cvtsi2ss") fmt from to
680 pprInstr (CVTSI2SD fmt from to) = pprFormatOpReg (sLit "cvtsi2sd") fmt from to
681
682 -- FETCHGOT for PIC on ELF platforms
683 pprInstr (FETCHGOT reg)
684 = vcat [ ptext (sLit "\tcall 1f"),
685 hcat [ ptext (sLit "1:\tpopl\t"), pprReg II32 reg ],
686 hcat [ ptext (sLit "\taddl\t$_GLOBAL_OFFSET_TABLE_+(.-1b), "),
687 pprReg II32 reg ]
688 ]
689
690 -- FETCHPC for PIC on Darwin/x86
691 -- get the instruction pointer into a register
692 -- (Terminology note: the IP is called Program Counter on PPC,
693 -- and it's a good thing to use the same name on both platforms)
694 pprInstr (FETCHPC reg)
695 = vcat [ ptext (sLit "\tcall 1f"),
696 hcat [ ptext (sLit "1:\tpopl\t"), pprReg II32 reg ]
697 ]
698
699
700 -- -----------------------------------------------------------------------------
701 -- i386 floating-point
702
703 -- Simulating a flat register set on the x86 FP stack is tricky.
704 -- you have to free %st(7) before pushing anything on the FP reg stack
705 -- so as to preclude the possibility of a FP stack overflow exception.
706 pprInstr g@(GMOV src dst)
707 | src == dst
708 = empty
709 | otherwise
710 = pprG g (hcat [gtab, gpush src 0, gsemi, gpop dst 1])
711
712 -- GLD fmt addr dst ==> FLDsz addr ; FSTP (dst+1)
713 pprInstr g@(GLD fmt addr dst)
714 = pprG g (hcat [gtab, text "fld", pprFormat_x87 fmt, gsp,
715 pprAddr addr, gsemi, gpop dst 1])
716
717 -- GST fmt src addr ==> FLD dst ; FSTPsz addr
718 pprInstr g@(GST fmt src addr)
719 | src == fake0 && fmt /= FF80 -- fstt instruction doesn't exist
720 = pprG g (hcat [gtab,
721 text "fst", pprFormat_x87 fmt, gsp, pprAddr addr])
722 | otherwise
723 = pprG g (hcat [gtab, gpush src 0, gsemi,
724 text "fstp", pprFormat_x87 fmt, gsp, pprAddr addr])
725
726 pprInstr g@(GLDZ dst)
727 = pprG g (hcat [gtab, text "fldz ; ", gpop dst 1])
728 pprInstr g@(GLD1 dst)
729 = pprG g (hcat [gtab, text "fld1 ; ", gpop dst 1])
730
731 pprInstr (GFTOI src dst)
732 = pprInstr (GDTOI src dst)
733
734 pprInstr g@(GDTOI src dst)
735 = pprG g (vcat [
736 hcat [gtab, text "subl $8, %esp ; fnstcw 4(%esp)"],
737 hcat [gtab, gpush src 0],
738 hcat [gtab, text "movzwl 4(%esp), ", reg,
739 text " ; orl $0xC00, ", reg],
740 hcat [gtab, text "movl ", reg, text ", 0(%esp) ; fldcw 0(%esp)"],
741 hcat [gtab, text "fistpl 0(%esp)"],
742 hcat [gtab, text "fldcw 4(%esp) ; movl 0(%esp), ", reg],
743 hcat [gtab, text "addl $8, %esp"]
744 ])
745 where
746 reg = pprReg II32 dst
747
748 pprInstr (GITOF src dst)
749 = pprInstr (GITOD src dst)
750
751 pprInstr g@(GITOD src dst)
752 = pprG g (hcat [gtab, text "pushl ", pprReg II32 src,
753 text " ; fildl (%esp) ; ",
754 gpop dst 1, text " ; addl $4,%esp"])
755
756 pprInstr g@(GDTOF src dst)
757 = pprG g (vcat [gtab <> gpush src 0,
758 gtab <> text "subl $4,%esp ; fstps (%esp) ; flds (%esp) ; addl $4,%esp ;",
759 gtab <> gpop dst 1])
760
761 {- Gruesome swamp follows. If you're unfortunate enough to have ventured
762 this far into the jungle AND you give a Rat's Ass (tm) what's going
763 on, here's the deal. Generate code to do a floating point comparison
764 of src1 and src2, of kind cond, and set the Zero flag if true.
765
766 The complications are to do with handling NaNs correctly. We want the
767 property that if either argument is NaN, then the result of the
768 comparison is False ... except if we're comparing for inequality,
769 in which case the answer is True.
770
771 Here's how the general (non-inequality) case works. As an
772 example, consider generating the an equality test:
773
774 pushl %eax -- we need to mess with this
775 <get src1 to top of FPU stack>
776 fcomp <src2 location in FPU stack> and pop pushed src1
777 -- Result of comparison is in FPU Status Register bits
778 -- C3 C2 and C0
779 fstsw %ax -- Move FPU Status Reg to %ax
780 sahf -- move C3 C2 C0 from %ax to integer flag reg
781 -- now the serious magic begins
782 setpo %ah -- %ah = if comparable(neither arg was NaN) then 1 else 0
783 sete %al -- %al = if arg1 == arg2 then 1 else 0
784 andb %ah,%al -- %al &= %ah
785 -- so %al == 1 iff (comparable && same); else it holds 0
786 decb %al -- %al == 0, ZeroFlag=1 iff (comparable && same);
787 else %al == 0xFF, ZeroFlag=0
788 -- the zero flag is now set as we desire.
789 popl %eax
790
791 The special case of inequality differs thusly:
792
793 setpe %ah -- %ah = if incomparable(either arg was NaN) then 1 else 0
794 setne %al -- %al = if arg1 /= arg2 then 1 else 0
795 orb %ah,%al -- %al = if (incomparable || different) then 1 else 0
796 decb %al -- if (incomparable || different) then (%al == 0, ZF=1)
797 else (%al == 0xFF, ZF=0)
798 -}
799 pprInstr g@(GCMP cond src1 src2)
800 | case cond of { NE -> True; _ -> False }
801 = pprG g (vcat [
802 hcat [gtab, text "pushl %eax ; ",gpush src1 0],
803 hcat [gtab, text "fcomp ", greg src2 1,
804 text "; fstsw %ax ; sahf ; setpe %ah"],
805 hcat [gtab, text "setne %al ; ",
806 text "orb %ah,%al ; decb %al ; popl %eax"]
807 ])
808 | otherwise
809 = pprG g (vcat [
810 hcat [gtab, text "pushl %eax ; ",gpush src1 0],
811 hcat [gtab, text "fcomp ", greg src2 1,
812 text "; fstsw %ax ; sahf ; setpo %ah"],
813 hcat [gtab, text "set", pprCond (fix_FP_cond cond), text " %al ; ",
814 text "andb %ah,%al ; decb %al ; popl %eax"]
815 ])
816 where
817 {- On the 486, the flags set by FP compare are the unsigned ones!
818 (This looks like a HACK to me. WDP 96/03)
819 -}
820 fix_FP_cond :: Cond -> Cond
821 fix_FP_cond GE = GEU
822 fix_FP_cond GTT = GU
823 fix_FP_cond LTT = LU
824 fix_FP_cond LE = LEU
825 fix_FP_cond EQQ = EQQ
826 fix_FP_cond NE = NE
827 fix_FP_cond _ = panic "X86.Ppr.fix_FP_cond: no match"
828 -- there should be no others
829
830
831 pprInstr g@(GABS _ src dst)
832 = pprG g (hcat [gtab, gpush src 0, text " ; fabs ; ", gpop dst 1])
833
834 pprInstr g@(GNEG _ src dst)
835 = pprG g (hcat [gtab, gpush src 0, text " ; fchs ; ", gpop dst 1])
836
837 pprInstr g@(GSQRT fmt src dst)
838 = pprG g (hcat [gtab, gpush src 0, text " ; fsqrt"] $$
839 hcat [gtab, gcoerceto fmt, gpop dst 1])
840
841 pprInstr g@(GSIN fmt l1 l2 src dst)
842 = pprG g (pprTrigOp "fsin" False l1 l2 src dst fmt)
843
844 pprInstr g@(GCOS fmt l1 l2 src dst)
845 = pprG g (pprTrigOp "fcos" False l1 l2 src dst fmt)
846
847 pprInstr g@(GTAN fmt l1 l2 src dst)
848 = pprG g (pprTrigOp "fptan" True l1 l2 src dst fmt)
849
850 -- In the translations for GADD, GMUL, GSUB and GDIV,
851 -- the first two cases are mere optimisations. The otherwise clause
852 -- generates correct code under all circumstances.
853
854 pprInstr g@(GADD _ src1 src2 dst)
855 | src1 == dst
856 = pprG g (text "\t#GADD-xxxcase1" $$
857 hcat [gtab, gpush src2 0,
858 text " ; faddp %st(0),", greg src1 1])
859 | src2 == dst
860 = pprG g (text "\t#GADD-xxxcase2" $$
861 hcat [gtab, gpush src1 0,
862 text " ; faddp %st(0),", greg src2 1])
863 | otherwise
864 = pprG g (hcat [gtab, gpush src1 0,
865 text " ; fadd ", greg src2 1, text ",%st(0)",
866 gsemi, gpop dst 1])
867
868
869 pprInstr g@(GMUL _ src1 src2 dst)
870 | src1 == dst
871 = pprG g (text "\t#GMUL-xxxcase1" $$
872 hcat [gtab, gpush src2 0,
873 text " ; fmulp %st(0),", greg src1 1])
874 | src2 == dst
875 = pprG g (text "\t#GMUL-xxxcase2" $$
876 hcat [gtab, gpush src1 0,
877 text " ; fmulp %st(0),", greg src2 1])
878 | otherwise
879 = pprG g (hcat [gtab, gpush src1 0,
880 text " ; fmul ", greg src2 1, text ",%st(0)",
881 gsemi, gpop dst 1])
882
883
884 pprInstr g@(GSUB _ src1 src2 dst)
885 | src1 == dst
886 = pprG g (text "\t#GSUB-xxxcase1" $$
887 hcat [gtab, gpush src2 0,
888 text " ; fsubrp %st(0),", greg src1 1])
889 | src2 == dst
890 = pprG g (text "\t#GSUB-xxxcase2" $$
891 hcat [gtab, gpush src1 0,
892 text " ; fsubp %st(0),", greg src2 1])
893 | otherwise
894 = pprG g (hcat [gtab, gpush src1 0,
895 text " ; fsub ", greg src2 1, text ",%st(0)",
896 gsemi, gpop dst 1])
897
898
899 pprInstr g@(GDIV _ src1 src2 dst)
900 | src1 == dst
901 = pprG g (text "\t#GDIV-xxxcase1" $$
902 hcat [gtab, gpush src2 0,
903 text " ; fdivrp %st(0),", greg src1 1])
904 | src2 == dst
905 = pprG g (text "\t#GDIV-xxxcase2" $$
906 hcat [gtab, gpush src1 0,
907 text " ; fdivp %st(0),", greg src2 1])
908 | otherwise
909 = pprG g (hcat [gtab, gpush src1 0,
910 text " ; fdiv ", greg src2 1, text ",%st(0)",
911 gsemi, gpop dst 1])
912
913
914 pprInstr GFREE
915 = vcat [ ptext (sLit "\tffree %st(0) ;ffree %st(1) ;ffree %st(2) ;ffree %st(3)"),
916 ptext (sLit "\tffree %st(4) ;ffree %st(5)")
917 ]
918
919 -- Atomics
920
921 pprInstr (LOCK i) = ptext (sLit "\tlock") $$ pprInstr i
922
923 pprInstr MFENCE = ptext (sLit "\tmfence")
924
925 pprInstr (XADD format src dst) = pprFormatOpOp (sLit "xadd") format src dst
926
927 pprInstr (CMPXCHG format src dst)
928 = pprFormatOpOp (sLit "cmpxchg") format src dst
929
930 pprInstr _
931 = panic "X86.Ppr.pprInstr: no match"
932
933
934 pprTrigOp :: String -> Bool -> CLabel -> CLabel
935 -> Reg -> Reg -> Format -> SDoc
936 pprTrigOp op -- fsin, fcos or fptan
937 isTan -- we need a couple of extra steps if we're doing tan
938 l1 l2 -- internal labels for us to use
939 src dst fmt
940 = -- We'll be needing %eax later on
941 hcat [gtab, text "pushl %eax;"] $$
942 -- tan is going to use an extra space on the FP stack
943 (if isTan then hcat [gtab, text "ffree %st(6)"] else empty) $$
944 -- First put the value in %st(0) and try to apply the op to it
945 hcat [gpush src 0, text ("; " ++ op)] $$
946 -- Now look to see if C2 was set (overflow, |value| >= 2^63)
947 hcat [gtab, text "fnstsw %ax"] $$
948 hcat [gtab, text "test $0x400,%eax"] $$
949 -- If we were in bounds then jump to the end
950 hcat [gtab, text "je " <> ppr l1] $$
951 -- Otherwise we need to shrink the value. Start by
952 -- loading pi, doubleing it (by adding it to itself),
953 -- and then swapping pi with the value, so the value we
954 -- want to apply op to is in %st(0) again
955 hcat [gtab, text "ffree %st(7); fldpi"] $$
956 hcat [gtab, text "fadd %st(0),%st"] $$
957 hcat [gtab, text "fxch %st(1)"] $$
958 -- Now we have a loop in which we make the value smaller,
959 -- see if it's small enough, and loop if not
960 (ppr l2 <> char ':') $$
961 hcat [gtab, text "fprem1"] $$
962 -- My Debian libc uses fstsw here for the tan code, but I can't
963 -- see any reason why it should need to be different for tan.
964 hcat [gtab, text "fnstsw %ax"] $$
965 hcat [gtab, text "test $0x400,%eax"] $$
966 hcat [gtab, text "jne " <> ppr l2] $$
967 hcat [gtab, text "fstp %st(1)"] $$
968 hcat [gtab, text op] $$
969 (ppr l1 <> char ':') $$
970 -- Pop the 1.0 tan gave us
971 (if isTan then hcat [gtab, text "fstp %st(0)"] else empty) $$
972 -- Restore %eax
973 hcat [gtab, text "popl %eax;"] $$
974 -- And finally make the result the right size
975 hcat [gtab, gcoerceto fmt, gpop dst 1]
976
977 --------------------------
978
979 -- coerce %st(0) to the specified size
980 gcoerceto :: Format -> SDoc
981 gcoerceto FF64 = empty
982 gcoerceto FF32 = empty --text "subl $4,%esp ; fstps (%esp) ; flds (%esp) ; addl $4,%esp ; "
983 gcoerceto _ = panic "X86.Ppr.gcoerceto: no match"
984
985 gpush :: Reg -> RegNo -> SDoc
986 gpush reg offset
987 = hcat [text "fld ", greg reg offset]
988
989 gpop :: Reg -> RegNo -> SDoc
990 gpop reg offset
991 = hcat [text "fstp ", greg reg offset]
992
993 greg :: Reg -> RegNo -> SDoc
994 greg reg offset = text "%st(" <> int (gregno reg - firstfake+offset) <> char ')'
995
996 gsemi :: SDoc
997 gsemi = text " ; "
998
999 gtab :: SDoc
1000 gtab = char '\t'
1001
1002 gsp :: SDoc
1003 gsp = char ' '
1004
1005 gregno :: Reg -> RegNo
1006 gregno (RegReal (RealRegSingle i)) = i
1007 gregno _ = --pprPanic "gregno" (ppr other)
1008 999 -- bogus; only needed for debug printing
1009
1010 pprG :: Instr -> SDoc -> SDoc
1011 pprG fake actual
1012 = (char '#' <> pprGInstr fake) $$ actual
1013
1014
1015 pprGInstr :: Instr -> SDoc
1016 pprGInstr (GMOV src dst) = pprFormatRegReg (sLit "gmov") FF64 src dst
1017 pprGInstr (GLD fmt src dst) = pprFormatAddrReg (sLit "gld") fmt src dst
1018 pprGInstr (GST fmt src dst) = pprFormatRegAddr (sLit "gst") fmt src dst
1019
1020 pprGInstr (GLDZ dst) = pprFormatReg (sLit "gldz") FF64 dst
1021 pprGInstr (GLD1 dst) = pprFormatReg (sLit "gld1") FF64 dst
1022
1023 pprGInstr (GFTOI src dst) = pprFormatFormatRegReg (sLit "gftoi") FF32 II32 src dst
1024 pprGInstr (GDTOI src dst) = pprFormatFormatRegReg (sLit "gdtoi") FF64 II32 src dst
1025
1026 pprGInstr (GITOF src dst) = pprFormatFormatRegReg (sLit "gitof") II32 FF32 src dst
1027 pprGInstr (GITOD src dst) = pprFormatFormatRegReg (sLit "gitod") II32 FF64 src dst
1028 pprGInstr (GDTOF src dst) = pprFormatFormatRegReg (sLit "gdtof") FF64 FF32 src dst
1029
1030 pprGInstr (GCMP co src dst) = pprCondRegReg (sLit "gcmp_") FF64 co src dst
1031 pprGInstr (GABS fmt src dst) = pprFormatRegReg (sLit "gabs") fmt src dst
1032 pprGInstr (GNEG fmt src dst) = pprFormatRegReg (sLit "gneg") fmt src dst
1033 pprGInstr (GSQRT fmt src dst) = pprFormatRegReg (sLit "gsqrt") fmt src dst
1034 pprGInstr (GSIN fmt _ _ src dst) = pprFormatRegReg (sLit "gsin") fmt src dst
1035 pprGInstr (GCOS fmt _ _ src dst) = pprFormatRegReg (sLit "gcos") fmt src dst
1036 pprGInstr (GTAN fmt _ _ src dst) = pprFormatRegReg (sLit "gtan") fmt src dst
1037
1038 pprGInstr (GADD fmt src1 src2 dst) = pprFormatRegRegReg (sLit "gadd") fmt src1 src2 dst
1039 pprGInstr (GSUB fmt src1 src2 dst) = pprFormatRegRegReg (sLit "gsub") fmt src1 src2 dst
1040 pprGInstr (GMUL fmt src1 src2 dst) = pprFormatRegRegReg (sLit "gmul") fmt src1 src2 dst
1041 pprGInstr (GDIV fmt src1 src2 dst) = pprFormatRegRegReg (sLit "gdiv") fmt src1 src2 dst
1042
1043 pprGInstr _ = panic "X86.Ppr.pprGInstr: no match"
1044
1045 pprDollImm :: Imm -> SDoc
1046 pprDollImm i = ptext (sLit "$") <> pprImm i
1047
1048
1049 pprOperand :: Format -> Operand -> SDoc
1050 pprOperand f (OpReg r) = pprReg f r
1051 pprOperand _ (OpImm i) = pprDollImm i
1052 pprOperand _ (OpAddr ea) = pprAddr ea
1053
1054
1055 pprMnemonic_ :: LitString -> SDoc
1056 pprMnemonic_ name =
1057 char '\t' <> ptext name <> space
1058
1059
1060 pprMnemonic :: LitString -> Format -> SDoc
1061 pprMnemonic name format =
1062 char '\t' <> ptext name <> pprFormat format <> space
1063
1064
1065 pprFormatImmOp :: LitString -> Format -> Imm -> Operand -> SDoc
1066 pprFormatImmOp name format imm op1
1067 = hcat [
1068 pprMnemonic name format,
1069 char '$',
1070 pprImm imm,
1071 comma,
1072 pprOperand format op1
1073 ]
1074
1075
1076 pprFormatOp_ :: LitString -> Format -> Operand -> SDoc
1077 pprFormatOp_ name format op1
1078 = hcat [
1079 pprMnemonic_ name ,
1080 pprOperand format op1
1081 ]
1082
1083 pprFormatOp :: LitString -> Format -> Operand -> SDoc
1084 pprFormatOp name format op1
1085 = hcat [
1086 pprMnemonic name format,
1087 pprOperand format op1
1088 ]
1089
1090
1091 pprFormatOpOp :: LitString -> Format -> Operand -> Operand -> SDoc
1092 pprFormatOpOp name format op1 op2
1093 = hcat [
1094 pprMnemonic name format,
1095 pprOperand format op1,
1096 comma,
1097 pprOperand format op2
1098 ]
1099
1100
1101 pprOpOp :: LitString -> Format -> Operand -> Operand -> SDoc
1102 pprOpOp name format op1 op2
1103 = hcat [
1104 pprMnemonic_ name,
1105 pprOperand format op1,
1106 comma,
1107 pprOperand format op2
1108 ]
1109
1110
1111 pprFormatReg :: LitString -> Format -> Reg -> SDoc
1112 pprFormatReg name format reg1
1113 = hcat [
1114 pprMnemonic name format,
1115 pprReg format reg1
1116 ]
1117
1118
1119 pprFormatRegReg :: LitString -> Format -> Reg -> Reg -> SDoc
1120 pprFormatRegReg name format reg1 reg2
1121 = hcat [
1122 pprMnemonic name format,
1123 pprReg format reg1,
1124 comma,
1125 pprReg format reg2
1126 ]
1127
1128
1129 pprRegReg :: LitString -> Reg -> Reg -> SDoc
1130 pprRegReg name reg1 reg2
1131 = sdocWithPlatform $ \platform ->
1132 hcat [
1133 pprMnemonic_ name,
1134 pprReg (archWordFormat (target32Bit platform)) reg1,
1135 comma,
1136 pprReg (archWordFormat (target32Bit platform)) reg2
1137 ]
1138
1139
1140 pprFormatOpReg :: LitString -> Format -> Operand -> Reg -> SDoc
1141 pprFormatOpReg name format op1 reg2
1142 = sdocWithPlatform $ \platform ->
1143 hcat [
1144 pprMnemonic name format,
1145 pprOperand format op1,
1146 comma,
1147 pprReg (archWordFormat (target32Bit platform)) reg2
1148 ]
1149
1150 pprCondOpReg :: LitString -> Format -> Cond -> Operand -> Reg -> SDoc
1151 pprCondOpReg name format cond op1 reg2
1152 = hcat [
1153 char '\t',
1154 ptext name,
1155 pprCond cond,
1156 space,
1157 pprOperand format op1,
1158 comma,
1159 pprReg format reg2
1160 ]
1161
1162 pprCondRegReg :: LitString -> Format -> Cond -> Reg -> Reg -> SDoc
1163 pprCondRegReg name format cond reg1 reg2
1164 = hcat [
1165 char '\t',
1166 ptext name,
1167 pprCond cond,
1168 space,
1169 pprReg format reg1,
1170 comma,
1171 pprReg format reg2
1172 ]
1173
1174 pprFormatFormatRegReg :: LitString -> Format -> Format -> Reg -> Reg -> SDoc
1175 pprFormatFormatRegReg name format1 format2 reg1 reg2
1176 = hcat [
1177 char '\t',
1178 ptext name,
1179 pprFormat format1,
1180 pprFormat format2,
1181 space,
1182 pprReg format1 reg1,
1183 comma,
1184 pprReg format2 reg2
1185 ]
1186
1187 pprFormatFormatOpReg :: LitString -> Format -> Format -> Operand -> Reg -> SDoc
1188 pprFormatFormatOpReg name format1 format2 op1 reg2
1189 = hcat [
1190 pprMnemonic name format2,
1191 pprOperand format1 op1,
1192 comma,
1193 pprReg format2 reg2
1194 ]
1195
1196 pprFormatRegRegReg :: LitString -> Format -> Reg -> Reg -> Reg -> SDoc
1197 pprFormatRegRegReg name format reg1 reg2 reg3
1198 = hcat [
1199 pprMnemonic name format,
1200 pprReg format reg1,
1201 comma,
1202 pprReg format reg2,
1203 comma,
1204 pprReg format reg3
1205 ]
1206
1207
1208 pprFormatAddrReg :: LitString -> Format -> AddrMode -> Reg -> SDoc
1209 pprFormatAddrReg name format op dst
1210 = hcat [
1211 pprMnemonic name format,
1212 pprAddr op,
1213 comma,
1214 pprReg format dst
1215 ]
1216
1217
1218 pprFormatRegAddr :: LitString -> Format -> Reg -> AddrMode -> SDoc
1219 pprFormatRegAddr name format src op
1220 = hcat [
1221 pprMnemonic name format,
1222 pprReg format src,
1223 comma,
1224 pprAddr op
1225 ]
1226
1227
1228 pprShift :: LitString -> Format -> Operand -> Operand -> SDoc
1229 pprShift name format src dest
1230 = hcat [
1231 pprMnemonic name format,
1232 pprOperand II8 src, -- src is 8-bit sized
1233 comma,
1234 pprOperand format dest
1235 ]
1236
1237
1238 pprFormatOpOpCoerce :: LitString -> Format -> Format -> Operand -> Operand -> SDoc
1239 pprFormatOpOpCoerce name format1 format2 op1 op2
1240 = hcat [ char '\t', ptext name, pprFormat format1, pprFormat format2, space,
1241 pprOperand format1 op1,
1242 comma,
1243 pprOperand format2 op2
1244 ]
1245
1246
1247 pprCondInstr :: LitString -> Cond -> SDoc -> SDoc
1248 pprCondInstr name cond arg
1249 = hcat [ char '\t', ptext name, pprCond cond, space, arg]
1250