Context Navigation

CodeGen.hs

Visit:

Revision 74b9eb7284a15e67e1283138a0c861808c5a51c5, 99.7 KB (checked in by Ian Lynagh <igloo@…>, 5 weeks ago)
Add an X86/amd64 implementation for quotRemWord2
Property mode set to `100644`

Line
1	-----------------------------------------------------------------------------
2	--
3	-- Generating machine code (instruction selection)
4	--
5	-- (c) The University of Glasgow 1996-2004
6	--
7	-----------------------------------------------------------------------------
8
9	-- This is a big module, but, if you pay attention to
10	-- (a) the sectioning, and (b) the type signatures, the
11	-- structure should not be too overwhelming.
12
13	module X86.CodeGen (
14	cmmTopCodeGen,
15	generateJumpTableForInstr,
16	InstrBlock
17	)
18
19	where
20
21	#include "HsVersions.h"
22	#include "nativeGen/NCG.h"
23	#include "../includes/MachDeps.h"
24
25	-- NCG stuff:
26	import X86.Instr
27	import X86.Cond
28	import X86.Regs
29	import X86.RegInfo
30	import CPrim
31	import Instruction
32	import PIC
33	import NCGMonad
34	import Size
35	import Reg
36	import Platform
37
38	-- Our intermediate code:
39	import BasicTypes
40	import BlockId
41	import Module ( primPackageId )
42	import PprCmm ()
43	import OldCmm
44	import OldPprCmm ()
45	import CLabel
46
47	-- The rest:
48	import StaticFlags ( opt_PIC )
49	import ForeignCall ( CCallConv(..) )
50	import OrdList
51	import Outputable
52	import Unique
53	import FastString
54	import FastBool ( isFastTrue )
55	import Constants ( wORD_SIZE )
56	import DynFlags
57
58	import Control.Monad
59	import Data.Bits
60	import Data.Int
61	import Data.Maybe
62	import Data.Word
63
64	is32BitPlatform :: NatM Bool
65	is32BitPlatform = do
66	dflags <- getDynFlags
67	return $ target32Bit (targetPlatform dflags)
68
69	sse2Enabled :: NatM Bool
70	sse2Enabled = do
71	dflags <- getDynFlags
72	case platformArch (targetPlatform dflags) of
73	ArchX86_64 -> -- SSE2 is fixed on for x86_64. It would be
74	-- possible to make it optional, but we'd need to
75	-- fix at least the foreign call code where the
76	-- calling convention specifies the use of xmm regs,
77	-- and possibly other places.
78	return True
79	ArchX86 -> return (dopt Opt_SSE2 dflags \|\| dopt Opt_SSE4_2 dflags)
80	_ -> panic "sse2Enabled: Not an X86* arch"
81
82	sse4_2Enabled :: NatM Bool
83	sse4_2Enabled = do
84	dflags <- getDynFlags
85	return (dopt Opt_SSE4_2 dflags)
86
87	if_sse2 :: NatM a -> NatM a -> NatM a
88	if_sse2 sse2 x87 = do
89	b <- sse2Enabled
90	if b then sse2 else x87
91
92	cmmTopCodeGen
93	:: RawCmmDecl
94	-> NatM [NatCmmDecl (Alignment, CmmStatics) Instr]
95
96	cmmTopCodeGen (CmmProc info lab (ListGraph blocks)) = do
97	(nat_blocks,statics) <- mapAndUnzipM basicBlockCodeGen blocks
98	picBaseMb <- getPicBaseMaybeNat
99	dflags <- getDynFlags
100	let proc = CmmProc info lab (ListGraph $ concat nat_blocks)
101	tops = proc : concat statics
102	os = platformOS $ targetPlatform dflags
103
104	case picBaseMb of
105	Just picBase -> initializePicBase_x86 ArchX86 os picBase tops
106	Nothing -> return tops
107
108	cmmTopCodeGen (CmmData sec dat) = do
109	return [CmmData sec (1, dat)] -- no translation, we just use CmmStatic
110
111
112	basicBlockCodeGen
113	:: CmmBasicBlock
114	-> NatM ( [NatBasicBlock Instr]
115	, [NatCmmDecl (Alignment, CmmStatics) Instr])
116
117	basicBlockCodeGen (BasicBlock id stmts) = do
118	instrs <- stmtsToInstrs stmts
119	-- code generation may introduce new basic block boundaries, which
120	-- are indicated by the NEWBLOCK instruction. We must split up the
121	-- instruction stream into basic blocks again. Also, we extract
122	-- LDATAs here too.
123	let
124	(top,other_blocks,statics) = foldrOL mkBlocks ([],[],[]) instrs
125
126	mkBlocks (NEWBLOCK id) (instrs,blocks,statics)
127	= ([], BasicBlock id instrs : blocks, statics)
128	mkBlocks (LDATA sec dat) (instrs,blocks,statics)
129	= (instrs, blocks, CmmData sec dat:statics)
130	mkBlocks instr (instrs,blocks,statics)
131	= (instr:instrs, blocks, statics)
132	-- in
133	return (BasicBlock id top : other_blocks, statics)
134
135
136	stmtsToInstrs :: [CmmStmt] -> NatM InstrBlock
137	stmtsToInstrs stmts
138	= do instrss <- mapM stmtToInstrs stmts
139	return (concatOL instrss)
140
141
142	stmtToInstrs :: CmmStmt -> NatM InstrBlock
143	stmtToInstrs stmt = do
144	is32Bit <- is32BitPlatform
145	case stmt of
146	CmmNop -> return nilOL
147	CmmComment s -> return (unitOL (COMMENT s))
148
149	CmmAssign reg src
150	\| isFloatType ty -> assignReg_FltCode size reg src
151	\| is32Bit && isWord64 ty -> assignReg_I64Code reg src
152	\| otherwise -> assignReg_IntCode size reg src
153	where ty = cmmRegType reg
154	size = cmmTypeSize ty
155
156	CmmStore addr src
157	\| isFloatType ty -> assignMem_FltCode size addr src
158	\| is32Bit && isWord64 ty -> assignMem_I64Code addr src
159	\| otherwise -> assignMem_IntCode size addr src
160	where ty = cmmExprType src
161	size = cmmTypeSize ty
162
163	CmmCall target result_regs args _
164	-> genCCall is32Bit target result_regs args
165
166	CmmBranch id -> genBranch id
167	CmmCondBranch arg id -> genCondJump id arg
168	CmmSwitch arg ids -> genSwitch arg ids
169	CmmJump arg _ -> genJump arg
170	CmmReturn ->
171	panic "stmtToInstrs: return statement should have been cps'd away"
172
173
174	--------------------------------------------------------------------------------
175	-- \| 'InstrBlock's are the insn sequences generated by the insn selectors.
176	-- They are really trees of insns to facilitate fast appending, where a
177	-- left-to-right traversal yields the insns in the correct order.
178	--
179	type InstrBlock
180	= OrdList Instr
181
182
183	-- \| Condition codes passed up the tree.
184	--
185	data CondCode
186	= CondCode Bool Cond InstrBlock
187
188
189	-- \| a.k.a "Register64"
190	-- Reg is the lower 32-bit temporary which contains the result.
191	-- Use getHiVRegFromLo to find the other VRegUnique.
192	--
193	-- Rules of this simplified insn selection game are therefore that
194	-- the returned Reg may be modified
195	--
196	data ChildCode64
197	= ChildCode64
198	InstrBlock
199	Reg
200
201
202	-- \| Register's passed up the tree. If the stix code forces the register
203	-- to live in a pre-decided machine register, it comes out as @Fixed@;
204	-- otherwise, it comes out as @Any@, and the parent can decide which
205	-- register to put it in.
206	--
207	data Register
208	= Fixed Size Reg InstrBlock
209	\| Any Size (Reg -> InstrBlock)
210
211
212	swizzleRegisterRep :: Register -> Size -> Register
213	swizzleRegisterRep (Fixed _ reg code) size = Fixed size reg code
214	swizzleRegisterRep (Any _ codefn) size = Any size codefn
215
216
217	-- \| Grab the Reg for a CmmReg
218	getRegisterReg :: Bool -> CmmReg -> Reg
219
220	getRegisterReg use_sse2 (CmmLocal (LocalReg u pk))
221	= let sz = cmmTypeSize pk in
222	if isFloatSize sz && not use_sse2
223	then RegVirtual (mkVirtualReg u FF80)
224	else RegVirtual (mkVirtualReg u sz)
225
226	getRegisterReg _ (CmmGlobal mid)
227	= case globalRegMaybe mid of
228	Just reg -> RegReal $ reg
229	Nothing -> pprPanic "getRegisterReg-memory" (ppr $ CmmGlobal mid)
230	-- By this stage, the only MagicIds remaining should be the
231	-- ones which map to a real machine register on this
232	-- platform. Hence ...
233
234
235	-- \| Memory addressing modes passed up the tree.
236	data Amode
237	= Amode AddrMode InstrBlock
238
239	{-
240	Now, given a tree (the argument to an CmmLoad) that references memory,
241	produce a suitable addressing mode.
242
243	A Rule of the Game (tm) for Amodes: use of the addr bit must
244	immediately follow use of the code part, since the code part puts
245	values in registers which the addr then refers to. So you can't put
246	anything in between, lest it overwrite some of those registers. If
247	you need to do some other computation between the code part and use of
248	the addr bit, first store the effective address from the amode in a
249	temporary, then do the other computation, and then use the temporary:
250
251	code
252	LEA amode, tmp
253	... other computation ...
254	... (tmp) ...
255	-}
256
257
258	-- \| Check whether an integer will fit in 32 bits.
259	-- A CmmInt is intended to be truncated to the appropriate
260	-- number of bits, so here we truncate it to Int64. This is
261	-- important because e.g. -1 as a CmmInt might be either
262	-- -1 or 18446744073709551615.
263	--
264	is32BitInteger :: Integer -> Bool
265	is32BitInteger i = i64 <= 0x7fffffff && i64 >= -0x80000000
266	where i64 = fromIntegral i :: Int64
267
268
269	-- \| Convert a BlockId to some CmmStatic data
270	jumpTableEntry :: Maybe BlockId -> CmmStatic
271	jumpTableEntry Nothing = CmmStaticLit (CmmInt 0 wordWidth)
272	jumpTableEntry (Just blockid) = CmmStaticLit (CmmLabel blockLabel)
273	where blockLabel = mkAsmTempLabel (getUnique blockid)
274
275
276	-- -----------------------------------------------------------------------------
277	-- General things for putting together code sequences
278
279	-- Expand CmmRegOff. ToDo: should we do it this way around, or convert
280	-- CmmExprs into CmmRegOff?
281	mangleIndexTree :: CmmReg -> Int -> CmmExpr
282	mangleIndexTree reg off
283	= CmmMachOp (MO_Add width) [CmmReg reg, CmmLit (CmmInt (fromIntegral off) width)]
284	where width = typeWidth (cmmRegType reg)
285
286	-- \| The dual to getAnyReg: compute an expression into a register, but
287	-- we don't mind which one it is.
288	getSomeReg :: CmmExpr -> NatM (Reg, InstrBlock)
289	getSomeReg expr = do
290	r <- getRegister expr
291	case r of
292	Any rep code -> do
293	tmp <- getNewRegNat rep
294	return (tmp, code tmp)
295	Fixed _ reg code ->
296	return (reg, code)
297
298
299	assignMem_I64Code :: CmmExpr -> CmmExpr -> NatM InstrBlock
300	assignMem_I64Code addrTree valueTree = do
301	Amode addr addr_code <- getAmode addrTree
302	ChildCode64 vcode rlo <- iselExpr64 valueTree
303	let
304	rhi = getHiVRegFromLo rlo
305
306	-- Little-endian store
307	mov_lo = MOV II32 (OpReg rlo) (OpAddr addr)
308	mov_hi = MOV II32 (OpReg rhi) (OpAddr (fromJust (addrOffset addr 4)))
309	-- in
310	return (vcode `appOL` addr_code `snocOL` mov_lo `snocOL` mov_hi)
311
312
313	assignReg_I64Code :: CmmReg -> CmmExpr -> NatM InstrBlock
314	assignReg_I64Code (CmmLocal (LocalReg u_dst _)) valueTree = do
315	ChildCode64 vcode r_src_lo <- iselExpr64 valueTree
316	let
317	r_dst_lo = RegVirtual $ mkVirtualReg u_dst II32
318	r_dst_hi = getHiVRegFromLo r_dst_lo
319	r_src_hi = getHiVRegFromLo r_src_lo
320	mov_lo = MOV II32 (OpReg r_src_lo) (OpReg r_dst_lo)
321	mov_hi = MOV II32 (OpReg r_src_hi) (OpReg r_dst_hi)
322	-- in
323	return (
324	vcode `snocOL` mov_lo `snocOL` mov_hi
325	)
326
327	assignReg_I64Code _ _
328	= panic "assignReg_I64Code(i386): invalid lvalue"
329
330
331	iselExpr64 :: CmmExpr -> NatM ChildCode64
332	iselExpr64 (CmmLit (CmmInt i _)) = do
333	(rlo,rhi) <- getNewRegPairNat II32
334	let
335	r = fromIntegral (fromIntegral i :: Word32)
336	q = fromIntegral (fromIntegral (i `shiftR` 32) :: Word32)
337	code = toOL [
338	MOV II32 (OpImm (ImmInteger r)) (OpReg rlo),
339	MOV II32 (OpImm (ImmInteger q)) (OpReg rhi)
340	]
341	-- in
342	return (ChildCode64 code rlo)
343
344	iselExpr64 (CmmLoad addrTree ty) \| isWord64 ty = do
345	Amode addr addr_code <- getAmode addrTree
346	(rlo,rhi) <- getNewRegPairNat II32
347	let
348	mov_lo = MOV II32 (OpAddr addr) (OpReg rlo)
349	mov_hi = MOV II32 (OpAddr (fromJust (addrOffset addr 4))) (OpReg rhi)
350	-- in
351	return (
352	ChildCode64 (addr_code `snocOL` mov_lo `snocOL` mov_hi)
353	rlo
354	)
355
356	iselExpr64 (CmmReg (CmmLocal (LocalReg vu ty))) \| isWord64 ty
357	= return (ChildCode64 nilOL (RegVirtual $ mkVirtualReg vu II32))
358
359	-- we handle addition, but rather badly
360	iselExpr64 (CmmMachOp (MO_Add _) [e1, CmmLit (CmmInt i _)]) = do
361	ChildCode64 code1 r1lo <- iselExpr64 e1
362	(rlo,rhi) <- getNewRegPairNat II32
363	let
364	r = fromIntegral (fromIntegral i :: Word32)
365	q = fromIntegral (fromIntegral (i `shiftR` 32) :: Word32)
366	r1hi = getHiVRegFromLo r1lo
367	code = code1 `appOL`
368	toOL [ MOV II32 (OpReg r1lo) (OpReg rlo),
369	ADD II32 (OpImm (ImmInteger r)) (OpReg rlo),
370	MOV II32 (OpReg r1hi) (OpReg rhi),
371	ADC II32 (OpImm (ImmInteger q)) (OpReg rhi) ]
372	-- in
373	return (ChildCode64 code rlo)
374
375	iselExpr64 (CmmMachOp (MO_Add _) [e1,e2]) = do
376	ChildCode64 code1 r1lo <- iselExpr64 e1
377	ChildCode64 code2 r2lo <- iselExpr64 e2
378	(rlo,rhi) <- getNewRegPairNat II32
379	let
380	r1hi = getHiVRegFromLo r1lo
381	r2hi = getHiVRegFromLo r2lo
382	code = code1 `appOL`
383	code2 `appOL`
384	toOL [ MOV II32 (OpReg r1lo) (OpReg rlo),
385	ADD II32 (OpReg r2lo) (OpReg rlo),
386	MOV II32 (OpReg r1hi) (OpReg rhi),
387	ADC II32 (OpReg r2hi) (OpReg rhi) ]
388	-- in
389	return (ChildCode64 code rlo)
390
391	iselExpr64 (CmmMachOp (MO_UU_Conv _ W64) [expr]) = do
392	fn <- getAnyReg expr
393	r_dst_lo <- getNewRegNat II32
394	let r_dst_hi = getHiVRegFromLo r_dst_lo
395	code = fn r_dst_lo
396	return (
397	ChildCode64 (code `snocOL`
398	MOV II32 (OpImm (ImmInt 0)) (OpReg r_dst_hi))
399	r_dst_lo
400	)
401
402	iselExpr64 expr
403	= do dflags <- getDynFlags
404	pprPanic "iselExpr64(i386)" (pprPlatform (targetPlatform dflags) expr)
405
406
407	--------------------------------------------------------------------------------
408	getRegister :: CmmExpr -> NatM Register
409	getRegister e = do is32Bit <- is32BitPlatform
410	getRegister' is32Bit e
411
412	getRegister' :: Bool -> CmmExpr -> NatM Register
413
414	getRegister' is32Bit (CmmReg reg)
415	= case reg of
416	CmmGlobal PicBaseReg
417	\| is32Bit ->
418	-- on x86_64, we have %rip for PicBaseReg, but it's not
419	-- a full-featured register, it can only be used for
420	-- rip-relative addressing.
421	do reg' <- getPicBaseNat (archWordSize is32Bit)
422	return (Fixed (archWordSize is32Bit) reg' nilOL)
423	_ ->
424	do use_sse2 <- sse2Enabled
425	let
426	sz = cmmTypeSize (cmmRegType reg)
427	size \| not use_sse2 && isFloatSize sz = FF80
428	\| otherwise = sz
429	--
430	return (Fixed size (getRegisterReg use_sse2 reg) nilOL)
431
432
433	getRegister' is32Bit (CmmRegOff r n)
434	= getRegister' is32Bit $ mangleIndexTree r n
435
436	-- for 32-bit architectuers, support some 64 -> 32 bit conversions:
437	-- TO_W_(x), TO_W_(x >> 32)
438
439	getRegister' is32Bit (CmmMachOp (MO_UU_Conv W64 W32)
440	[CmmMachOp (MO_U_Shr W64) [x,CmmLit (CmmInt 32 _)]])
441	\| is32Bit = do
442	ChildCode64 code rlo <- iselExpr64 x
443	return $ Fixed II32 (getHiVRegFromLo rlo) code
444
445	getRegister' is32Bit (CmmMachOp (MO_SS_Conv W64 W32)
446	[CmmMachOp (MO_U_Shr W64) [x,CmmLit (CmmInt 32 _)]])
447	\| is32Bit = do
448	ChildCode64 code rlo <- iselExpr64 x
449	return $ Fixed II32 (getHiVRegFromLo rlo) code
450
451	getRegister' is32Bit (CmmMachOp (MO_UU_Conv W64 W32) [x])
452	\| is32Bit = do
453	ChildCode64 code rlo <- iselExpr64 x
454	return $ Fixed II32 rlo code
455
456	getRegister' is32Bit (CmmMachOp (MO_SS_Conv W64 W32) [x])
457	\| is32Bit = do
458	ChildCode64 code rlo <- iselExpr64 x
459	return $ Fixed II32 rlo code
460
461	getRegister' _ (CmmLit lit@(CmmFloat f w)) =
462	if_sse2 float_const_sse2 float_const_x87
463	where
464	float_const_sse2
465	\| f == 0.0 = do
466	let
467	size = floatSize w
468	code dst = unitOL (XOR size (OpReg dst) (OpReg dst))
469	-- I don't know why there are xorpd, xorps, and pxor instructions.
470	-- They all appear to do the same thing --SDM
471	return (Any size code)
472
473	\| otherwise = do
474	Amode addr code <- memConstant (widthInBytes w) lit
475	loadFloatAmode True w addr code
476
477	float_const_x87 = case w of
478	W64
479	\| f == 0.0 ->
480	let code dst = unitOL (GLDZ dst)
481	in return (Any FF80 code)
482
483	\| f == 1.0 ->
484	let code dst = unitOL (GLD1 dst)
485	in return (Any FF80 code)
486
487	_otherwise -> do
488	Amode addr code <- memConstant (widthInBytes w) lit
489	loadFloatAmode False w addr code
490
491	-- catch simple cases of zero- or sign-extended load
492	getRegister' _ (CmmMachOp (MO_UU_Conv W8 W32) [CmmLoad addr _]) = do
493	code <- intLoadCode (MOVZxL II8) addr
494	return (Any II32 code)
495
496	getRegister' _ (CmmMachOp (MO_SS_Conv W8 W32) [CmmLoad addr _]) = do
497	code <- intLoadCode (MOVSxL II8) addr
498	return (Any II32 code)
499
500	getRegister' _ (CmmMachOp (MO_UU_Conv W16 W32) [CmmLoad addr _]) = do
501	code <- intLoadCode (MOVZxL II16) addr
502	return (Any II32 code)
503
504	getRegister' _ (CmmMachOp (MO_SS_Conv W16 W32) [CmmLoad addr _]) = do
505	code <- intLoadCode (MOVSxL II16) addr
506	return (Any II32 code)
507
508	-- catch simple cases of zero- or sign-extended load
509	getRegister' is32Bit (CmmMachOp (MO_UU_Conv W8 W64) [CmmLoad addr _])
510	\| not is32Bit = do
511	code <- intLoadCode (MOVZxL II8) addr
512	return (Any II64 code)
513
514	getRegister' is32Bit (CmmMachOp (MO_SS_Conv W8 W64) [CmmLoad addr _])
515	\| not is32Bit = do
516	code <- intLoadCode (MOVSxL II8) addr
517	return (Any II64 code)
518
519	getRegister' is32Bit (CmmMachOp (MO_UU_Conv W16 W64) [CmmLoad addr _])
520	\| not is32Bit = do
521	code <- intLoadCode (MOVZxL II16) addr
522	return (Any II64 code)
523
524	getRegister' is32Bit (CmmMachOp (MO_SS_Conv W16 W64) [CmmLoad addr _])
525	\| not is32Bit = do
526	code <- intLoadCode (MOVSxL II16) addr
527	return (Any II64 code)
528
529	getRegister' is32Bit (CmmMachOp (MO_UU_Conv W32 W64) [CmmLoad addr _])
530	\| not is32Bit = do
531	code <- intLoadCode (MOV II32) addr -- 32-bit loads zero-extend
532	return (Any II64 code)
533
534	getRegister' is32Bit (CmmMachOp (MO_SS_Conv W32 W64) [CmmLoad addr _])
535	\| not is32Bit = do
536	code <- intLoadCode (MOVSxL II32) addr
537	return (Any II64 code)
538
539	getRegister' is32Bit (CmmMachOp (MO_Add W64) [CmmReg (CmmGlobal PicBaseReg),
540	CmmLit displacement])
541	\| not is32Bit = do
542	return $ Any II64 (\dst -> unitOL $
543	LEA II64 (OpAddr (ripRel (litToImm displacement))) (OpReg dst))
544
545	getRegister' is32Bit (CmmMachOp mop [x]) = do -- unary MachOps
546	sse2 <- sse2Enabled
547	case mop of
548	MO_F_Neg w
549	\| sse2 -> sse2NegCode w x
550	\| otherwise -> trivialUFCode FF80 (GNEG FF80) x
551
552	MO_S_Neg w -> triv_ucode NEGI (intSize w)
553	MO_Not w -> triv_ucode NOT (intSize w)
554
555	-- Nop conversions
556	MO_UU_Conv W32 W8 -> toI8Reg W32 x
557	MO_SS_Conv W32 W8 -> toI8Reg W32 x
558	MO_UU_Conv W16 W8 -> toI8Reg W16 x
559	MO_SS_Conv W16 W8 -> toI8Reg W16 x
560	MO_UU_Conv W32 W16 -> toI16Reg W32 x
561	MO_SS_Conv W32 W16 -> toI16Reg W32 x
562
563	MO_UU_Conv W64 W32 \| not is32Bit -> conversionNop II64 x
564	MO_SS_Conv W64 W32 \| not is32Bit -> conversionNop II64 x
565	MO_UU_Conv W64 W16 \| not is32Bit -> toI16Reg W64 x
566	MO_SS_Conv W64 W16 \| not is32Bit -> toI16Reg W64 x
567	MO_UU_Conv W64 W8 \| not is32Bit -> toI8Reg W64 x
568	MO_SS_Conv W64 W8 \| not is32Bit -> toI8Reg W64 x
569
570	MO_UU_Conv rep1 rep2 \| rep1 == rep2 -> conversionNop (intSize rep1) x
571	MO_SS_Conv rep1 rep2 \| rep1 == rep2 -> conversionNop (intSize rep1) x
572
573	-- widenings
574	MO_UU_Conv W8 W32 -> integerExtend W8 W32 MOVZxL x
575	MO_UU_Conv W16 W32 -> integerExtend W16 W32 MOVZxL x
576	MO_UU_Conv W8 W16 -> integerExtend W8 W16 MOVZxL x
577
578	MO_SS_Conv W8 W32 -> integerExtend W8 W32 MOVSxL x
579	MO_SS_Conv W16 W32 -> integerExtend W16 W32 MOVSxL x
580	MO_SS_Conv W8 W16 -> integerExtend W8 W16 MOVSxL x
581
582	MO_UU_Conv W8 W64 \| not is32Bit -> integerExtend W8 W64 MOVZxL x
583	MO_UU_Conv W16 W64 \| not is32Bit -> integerExtend W16 W64 MOVZxL x
584	MO_UU_Conv W32 W64 \| not is32Bit -> integerExtend W32 W64 MOVZxL x
585	MO_SS_Conv W8 W64 \| not is32Bit -> integerExtend W8 W64 MOVSxL x
586	MO_SS_Conv W16 W64 \| not is32Bit -> integerExtend W16 W64 MOVSxL x
587	MO_SS_Conv W32 W64 \| not is32Bit -> integerExtend W32 W64 MOVSxL x
588	-- for 32-to-64 bit zero extension, amd64 uses an ordinary movl.
589	-- However, we don't want the register allocator to throw it
590	-- away as an unnecessary reg-to-reg move, so we keep it in
591	-- the form of a movzl and print it as a movl later.
592
593	MO_FF_Conv W32 W64
594	\| sse2 -> coerceFP2FP W64 x
595	\| otherwise -> conversionNop FF80 x
596
597	MO_FF_Conv W64 W32 -> coerceFP2FP W32 x
598
599	MO_FS_Conv from to -> coerceFP2Int from to x
600	MO_SF_Conv from to -> coerceInt2FP from to x
601
602	_other -> pprPanic "getRegister" (pprMachOp mop)
603	where
604	triv_ucode :: (Size -> Operand -> Instr) -> Size -> NatM Register
605	triv_ucode instr size = trivialUCode size (instr size) x
606
607	-- signed or unsigned extension.
608	integerExtend :: Width -> Width
609	-> (Size -> Operand -> Operand -> Instr)
610	-> CmmExpr -> NatM Register
611	integerExtend from to instr expr = do
612	(reg,e_code) <- if from == W8 then getByteReg expr
613	else getSomeReg expr
614	let
615	code dst =
616	e_code `snocOL`
617	instr (intSize from) (OpReg reg) (OpReg dst)
618	return (Any (intSize to) code)
619
620	toI8Reg :: Width -> CmmExpr -> NatM Register
621	toI8Reg new_rep expr
622	= do codefn <- getAnyReg expr
623	return (Any (intSize new_rep) codefn)
624	-- HACK: use getAnyReg to get a byte-addressable register.
625	-- If the source was a Fixed register, this will add the
626	-- mov instruction to put it into the desired destination.
627	-- We're assuming that the destination won't be a fixed
628	-- non-byte-addressable register; it won't be, because all
629	-- fixed registers are word-sized.
630
631	toI16Reg = toI8Reg -- for now
632
633	conversionNop :: Size -> CmmExpr -> NatM Register
634	conversionNop new_size expr
635	= do e_code <- getRegister' is32Bit expr
636	return (swizzleRegisterRep e_code new_size)
637
638
639	getRegister' is32Bit (CmmMachOp mop [x, y]) = do -- dyadic MachOps
640	sse2 <- sse2Enabled
641	case mop of
642	MO_F_Eq _ -> condFltReg is32Bit EQQ x y
643	MO_F_Ne _ -> condFltReg is32Bit NE x y
644	MO_F_Gt _ -> condFltReg is32Bit GTT x y
645	MO_F_Ge _ -> condFltReg is32Bit GE x y
646	MO_F_Lt _ -> condFltReg is32Bit LTT x y
647	MO_F_Le _ -> condFltReg is32Bit LE x y
648
649	MO_Eq _ -> condIntReg EQQ x y
650	MO_Ne _ -> condIntReg NE x y
651
652	MO_S_Gt _ -> condIntReg GTT x y
653	MO_S_Ge _ -> condIntReg GE x y
654	MO_S_Lt _ -> condIntReg LTT x y
655	MO_S_Le _ -> condIntReg LE x y
656
657	MO_U_Gt _ -> condIntReg GU x y
658	MO_U_Ge _ -> condIntReg GEU x y
659	MO_U_Lt _ -> condIntReg LU x y
660	MO_U_Le _ -> condIntReg LEU x y
661
662	MO_F_Add w \| sse2 -> trivialFCode_sse2 w ADD x y
663	\| otherwise -> trivialFCode_x87 GADD x y
664	MO_F_Sub w \| sse2 -> trivialFCode_sse2 w SUB x y
665	\| otherwise -> trivialFCode_x87 GSUB x y
666	MO_F_Quot w \| sse2 -> trivialFCode_sse2 w FDIV x y
667	\| otherwise -> trivialFCode_x87 GDIV x y
668	MO_F_Mul w \| sse2 -> trivialFCode_sse2 w MUL x y
669	\| otherwise -> trivialFCode_x87 GMUL x y
670
671	MO_Add rep -> add_code rep x y
672	MO_Sub rep -> sub_code rep x y
673
674	MO_S_Quot rep -> div_code rep True True x y
675	MO_S_Rem rep -> div_code rep True False x y
676	MO_U_Quot rep -> div_code rep False True x y
677	MO_U_Rem rep -> div_code rep False False x y
678
679	MO_S_MulMayOflo rep -> imulMayOflo rep x y
680
681	MO_Mul rep -> triv_op rep IMUL
682	MO_And rep -> triv_op rep AND
683	MO_Or rep -> triv_op rep OR
684	MO_Xor rep -> triv_op rep XOR
685
686	{- Shift ops on x86s have constraints on their source, it
687	either has to be Imm, CL or 1
688	=> trivialCode is not restrictive enough (sigh.)
689	-}
690	MO_Shl rep -> shift_code rep SHL x y {-False-}
691	MO_U_Shr rep -> shift_code rep SHR x y {-False-}
692	MO_S_Shr rep -> shift_code rep SAR x y {-False-}
693
694	_other -> pprPanic "getRegister(x86) - binary CmmMachOp (1)" (pprMachOp mop)
695	where
696	--------------------
697	triv_op width instr = trivialCode width op (Just op) x y
698	where op = instr (intSize width)
699
700	imulMayOflo :: Width -> CmmExpr -> CmmExpr -> NatM Register
701	imulMayOflo rep a b = do
702	(a_reg, a_code) <- getNonClobberedReg a
703	b_code <- getAnyReg b
704	let
705	shift_amt = case rep of
706	W32 -> 31
707	W64 -> 63
708	_ -> panic "shift_amt"
709
710	size = intSize rep
711	code = a_code `appOL` b_code eax `appOL`
712	toOL [
713	IMUL2 size (OpReg a_reg), -- result in %edx:%eax
714	SAR size (OpImm (ImmInt shift_amt)) (OpReg eax),
715	-- sign extend lower part
716	SUB size (OpReg edx) (OpReg eax)
717	-- compare against upper
718	-- eax==0 if high part == sign extended low part
719	]
720	-- in
721	return (Fixed size eax code)
722
723	--------------------
724	shift_code :: Width
725	-> (Size -> Operand -> Operand -> Instr)
726	-> CmmExpr
727	-> CmmExpr
728	-> NatM Register
729
730	{- Case1: shift length as immediate -}
731	shift_code width instr x (CmmLit lit) = do
732	x_code <- getAnyReg x
733	let
734	size = intSize width
735	code dst
736	= x_code dst `snocOL`
737	instr size (OpImm (litToImm lit)) (OpReg dst)
738	-- in
739	return (Any size code)
740
741	{- Case2: shift length is complex (non-immediate)
742	* y must go in %ecx.
743	* we cannot do y first and put its result in %ecx, because
744	%ecx might be clobbered by x.
745	* if we do y second, then x cannot be
746	in a clobbered reg. Also, we cannot clobber x's reg
747	with the instruction itself.
748	* so we can either:
749	- do y first, put its result in a fresh tmp, then copy it to %ecx later
750	- do y second and put its result into %ecx. x gets placed in a fresh
751	tmp. This is likely to be better, becuase the reg alloc can
752	eliminate this reg->reg move here (it won't eliminate the other one,
753	because the move is into the fixed %ecx).
754	-}
755	shift_code width instr x y{-amount-} = do
756	x_code <- getAnyReg x
757	let size = intSize width
758	tmp <- getNewRegNat size
759	y_code <- getAnyReg y
760	let
761	code = x_code tmp `appOL`
762	y_code ecx `snocOL`
763	instr size (OpReg ecx) (OpReg tmp)
764	-- in
765	return (Fixed size tmp code)
766
767	--------------------
768	add_code :: Width -> CmmExpr -> CmmExpr -> NatM Register
769	add_code rep x (CmmLit (CmmInt y _))
770	\| is32BitInteger y = add_int rep x y
771	add_code rep x y = trivialCode rep (ADD size) (Just (ADD size)) x y
772	where size = intSize rep
773
774	--------------------
775	sub_code :: Width -> CmmExpr -> CmmExpr -> NatM Register
776	sub_code rep x (CmmLit (CmmInt y _))
777	\| is32BitInteger (-y) = add_int rep x (-y)
778	sub_code rep x y = trivialCode rep (SUB (intSize rep)) Nothing x y
779
780	-- our three-operand add instruction:
781	add_int width x y = do
782	(x_reg, x_code) <- getSomeReg x
783	let
784	size = intSize width
785	imm = ImmInt (fromInteger y)
786	code dst
787	= x_code `snocOL`
788	LEA size
789	(OpAddr (AddrBaseIndex (EABaseReg x_reg) EAIndexNone imm))
790	(OpReg dst)
791	--
792	return (Any size code)
793
794	----------------------
795	div_code width signed quotient x y = do
796	(y_op, y_code) <- getRegOrMem y -- cannot be clobbered
797	x_code <- getAnyReg x
798	let
799	size = intSize width
800	widen \| signed = CLTD size
801	\| otherwise = XOR size (OpReg edx) (OpReg edx)
802
803	instr \| signed = IDIV
804	\| otherwise = DIV
805
806	code = y_code `appOL`
807	x_code eax `appOL`
808	toOL [widen, instr size y_op]
809
810	result \| quotient = eax
811	\| otherwise = edx
812
813	-- in
814	return (Fixed size result code)
815
816
817	getRegister' _ (CmmLoad mem pk)
818	\| isFloatType pk
819	= do
820	Amode addr mem_code <- getAmode mem
821	use_sse2 <- sse2Enabled
822	loadFloatAmode use_sse2 (typeWidth pk) addr mem_code
823
824	getRegister' is32Bit (CmmLoad mem pk)
825	\| is32Bit && not (isWord64 pk)
826	= do
827	code <- intLoadCode instr mem
828	return (Any size code)
829	where
830	width = typeWidth pk
831	size = intSize width
832	instr = case width of
833	W8 -> MOVZxL II8
834	_other -> MOV size
835	-- We always zero-extend 8-bit loads, if we
836	-- can't think of anything better. This is because
837	-- we can't guarantee access to an 8-bit variant of every register
838	-- (esi and edi don't have 8-bit variants), so to make things
839	-- simpler we do our 8-bit arithmetic with full 32-bit registers.
840
841	-- Simpler memory load code on x86_64
842	getRegister' is32Bit (CmmLoad mem pk)
843	\| not is32Bit
844	= do
845	code <- intLoadCode (MOV size) mem
846	return (Any size code)
847	where size = intSize $ typeWidth pk
848
849	getRegister' is32Bit (CmmLit (CmmInt 0 width))
850	= let
851	size = intSize width
852
853	-- x86_64: 32-bit xor is one byte shorter, and zero-extends to 64 bits
854	size1 = if is32Bit then size
855	else case size of
856	II64 -> II32
857	_ -> size
858	code dst
859	= unitOL (XOR size1 (OpReg dst) (OpReg dst))
860	in
861	return (Any size code)
862
863	-- optimisation for loading small literals on x86_64: take advantage
864	-- of the automatic zero-extension from 32 to 64 bits, because the 32-bit
865	-- instruction forms are shorter.
866	getRegister' is32Bit (CmmLit lit)
867	\| not is32Bit, isWord64 (cmmLitType lit), not (isBigLit lit)
868	= let
869	imm = litToImm lit
870	code dst = unitOL (MOV II32 (OpImm imm) (OpReg dst))
871	in
872	return (Any II64 code)
873	where
874	isBigLit (CmmInt i _) = i < 0 \|\| i > 0xffffffff
875	isBigLit _ = False
876	-- note1: not the same as (not.is32BitLit), because that checks for
877	-- signed literals that fit in 32 bits, but we want unsigned
878	-- literals here.
879	-- note2: all labels are small, because we're assuming the
880	-- small memory model (see gcc docs, -mcmodel=small).
881
882	getRegister' _ (CmmLit lit)
883	= let
884	size = cmmTypeSize (cmmLitType lit)
885	imm = litToImm lit
886	code dst = unitOL (MOV size (OpImm imm) (OpReg dst))
887	in
888	return (Any size code)
889
890	getRegister' _ other = do dflags <- getDynFlags
891	pprPanic "getRegister(x86)" (pprPlatform (targetPlatform dflags) other)
892
893
894	intLoadCode :: (Operand -> Operand -> Instr) -> CmmExpr
895	-> NatM (Reg -> InstrBlock)
896	intLoadCode instr mem = do
897	Amode src mem_code <- getAmode mem
898	return (\dst -> mem_code `snocOL` instr (OpAddr src) (OpReg dst))
899
900	-- Compute an expression into any register, adding the appropriate
901	-- move instruction if necessary.
902	getAnyReg :: CmmExpr -> NatM (Reg -> InstrBlock)
903	getAnyReg expr = do
904	r <- getRegister expr
905	anyReg r
906
907	anyReg :: Register -> NatM (Reg -> InstrBlock)
908	anyReg (Any _ code) = return code
909	anyReg (Fixed rep reg fcode) = return (\dst -> fcode `snocOL` reg2reg rep reg dst)
910
911	-- A bit like getSomeReg, but we want a reg that can be byte-addressed.
912	-- Fixed registers might not be byte-addressable, so we make sure we've
913	-- got a temporary, inserting an extra reg copy if necessary.
914	getByteReg :: CmmExpr -> NatM (Reg, InstrBlock)
915	getByteReg expr = do
916	is32Bit <- is32BitPlatform
917	if is32Bit
918	then do r <- getRegister expr
919	case r of
920	Any rep code -> do
921	tmp <- getNewRegNat rep
922	return (tmp, code tmp)
923	Fixed rep reg code
924	\| isVirtualReg reg -> return (reg,code)
925	\| otherwise -> do
926	tmp <- getNewRegNat rep
927	return (tmp, code `snocOL` reg2reg rep reg tmp)
928	-- ToDo: could optimise slightly by checking for
929	-- byte-addressable real registers, but that will
930	-- happen very rarely if at all.
931	else getSomeReg expr -- all regs are byte-addressable on x86_64
932
933	-- Another variant: this time we want the result in a register that cannot
934	-- be modified by code to evaluate an arbitrary expression.
935	getNonClobberedReg :: CmmExpr -> NatM (Reg, InstrBlock)
936	getNonClobberedReg expr = do
937	r <- getRegister expr
938	case r of
939	Any rep code -> do
940	tmp <- getNewRegNat rep
941	return (tmp, code tmp)
942	Fixed rep reg code
943	-- only free regs can be clobbered
944	\| RegReal (RealRegSingle rr) <- reg
945	, isFastTrue (freeReg rr)
946	-> do
947	tmp <- getNewRegNat rep
948	return (tmp, code `snocOL` reg2reg rep reg tmp)
949	\| otherwise ->
950	return (reg, code)
951
952	reg2reg :: Size -> Reg -> Reg -> Instr
953	reg2reg size src dst
954	\| size == FF80 = GMOV src dst
955	\| otherwise = MOV size (OpReg src) (OpReg dst)
956
957
958	--------------------------------------------------------------------------------
959	getAmode :: CmmExpr -> NatM Amode
960	getAmode e = do is32Bit <- is32BitPlatform
961	getAmode' is32Bit e
962
963	getAmode' :: Bool -> CmmExpr -> NatM Amode
964	getAmode' _ (CmmRegOff r n) = getAmode $ mangleIndexTree r n
965
966	getAmode' is32Bit (CmmMachOp (MO_Add W64) [CmmReg (CmmGlobal PicBaseReg),
967	CmmLit displacement])
968	\| not is32Bit
969	= return $ Amode (ripRel (litToImm displacement)) nilOL
970
971
972	-- This is all just ridiculous, since it carefully undoes
973	-- what mangleIndexTree has just done.
974	getAmode' is32Bit (CmmMachOp (MO_Sub _rep) [x, CmmLit lit@(CmmInt i _)])
975	\| is32BitLit is32Bit lit
976	-- ASSERT(rep == II32)???
977	= do (x_reg, x_code) <- getSomeReg x
978	let off = ImmInt (-(fromInteger i))
979	return (Amode (AddrBaseIndex (EABaseReg x_reg) EAIndexNone off) x_code)
980
981	getAmode' is32Bit (CmmMachOp (MO_Add _rep) [x, CmmLit lit])
982	\| is32BitLit is32Bit lit
983	-- ASSERT(rep == II32)???
984	= do (x_reg, x_code) <- getSomeReg x
985	let off = litToImm lit
986	return (Amode (AddrBaseIndex (EABaseReg x_reg) EAIndexNone off) x_code)
987
988	-- Turn (lit1 << n + lit2) into (lit2 + lit1 << n) so it will be
989	-- recognised by the next rule.
990	getAmode' is32Bit (CmmMachOp (MO_Add rep) [a@(CmmMachOp (MO_Shl _) _),
991	b@(CmmLit _)])
992	= getAmode' is32Bit (CmmMachOp (MO_Add rep) [b,a])
993
994	getAmode' _ (CmmMachOp (MO_Add _) [x, CmmMachOp (MO_Shl _)
995	[y, CmmLit (CmmInt shift _)]])
996	\| shift == 0 \|\| shift == 1 \|\| shift == 2 \|\| shift == 3
997	= x86_complex_amode x y shift 0
998
999	getAmode' _ (CmmMachOp (MO_Add _)
1000	[x, CmmMachOp (MO_Add _)
1001	[CmmMachOp (MO_Shl _) [y, CmmLit (CmmInt shift _)],
1002	CmmLit (CmmInt offset _)]])
1003	\| shift == 0 \|\| shift == 1 \|\| shift == 2 \|\| shift == 3
1004	&& is32BitInteger offset
1005	= x86_complex_amode x y shift offset
1006
1007	getAmode' _ (CmmMachOp (MO_Add _) [x,y])
1008	= x86_complex_amode x y 0 0
1009
1010	getAmode' is32Bit (CmmLit lit) \| is32BitLit is32Bit lit
1011	= return (Amode (ImmAddr (litToImm lit) 0) nilOL)
1012
1013	getAmode' _ expr = do
1014	(reg,code) <- getSomeReg expr
1015	return (Amode (AddrBaseIndex (EABaseReg reg) EAIndexNone (ImmInt 0)) code)
1016
1017
1018	x86_complex_amode :: CmmExpr -> CmmExpr -> Integer -> Integer -> NatM Amode
1019	x86_complex_amode base index shift offset
1020	= do (x_reg, x_code) <- getNonClobberedReg base
1021	-- x must be in a temp, because it has to stay live over y_code
1022	-- we could compre x_reg and y_reg and do something better here...
1023	(y_reg, y_code) <- getSomeReg index
1024	let
1025	code = x_code `appOL` y_code
1026	base = case shift of 0 -> 1; 1 -> 2; 2 -> 4; 3 -> 8;
1027	n -> panic $ "x86_complex_amode: unhandled shift! (" ++ show n ++ ")"
1028	return (Amode (AddrBaseIndex (EABaseReg x_reg) (EAIndex y_reg base) (ImmInt (fromIntegral offset)))
1029	code)
1030
1031
1032
1033
1034	-- -----------------------------------------------------------------------------
1035	-- getOperand: sometimes any operand will do.
1036
1037	-- getNonClobberedOperand: the value of the operand will remain valid across
1038	-- the computation of an arbitrary expression, unless the expression
1039	-- is computed directly into a register which the operand refers to
1040	-- (see trivialCode where this function is used for an example).
1041
1042	getNonClobberedOperand :: CmmExpr -> NatM (Operand, InstrBlock)
1043	getNonClobberedOperand (CmmLit lit) = do
1044	use_sse2 <- sse2Enabled
1045	if use_sse2 && isSuitableFloatingPointLit lit
1046	then do
1047	let CmmFloat _ w = lit
1048	Amode addr code <- memConstant (widthInBytes w) lit
1049	return (OpAddr addr, code)
1050	else do
1051
1052	is32Bit <- is32BitPlatform
1053	if is32BitLit is32Bit lit && not (isFloatType (cmmLitType lit))
1054	then return (OpImm (litToImm lit), nilOL)
1055	else getNonClobberedOperand_generic (CmmLit lit)
1056
1057	getNonClobberedOperand (CmmLoad mem pk) = do
1058	is32Bit <- is32BitPlatform
1059	use_sse2 <- sse2Enabled
1060	if (not (isFloatType pk) \|\| use_sse2)
1061	&& (if is32Bit then not (isWord64 pk) else True)
1062	then do
1063	Amode src mem_code <- getAmode mem
1064	(src',save_code) <-
1065	if (amodeCouldBeClobbered src)
1066	then do
1067	tmp <- getNewRegNat (archWordSize is32Bit)
1068	return (AddrBaseIndex (EABaseReg tmp) EAIndexNone (ImmInt 0),
1069	unitOL (LEA (archWordSize is32Bit) (OpAddr src) (OpReg tmp)))
1070	else
1071	return (src, nilOL)
1072	return (OpAddr src', mem_code `appOL` save_code)
1073	else do
1074	getNonClobberedOperand_generic (CmmLoad mem pk)
1075
1076	getNonClobberedOperand e = getNonClobberedOperand_generic e
1077
1078	getNonClobberedOperand_generic :: CmmExpr -> NatM (Operand, InstrBlock)
1079	getNonClobberedOperand_generic e = do
1080	(reg, code) <- getNonClobberedReg e
1081	return (OpReg reg, code)
1082
1083	amodeCouldBeClobbered :: AddrMode -> Bool
1084	amodeCouldBeClobbered amode = any regClobbered (addrModeRegs amode)
1085
1086	regClobbered :: Reg -> Bool
1087	regClobbered (RegReal (RealRegSingle rr)) = isFastTrue (freeReg rr)
1088	regClobbered _ = False
1089
1090	-- getOperand: the operand is not required to remain valid across the
1091	-- computation of an arbitrary expression.
1092	getOperand :: CmmExpr -> NatM (Operand, InstrBlock)
1093
1094	getOperand (CmmLit lit) = do
1095	use_sse2 <- sse2Enabled
1096	if (use_sse2 && isSuitableFloatingPointLit lit)
1097	then do
1098	let CmmFloat _ w = lit
1099	Amode addr code <- memConstant (widthInBytes w) lit
1100	return (OpAddr addr, code)
1101	else do
1102
1103	is32Bit <- is32BitPlatform
1104	if is32BitLit is32Bit lit && not (isFloatType (cmmLitType lit))
1105	then return (OpImm (litToImm lit), nilOL)
1106	else getOperand_generic (CmmLit lit)
1107
1108	getOperand (CmmLoad mem pk) = do
1109	is32Bit <- is32BitPlatform
1110	use_sse2 <- sse2Enabled
1111	if (not (isFloatType pk) \|\| use_sse2) && (if is32Bit then not (isWord64 pk) else True)
1112	then do
1113	Amode src mem_code <- getAmode mem
1114	return (OpAddr src, mem_code)
1115	else
1116	getOperand_generic (CmmLoad mem pk)
1117
1118	getOperand e = getOperand_generic e
1119
1120	getOperand_generic :: CmmExpr -> NatM (Operand, InstrBlock)
1121	getOperand_generic e = do
1122	(reg, code) <- getSomeReg e
1123	return (OpReg reg, code)
1124
1125	isOperand :: Bool -> CmmExpr -> Bool
1126	isOperand _ (CmmLoad _ _) = True
1127	isOperand is32Bit (CmmLit lit) = is32BitLit is32Bit lit
1128	\|\| isSuitableFloatingPointLit lit
1129	isOperand _ _ = False
1130
1131	memConstant :: Int -> CmmLit -> NatM Amode
1132	memConstant align lit = do
1133	lbl <- getNewLabelNat
1134	dflags <- getDynFlags
1135	(addr, addr_code) <- if target32Bit (targetPlatform dflags)
1136	then do dynRef <- cmmMakeDynamicReference
1137	dflags
1138	addImportNat
1139	DataReference
1140	lbl
1141	Amode addr addr_code <- getAmode dynRef
1142	return (addr, addr_code)
1143	else return (ripRel (ImmCLbl lbl), nilOL)
1144	let code =
1145	LDATA ReadOnlyData (align, Statics lbl [CmmStaticLit lit])
1146	`consOL` addr_code
1147	return (Amode addr code)
1148
1149
1150	loadFloatAmode :: Bool -> Width -> AddrMode -> InstrBlock -> NatM Register
1151	loadFloatAmode use_sse2 w addr addr_code = do
1152	let size = floatSize w
1153	code dst = addr_code `snocOL`
1154	if use_sse2
1155	then MOV size (OpAddr addr) (OpReg dst)
1156	else GLD size addr dst
1157	-- in
1158	return (Any (if use_sse2 then size else FF80) code)
1159
1160
1161	-- if we want a floating-point literal as an operand, we can
1162	-- use it directly from memory. However, if the literal is
1163	-- zero, we're better off generating it into a register using
1164	-- xor.
1165	isSuitableFloatingPointLit :: CmmLit -> Bool
1166	isSuitableFloatingPointLit (CmmFloat f _) = f /= 0.0
1167	isSuitableFloatingPointLit _ = False
1168
1169	getRegOrMem :: CmmExpr -> NatM (Operand, InstrBlock)
1170	getRegOrMem e@(CmmLoad mem pk) = do
1171	is32Bit <- is32BitPlatform
1172	use_sse2 <- sse2Enabled
1173	if (not (isFloatType pk) \|\| use_sse2) && (if is32Bit then not (isWord64 pk) else True)
1174	then do
1175	Amode src mem_code <- getAmode mem
1176	return (OpAddr src, mem_code)
1177	else do
1178	(reg, code) <- getNonClobberedReg e
1179	return (OpReg reg, code)
1180	getRegOrMem e = do
1181	(reg, code) <- getNonClobberedReg e
1182	return (OpReg reg, code)
1183
1184	is32BitLit :: Bool -> CmmLit -> Bool
1185	is32BitLit is32Bit (CmmInt i W64)
1186	\| not is32Bit
1187	= -- assume that labels are in the range 0-2^31-1: this assumes the
1188	-- small memory model (see gcc docs, -mcmodel=small).
1189	is32BitInteger i
1190	is32BitLit _ _ = True
1191
1192
1193
1194
1195	-- Set up a condition code for a conditional branch.
1196
1197	getCondCode :: CmmExpr -> NatM CondCode
1198
1199	-- yes, they really do seem to want exactly the same!
1200
1201	getCondCode (CmmMachOp mop [x, y])
1202	=
1203	case mop of
1204	MO_F_Eq W32 -> condFltCode EQQ x y
1205	MO_F_Ne W32 -> condFltCode NE x y
1206	MO_F_Gt W32 -> condFltCode GTT x y
1207	MO_F_Ge W32 -> condFltCode GE x y
1208	MO_F_Lt W32 -> condFltCode LTT x y
1209	MO_F_Le W32 -> condFltCode LE x y
1210
1211	MO_F_Eq W64 -> condFltCode EQQ x y
1212	MO_F_Ne W64 -> condFltCode NE x y
1213	MO_F_Gt W64 -> condFltCode GTT x y
1214	MO_F_Ge W64 -> condFltCode GE x y
1215	MO_F_Lt W64 -> condFltCode LTT x y
1216	MO_F_Le W64 -> condFltCode LE x y
1217
1218	MO_Eq _ -> condIntCode EQQ x y
1219	MO_Ne _ -> condIntCode NE x y
1220
1221	MO_S_Gt _ -> condIntCode GTT x y
1222	MO_S_Ge _ -> condIntCode GE x y
1223	MO_S_Lt _ -> condIntCode LTT x y
1224	MO_S_Le _ -> condIntCode LE x y
1225
1226	MO_U_Gt _ -> condIntCode GU x y
1227	MO_U_Ge _ -> condIntCode GEU x y
1228	MO_U_Lt _ -> condIntCode LU x y
1229	MO_U_Le _ -> condIntCode LEU x y
1230
1231	_other -> do dflags <- getDynFlags
1232	pprPanic "getCondCode(x86,x86_64,sparc)" (pprPlatform (targetPlatform dflags) (CmmMachOp mop [x,y]))
1233
1234	getCondCode other = do dflags <- getDynFlags
1235	pprPanic "getCondCode(2)(x86,sparc)" (pprPlatform (targetPlatform dflags) other)
1236
1237
1238
1239
1240	-- @cond(Int\|Flt)Code@: Turn a boolean expression into a condition, to be
1241	-- passed back up the tree.
1242
1243	condIntCode :: Cond -> CmmExpr -> CmmExpr -> NatM CondCode
1244	condIntCode cond x y = do is32Bit <- is32BitPlatform
1245	condIntCode' is32Bit cond x y
1246
1247	condIntCode' :: Bool -> Cond -> CmmExpr -> CmmExpr -> NatM CondCode
1248
1249	-- memory vs immediate
1250	condIntCode' is32Bit cond (CmmLoad x pk) (CmmLit lit)
1251	\| is32BitLit is32Bit lit = do
1252	Amode x_addr x_code <- getAmode x
1253	let
1254	imm = litToImm lit
1255	code = x_code `snocOL`
1256	CMP (cmmTypeSize pk) (OpImm imm) (OpAddr x_addr)
1257	--
1258	return (CondCode False cond code)
1259
1260	-- anything vs zero, using a mask
1261	-- TODO: Add some sanity checking!!!!
1262	condIntCode' is32Bit cond (CmmMachOp (MO_And _) [x,o2]) (CmmLit (CmmInt 0 pk))
1263	\| (CmmLit lit@(CmmInt mask _)) <- o2, is32BitLit is32Bit lit
1264	= do
1265	(x_reg, x_code) <- getSomeReg x
1266	let
1267	code = x_code `snocOL`
1268	TEST (intSize pk) (OpImm (ImmInteger mask)) (OpReg x_reg)
1269	--
1270	return (CondCode False cond code)
1271
1272	-- anything vs zero
1273	condIntCode' _ cond x (CmmLit (CmmInt 0 pk)) = do
1274	(x_reg, x_code) <- getSomeReg x
1275	let
1276	code = x_code `snocOL`
1277	TEST (intSize pk) (OpReg x_reg) (OpReg x_reg)
1278	--
1279	return (CondCode False cond code)
1280
1281	-- anything vs operand
1282	condIntCode' is32Bit cond x y \| isOperand is32Bit y = do
1283	(x_reg, x_code) <- getNonClobberedReg x
1284	(y_op, y_code) <- getOperand y
1285	let
1286	code = x_code `appOL` y_code `snocOL`
1287	CMP (cmmTypeSize (cmmExprType x)) y_op (OpReg x_reg)
1288	-- in
1289	return (CondCode False cond code)
1290
1291	-- anything vs anything
1292	condIntCode' _ cond x y = do
1293	(y_reg, y_code) <- getNonClobberedReg y
1294	(x_op, x_code) <- getRegOrMem x
1295	let
1296	code = y_code `appOL`
1297	x_code `snocOL`
1298	CMP (cmmTypeSize (cmmExprType x)) (OpReg y_reg) x_op
1299	-- in
1300	return (CondCode False cond code)
1301
1302
1303
1304	--------------------------------------------------------------------------------
1305	condFltCode :: Cond -> CmmExpr -> CmmExpr -> NatM CondCode
1306
1307	condFltCode cond x y
1308	= if_sse2 condFltCode_sse2 condFltCode_x87
1309	where
1310
1311	condFltCode_x87
1312	= ASSERT(cond `elem` ([EQQ, NE, LE, LTT, GE, GTT])) do
1313	(x_reg, x_code) <- getNonClobberedReg x
1314	(y_reg, y_code) <- getSomeReg y
1315	let
1316	code = x_code `appOL` y_code `snocOL`
1317	GCMP cond x_reg y_reg
1318	-- The GCMP insn does the test and sets the zero flag if comparable
1319	-- and true. Hence we always supply EQQ as the condition to test.
1320	return (CondCode True EQQ code)
1321
1322	-- in the SSE2 comparison ops (ucomiss, ucomisd) the left arg may be
1323	-- an operand, but the right must be a reg. We can probably do better
1324	-- than this general case...
1325	condFltCode_sse2 = do
1326	(x_reg, x_code) <- getNonClobberedReg x
1327	(y_op, y_code) <- getOperand y
1328	let
1329	code = x_code `appOL`
1330	y_code `snocOL`
1331	CMP (floatSize $ cmmExprWidth x) y_op (OpReg x_reg)
1332	-- NB(1): we need to use the unsigned comparison operators on the
1333	-- result of this comparison.
1334	-- in
1335	return (CondCode True (condToUnsigned cond) code)
1336
1337	-- -----------------------------------------------------------------------------
1338	-- Generating assignments
1339
1340	-- Assignments are really at the heart of the whole code generation
1341	-- business. Almost all top-level nodes of any real importance are
1342	-- assignments, which correspond to loads, stores, or register
1343	-- transfers. If we're really lucky, some of the register transfers
1344	-- will go away, because we can use the destination register to
1345	-- complete the code generation for the right hand side. This only
1346	-- fails when the right hand side is forced into a fixed register
1347	-- (e.g. the result of a call).
1348
1349	assignMem_IntCode :: Size -> CmmExpr -> CmmExpr -> NatM InstrBlock
1350	assignReg_IntCode :: Size -> CmmReg -> CmmExpr -> NatM InstrBlock
1351
1352	assignMem_FltCode :: Size -> CmmExpr -> CmmExpr -> NatM InstrBlock
1353	assignReg_FltCode :: Size -> CmmReg -> CmmExpr -> NatM InstrBlock
1354
1355
1356	-- integer assignment to memory
1357
1358	-- specific case of adding/subtracting an integer to a particular address.
1359	-- ToDo: catch other cases where we can use an operation directly on a memory
1360	-- address.
1361	assignMem_IntCode pk addr (CmmMachOp op [CmmLoad addr2 _,
1362	CmmLit (CmmInt i _)])
1363	\| addr == addr2, pk /= II64 \|\| is32BitInteger i,
1364	Just instr <- check op
1365	= do Amode amode code_addr <- getAmode addr
1366	let code = code_addr `snocOL`
1367	instr pk (OpImm (ImmInt (fromIntegral i))) (OpAddr amode)
1368	return code
1369	where
1370	check (MO_Add _) = Just ADD
1371	check (MO_Sub _) = Just SUB
1372	check _ = Nothing
1373	-- ToDo: more?
1374
1375	-- general case
1376	assignMem_IntCode pk addr src = do
1377	is32Bit <- is32BitPlatform
1378	Amode addr code_addr <- getAmode addr
1379	(code_src, op_src) <- get_op_RI is32Bit src
1380	let
1381	code = code_src `appOL`
1382	code_addr `snocOL`
1383	MOV pk op_src (OpAddr addr)
1384	-- NOTE: op_src is stable, so it will still be valid
1385	-- after code_addr. This may involve the introduction
1386	-- of an extra MOV to a temporary register, but we hope
1387	-- the register allocator will get rid of it.
1388	--
1389	return code
1390	where
1391	get_op_RI :: Bool -> CmmExpr -> NatM (InstrBlock,Operand) -- code, operator
1392	get_op_RI is32Bit (CmmLit lit) \| is32BitLit is32Bit lit
1393	= return (nilOL, OpImm (litToImm lit))
1394	get_op_RI _ op
1395	= do (reg,code) <- getNonClobberedReg op
1396	return (code, OpReg reg)
1397
1398
1399	-- Assign; dst is a reg, rhs is mem
1400	assignReg_IntCode pk reg (CmmLoad src _) = do
1401	load_code <- intLoadCode (MOV pk) src
1402	return (load_code (getRegisterReg False{-no sse2-} reg))
1403
1404	-- dst is a reg, but src could be anything
1405	assignReg_IntCode _ reg src = do
1406	code <- getAnyReg src
1407	return (code (getRegisterReg False{-no sse2-} reg))
1408
1409
1410	-- Floating point assignment to memory
1411	assignMem_FltCode pk addr src = do
1412	(src_reg, src_code) <- getNonClobberedReg src
1413	Amode addr addr_code <- getAmode addr
1414	use_sse2 <- sse2Enabled
1415	let
1416	code = src_code `appOL`
1417	addr_code `snocOL`
1418	if use_sse2 then MOV pk (OpReg src_reg) (OpAddr addr)
1419	else GST pk src_reg addr
1420	return code
1421
1422	-- Floating point assignment to a register/temporary
1423	assignReg_FltCode _ reg src = do
1424	use_sse2 <- sse2Enabled
1425	src_code <- getAnyReg src
1426	return (src_code (getRegisterReg use_sse2 reg))
1427
1428
1429	genJump :: CmmExpr{-the branch target-} -> NatM InstrBlock
1430
1431	genJump (CmmLoad mem _) = do
1432	Amode target code <- getAmode mem
1433	return (code `snocOL` JMP (OpAddr target))
1434
1435	genJump (CmmLit lit) = do
1436	return (unitOL (JMP (OpImm (litToImm lit))))
1437
1438	genJump expr = do
1439	(reg,code) <- getSomeReg expr
1440	return (code `snocOL` JMP (OpReg reg))
1441
1442
1443	-- -----------------------------------------------------------------------------
1444	-- Unconditional branches
1445
1446	genBranch :: BlockId -> NatM InstrBlock
1447	genBranch = return . toOL . mkJumpInstr
1448
1449
1450
1451	-- -----------------------------------------------------------------------------
1452	-- Conditional jumps
1453
1454	{-
1455	Conditional jumps are always to local labels, so we can use branch
1456	instructions. We peek at the arguments to decide what kind of
1457	comparison to do.
1458
1459	I386: First, we have to ensure that the condition
1460	codes are set according to the supplied comparison operation.
1461	-}
1462
1463	genCondJump
1464	:: BlockId -- the branch target
1465	-> CmmExpr -- the condition on which to branch
1466	-> NatM InstrBlock
1467
1468	genCondJump id bool = do
1469	CondCode is_float cond cond_code <- getCondCode bool
1470	use_sse2 <- sse2Enabled
1471	if not is_float \|\| not use_sse2
1472	then
1473	return (cond_code `snocOL` JXX cond id)
1474	else do
1475	lbl <- getBlockIdNat
1476
1477	-- see comment with condFltReg
1478	let code = case cond of
1479	NE -> or_unordered
1480	GU -> plain_test
1481	GEU -> plain_test
1482	_ -> and_ordered
1483
1484	plain_test = unitOL (
1485	JXX cond id
1486	)
1487	or_unordered = toOL [
1488	JXX cond id,
1489	JXX PARITY id
1490	]
1491	and_ordered = toOL [
1492	JXX PARITY lbl,
1493	JXX cond id,
1494	JXX ALWAYS lbl,
1495	NEWBLOCK lbl
1496	]
1497	return (cond_code `appOL` code)
1498
1499
1500	-- -----------------------------------------------------------------------------
1501	-- Generating C calls
1502
1503	-- Now the biggest nightmare---calls. Most of the nastiness is buried in
1504	-- @get_arg@, which moves the arguments to the correct registers/stack
1505	-- locations. Apart from that, the code is easy.
1506	--
1507	-- (If applicable) Do not fill the delay slots here; you will confuse the
1508	-- register allocator.
1509
1510	genCCall
1511	:: Bool -- 32 bit platform?
1512	-> CmmCallTarget -- function to call
1513	-> [HintedCmmFormal] -- where to put the result
1514	-> [HintedCmmActual] -- arguments (of mixed type)
1515	-> NatM InstrBlock
1516
1517	-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1518
1519	-- Unroll memcpy calls if the source and destination pointers are at
1520	-- least DWORD aligned and the number of bytes to copy isn't too
1521	-- large. Otherwise, call C's memcpy.
1522	genCCall is32Bit (CmmPrim MO_Memcpy _) _
1523	[CmmHinted dst _, CmmHinted src _,
1524	CmmHinted (CmmLit (CmmInt n _)) _,
1525	CmmHinted (CmmLit (CmmInt align _)) _]
1526	\| n <= maxInlineSizeThreshold && align .&. 3 == 0 = do
1527	code_dst <- getAnyReg dst
1528	dst_r <- getNewRegNat size
1529	code_src <- getAnyReg src
1530	src_r <- getNewRegNat size
1531	tmp_r <- getNewRegNat size
1532	return $ code_dst dst_r `appOL` code_src src_r `appOL`
1533	go dst_r src_r tmp_r n
1534	where
1535	size = if align .&. 4 /= 0 then II32 else (archWordSize is32Bit)
1536
1537	sizeBytes = fromIntegral (sizeInBytes size)
1538
1539	go :: Reg -> Reg -> Reg -> Integer -> OrdList Instr
1540	go dst src tmp i
1541	\| i >= sizeBytes =
1542	unitOL (MOV size (OpAddr src_addr) (OpReg tmp)) `appOL`
1543	unitOL (MOV size (OpReg tmp) (OpAddr dst_addr)) `appOL`
1544	go dst src tmp (i - sizeBytes)
1545	-- Deal with remaining bytes.
1546	\| i >= 4 = -- Will never happen on 32-bit
1547	unitOL (MOV II32 (OpAddr src_addr) (OpReg tmp)) `appOL`
1548	unitOL (MOV II32 (OpReg tmp) (OpAddr dst_addr)) `appOL`
1549	go dst src tmp (i - 4)
1550	\| i >= 2 =
1551	unitOL (MOVZxL II16 (OpAddr src_addr) (OpReg tmp)) `appOL`
1552	unitOL (MOV II16 (OpReg tmp) (OpAddr dst_addr)) `appOL`
1553	go dst src tmp (i - 2)
1554	\| i >= 1 =
1555	unitOL (MOVZxL II8 (OpAddr src_addr) (OpReg tmp)) `appOL`
1556	unitOL (MOV II8 (OpReg tmp) (OpAddr dst_addr)) `appOL`
1557	go dst src tmp (i - 1)
1558	\| otherwise = nilOL
1559	where
1560	src_addr = AddrBaseIndex (EABaseReg src) EAIndexNone
1561	(ImmInteger (n - i))
1562	dst_addr = AddrBaseIndex (EABaseReg dst) EAIndexNone
1563	(ImmInteger (n - i))
1564
1565	genCCall _ (CmmPrim MO_Memset _) _
1566	[CmmHinted dst _,
1567	CmmHinted (CmmLit (CmmInt c _)) _,
1568	CmmHinted (CmmLit (CmmInt n _)) _,
1569	CmmHinted (CmmLit (CmmInt align _)) _]
1570	\| n <= maxInlineSizeThreshold && align .&. 3 == 0 = do
1571	code_dst <- getAnyReg dst
1572	dst_r <- getNewRegNat size
1573	return $ code_dst dst_r `appOL` go dst_r n
1574	where
1575	(size, val) = case align .&. 3 of
1576	2 -> (II16, c2)
1577	0 -> (II32, c4)
1578	_ -> (II8, c)
1579	c2 = c `shiftL` 8 .\|. c
1580	c4 = c2 `shiftL` 16 .\|. c2
1581
1582	sizeBytes = fromIntegral (sizeInBytes size)
1583
1584	go :: Reg -> Integer -> OrdList Instr
1585	go dst i
1586	-- TODO: Add movabs instruction and support 64-bit sets.
1587	\| i >= sizeBytes = -- This might be smaller than the below sizes
1588	unitOL (MOV size (OpImm (ImmInteger val)) (OpAddr dst_addr)) `appOL`
1589	go dst (i - sizeBytes)
1590	\| i >= 4 = -- Will never happen on 32-bit
1591	unitOL (MOV II32 (OpImm (ImmInteger c4)) (OpAddr dst_addr)) `appOL`
1592	go dst (i - 4)
1593	\| i >= 2 =
1594	unitOL (MOV II16 (OpImm (ImmInteger c2)) (OpAddr dst_addr)) `appOL`
1595	go dst (i - 2)
1596	\| i >= 1 =
1597	unitOL (MOV II8 (OpImm (ImmInteger c)) (OpAddr dst_addr)) `appOL`
1598	go dst (i - 1)
1599	\| otherwise = nilOL
1600	where
1601	dst_addr = AddrBaseIndex (EABaseReg dst) EAIndexNone
1602	(ImmInteger (n - i))
1603
1604	genCCall _ (CmmPrim MO_WriteBarrier _) _ _ = return nilOL
1605	-- write barrier compiles to no code on x86/x86-64;
1606	-- we keep it this long in order to prevent earlier optimisations.
1607
1608	genCCall is32Bit (CmmPrim (MO_PopCnt width) _) dest_regs@[CmmHinted dst _]
1609	args@[CmmHinted src _] = do
1610	sse4_2 <- sse4_2Enabled
1611	if sse4_2
1612	then do code_src <- getAnyReg src
1613	src_r <- getNewRegNat size
1614	return $ code_src src_r `appOL`
1615	(if width == W8 then
1616	-- The POPCNT instruction doesn't take a r/m8
1617	unitOL (MOVZxL II8 (OpReg src_r) (OpReg src_r)) `appOL`
1618	unitOL (POPCNT II16 (OpReg src_r)
1619	(getRegisterReg False (CmmLocal dst)))
1620	else
1621	unitOL (POPCNT size (OpReg src_r)
1622	(getRegisterReg False (CmmLocal dst))))
1623	else do
1624	dflags <- getDynFlags
1625	targetExpr <- cmmMakeDynamicReference dflags addImportNat
1626	CallReference lbl
1627	let target = CmmCallee targetExpr CCallConv
1628	genCCall is32Bit target dest_regs args
1629	where
1630	size = intSize width
1631	lbl = mkCmmCodeLabel primPackageId (fsLit (popCntLabel width))
1632
1633	genCCall is32Bit target dest_regs args
1634	\| is32Bit = genCCall32 target dest_regs args
1635	\| otherwise = genCCall64 target dest_regs args
1636
1637	genCCall32 :: CmmCallTarget -- function to call
1638	-> [HintedCmmFormal] -- where to put the result
1639	-> [HintedCmmActual] -- arguments (of mixed type)
1640	-> NatM InstrBlock
1641	genCCall32 target dest_regs args =
1642	case (target, dest_regs) of
1643	-- void return type prim op
1644	(CmmPrim op _, []) ->
1645	outOfLineCmmOp op Nothing args
1646	-- we only cope with a single result for foreign calls
1647	(CmmPrim op _, [r_hinted@(CmmHinted r _)]) -> do
1648	l1 <- getNewLabelNat
1649	l2 <- getNewLabelNat
1650	sse2 <- sse2Enabled
1651	if sse2
1652	then
1653	outOfLineCmmOp op (Just r_hinted) args
1654	else case op of
1655	MO_F32_Sqrt -> actuallyInlineFloatOp GSQRT FF32 args
1656	MO_F64_Sqrt -> actuallyInlineFloatOp GSQRT FF64 args
1657
1658	MO_F32_Sin -> actuallyInlineFloatOp (\s -> GSIN s l1 l2) FF32 args
1659	MO_F64_Sin -> actuallyInlineFloatOp (\s -> GSIN s l1 l2) FF64 args
1660
1661	MO_F32_Cos -> actuallyInlineFloatOp (\s -> GCOS s l1 l2) FF32 args
1662	MO_F64_Cos -> actuallyInlineFloatOp (\s -> GCOS s l1 l2) FF64 args
1663
1664	MO_F32_Tan -> actuallyInlineFloatOp (\s -> GTAN s l1 l2) FF32 args
1665	MO_F64_Tan -> actuallyInlineFloatOp (\s -> GTAN s l1 l2) FF64 args
1666
1667	_other_op -> outOfLineCmmOp op (Just r_hinted) args
1668
1669	where
1670	actuallyInlineFloatOp instr size [CmmHinted x _]
1671	= do res <- trivialUFCode size (instr size) x
1672	any <- anyReg res
1673	return (any (getRegisterReg False (CmmLocal r)))
1674
1675	actuallyInlineFloatOp _ _ args
1676	= panic $ "genCCall32.actuallyInlineFloatOp: bad number of arguments! ("
1677	++ show (length args) ++ ")"
1678
1679	(CmmPrim (MO_S_QuotRem width) _, _) -> divOp1 True width dest_regs args
1680	(CmmPrim (MO_U_QuotRem width) _, _) -> divOp1 False width dest_regs args
1681	(CmmPrim (MO_U_QuotRem2 width) _, _) -> divOp2 False width dest_regs args
1682	(CmmPrim (MO_Add2 width) _, [CmmHinted res_h _, CmmHinted res_l _]) ->
1683	case args of
1684	[CmmHinted arg_x _, CmmHinted arg_y _] ->
1685	do hCode <- getAnyReg (CmmLit (CmmInt 0 width))
1686	lCode <- getAnyReg (CmmMachOp (MO_Add width) [arg_x, arg_y])
1687	let size = intSize width
1688	reg_l = getRegisterReg True (CmmLocal res_l)
1689	reg_h = getRegisterReg True (CmmLocal res_h)
1690	code = hCode reg_h `appOL`
1691	lCode reg_l `snocOL`
1692	ADC size (OpImm (ImmInteger 0)) (OpReg reg_h)
1693	return code
1694	_ -> panic "genCCall32: Wrong number of arguments/results for add2"
1695	(CmmPrim (MO_U_Mul2 width) _, [CmmHinted res_h _, CmmHinted res_l _]) ->
1696	case args of
1697	[CmmHinted arg_x _, CmmHinted arg_y _] ->
1698	do (y_reg, y_code) <- getRegOrMem arg_y
1699	x_code <- getAnyReg arg_x
1700	let size = intSize width
1701	reg_h = getRegisterReg True (CmmLocal res_h)
1702	reg_l = getRegisterReg True (CmmLocal res_l)
1703	code = y_code `appOL`
1704	x_code rax `appOL`
1705	toOL [MUL2 size y_reg,
1706	MOV size (OpReg rdx) (OpReg reg_h),
1707	MOV size (OpReg rax) (OpReg reg_l)]
1708	return code
1709	_ -> panic "genCCall32: Wrong number of arguments/results for add2"
1710
1711	(CmmPrim _ (Just stmts), _) ->
1712	stmtsToInstrs stmts
1713
1714	_ -> genCCall32' target dest_regs args
1715
1716	where divOp1 signed width results [CmmHinted arg_x _, CmmHinted arg_y _]
1717	= divOp signed width results Nothing arg_x arg_y
1718	divOp1 _ _ _ _
1719	= panic "genCCall32: Wrong number of arguments for divOp1"
1720	divOp2 signed width results [CmmHinted arg_x_high _,
1721	CmmHinted arg_x_low _,
1722	CmmHinted arg_y _]
1723	= divOp signed width results (Just arg_x_high) arg_x_low arg_y
1724	divOp2 _ _ _ _
1725	= panic "genCCall64: Wrong number of arguments for divOp2"
1726	divOp signed width [CmmHinted res_q _, CmmHinted res_r _]
1727	m_arg_x_high arg_x_low arg_y
1728	= do let size = intSize width
1729	reg_q = getRegisterReg True (CmmLocal res_q)
1730	reg_r = getRegisterReg True (CmmLocal res_r)
1731	widen \| signed = CLTD size
1732	\| otherwise = XOR size (OpReg rdx) (OpReg rdx)
1733	instr \| signed = IDIV
1734	\| otherwise = DIV
1735	(y_reg, y_code) <- getRegOrMem arg_y
1736	x_low_code <- getAnyReg arg_x_low
1737	x_high_code <- case m_arg_x_high of
1738	Just arg_x_high ->
1739	getAnyReg arg_x_high
1740	Nothing ->
1741	return $ const $ unitOL widen
1742	return $ y_code `appOL`
1743	x_low_code rax `appOL`
1744	x_high_code rdx `appOL`
1745	toOL [instr size y_reg,
1746	MOV size (OpReg rax) (OpReg reg_q),
1747	MOV size (OpReg rdx) (OpReg reg_r)]
1748	divOp _ _ _ _ _ _
1749	= panic "genCCall32: Wrong number of results for divOp"
1750
1751	genCCall32' :: CmmCallTarget -- function to call
1752	-> [HintedCmmFormal] -- where to put the result
1753	-> [HintedCmmActual] -- arguments (of mixed type)
1754	-> NatM InstrBlock
1755	genCCall32' target dest_regs args = do
1756	let
1757	-- Align stack to 16n for calls, assuming a starting stack
1758	-- alignment of 16n - word_size on procedure entry. Which we
1759	-- maintiain. See Note [rts/StgCRun.c : Stack Alignment on X86]
1760	sizes = map (arg_size . cmmExprType . hintlessCmm) (reverse args)
1761	raw_arg_size = sum sizes + wORD_SIZE
1762	arg_pad_size = (roundTo 16 $ raw_arg_size) - raw_arg_size
1763	tot_arg_size = raw_arg_size + arg_pad_size - wORD_SIZE
1764	delta0 <- getDeltaNat
1765	setDeltaNat (delta0 - arg_pad_size)
1766
1767	use_sse2 <- sse2Enabled
1768	push_codes <- mapM (push_arg use_sse2) (reverse args)
1769	delta <- getDeltaNat
1770	MASSERT (delta == delta0 - tot_arg_size)
1771
1772	-- in
1773	-- deal with static vs dynamic call targets
1774	(callinsns,cconv) <-
1775	case target of
1776	CmmCallee (CmmLit (CmmLabel lbl)) conv
1777	-> -- ToDo: stdcall arg sizes
1778	return (unitOL (CALL (Left fn_imm) []), conv)
1779	where fn_imm = ImmCLbl lbl
1780	CmmCallee expr conv
1781	-> do { (dyn_r, dyn_c) <- getSomeReg expr
1782	; ASSERT( isWord32 (cmmExprType expr) )
1783	return (dyn_c `snocOL` CALL (Right dyn_r) [], conv) }
1784	CmmPrim _ _
1785	-> panic $ "genCCall: Can't handle CmmPrim call type here, error "
1786	++ "probably because too many return values."
1787
1788	let push_code
1789	\| arg_pad_size /= 0
1790	= toOL [SUB II32 (OpImm (ImmInt arg_pad_size)) (OpReg esp),
1791	DELTA (delta0 - arg_pad_size)]
1792	`appOL` concatOL push_codes
1793	\| otherwise
1794	= concatOL push_codes
1795
1796	-- Deallocate parameters after call for ccall;
1797	-- but not for stdcall (callee does it)
1798	--
1799	-- We have to pop any stack padding we added
1800	-- even if we are doing stdcall, though (#5052)
1801	pop_size \| cconv /= StdCallConv = tot_arg_size
1802	\| otherwise = arg_pad_size
1803
1804	call = callinsns `appOL`
1805	toOL (
1806	(if pop_size==0 then [] else
1807	[ADD II32 (OpImm (ImmInt pop_size)) (OpReg esp)])
1808	++
1809	[DELTA delta0]
1810	)
1811	-- in
1812	setDeltaNat delta0
1813
1814	let
1815	-- assign the results, if necessary
1816	assign_code [] = nilOL
1817	assign_code [CmmHinted dest _hint]
1818	\| isFloatType ty =
1819	if use_sse2
1820	then let tmp_amode = AddrBaseIndex (EABaseReg esp)
1821	EAIndexNone
1822	(ImmInt 0)
1823	sz = floatSize w
1824	in toOL [ SUB II32 (OpImm (ImmInt b)) (OpReg esp),
1825	DELTA (delta0 - b),
1826	GST sz fake0 tmp_amode,
1827	MOV sz (OpAddr tmp_amode) (OpReg r_dest),
1828	ADD II32 (OpImm (ImmInt b)) (OpReg esp),
1829	DELTA delta0]
1830	else unitOL (GMOV fake0 r_dest)
1831	\| isWord64 ty = toOL [MOV II32 (OpReg eax) (OpReg r_dest),
1832	MOV II32 (OpReg edx) (OpReg r_dest_hi)]
1833	\| otherwise = unitOL (MOV (intSize w) (OpReg eax) (OpReg r_dest))
1834	where
1835	ty = localRegType dest
1836	w = typeWidth ty
1837	b = widthInBytes w
1838	r_dest_hi = getHiVRegFromLo r_dest
1839	r_dest = getRegisterReg use_sse2 (CmmLocal dest)
1840	assign_code many = pprPanic "genCCall.assign_code - too many return values:" (ppr many)
1841
1842	return (push_code `appOL`
1843	call `appOL`
1844	assign_code dest_regs)
1845
1846	where
1847	arg_size :: CmmType -> Int -- Width in bytes
1848	arg_size ty = widthInBytes (typeWidth ty)
1849
1850	roundTo a x \| x `mod` a == 0 = x
1851	\| otherwise = x + a - (x `mod` a)
1852
1853	push_arg :: Bool -> HintedCmmActual {-current argument-}
1854	-> NatM InstrBlock -- code
1855
1856	push_arg use_sse2 (CmmHinted arg _hint) -- we don't need the hints on x86
1857	\| isWord64 arg_ty = do
1858	ChildCode64 code r_lo <- iselExpr64 arg
1859	delta <- getDeltaNat
1860	setDeltaNat (delta - 8)
1861	let
1862	r_hi = getHiVRegFromLo r_lo
1863	-- in
1864	return ( code `appOL`
1865	toOL [PUSH II32 (OpReg r_hi), DELTA (delta - 4),
1866	PUSH II32 (OpReg r_lo), DELTA (delta - 8),
1867	DELTA (delta-8)]
1868	)
1869
1870	\| isFloatType arg_ty = do
1871	(reg, code) <- getSomeReg arg
1872	delta <- getDeltaNat
1873	setDeltaNat (delta-size)
1874	return (code `appOL`
1875	toOL [SUB II32 (OpImm (ImmInt size)) (OpReg esp),
1876	DELTA (delta-size),
1877	let addr = AddrBaseIndex (EABaseReg esp)
1878	EAIndexNone
1879	(ImmInt 0)
1880	size = floatSize (typeWidth arg_ty)
1881	in
1882	if use_sse2
1883	then MOV size (OpReg reg) (OpAddr addr)
1884	else GST size reg addr
1885	]
1886	)
1887
1888	\| otherwise = do
1889	(operand, code) <- getOperand arg
1890	delta <- getDeltaNat
1891	setDeltaNat (delta-size)
1892	return (code `snocOL`
1893	PUSH II32 operand `snocOL`
1894	DELTA (delta-size))
1895
1896	where
1897	arg_ty = cmmExprType arg
1898	size = arg_size arg_ty -- Byte size
1899
1900	genCCall64 :: CmmCallTarget -- function to call
1901	-> [HintedCmmFormal] -- where to put the result
1902	-> [HintedCmmActual] -- arguments (of mixed type)
1903	-> NatM InstrBlock
1904	genCCall64 target dest_regs args =
1905	case (target, dest_regs) of
1906
1907	(CmmPrim op _, []) ->
1908	-- void return type prim op
1909	outOfLineCmmOp op Nothing args
1910
1911	(CmmPrim op _, [res]) ->
1912	-- we only cope with a single result for foreign calls
1913	outOfLineCmmOp op (Just res) args
1914
1915	(CmmPrim (MO_S_QuotRem width) _, _) -> divOp1 True width dest_regs args
1916	(CmmPrim (MO_U_QuotRem width) _, _) -> divOp1 False width dest_regs args
1917	(CmmPrim (MO_U_QuotRem2 width) _, _) -> divOp2 False width dest_regs args
1918	(CmmPrim (MO_Add2 width) _, [CmmHinted res_h _, CmmHinted res_l _]) ->
1919	case args of
1920	[CmmHinted arg_x _, CmmHinted arg_y _] ->
1921	do hCode <- getAnyReg (CmmLit (CmmInt 0 width))
1922	lCode <- getAnyReg (CmmMachOp (MO_Add width) [arg_x, arg_y])
1923	let size = intSize width
1924	reg_l = getRegisterReg True (CmmLocal res_l)
1925	reg_h = getRegisterReg True (CmmLocal res_h)
1926	code = hCode reg_h `appOL`
1927	lCode reg_l `snocOL`
1928	ADC size (OpImm (ImmInteger 0)) (OpReg reg_h)
1929	return code
1930	_ -> panic "genCCall64: Wrong number of arguments/results for add2"
1931	(CmmPrim (MO_U_Mul2 width) _, [CmmHinted res_h _, CmmHinted res_l _]) ->
1932	case args of
1933	[CmmHinted arg_x _, CmmHinted arg_y _] ->
1934	do (y_reg, y_code) <- getRegOrMem arg_y
1935	x_code <- getAnyReg arg_x
1936	let size = intSize width
1937	reg_h = getRegisterReg True (CmmLocal res_h)
1938	reg_l = getRegisterReg True (CmmLocal res_l)
1939	code = y_code `appOL`
1940	x_code rax `appOL`
1941	toOL [MUL2 size y_reg,
1942	MOV size (OpReg rdx) (OpReg reg_h),
1943	MOV size (OpReg rax) (OpReg reg_l)]
1944	return code
1945	_ -> panic "genCCall64: Wrong number of arguments/results for add2"
1946
1947	(CmmPrim _ (Just stmts), _) ->
1948	stmtsToInstrs stmts
1949
1950	_ ->
1951	do dflags <- getDynFlags
1952	let platform = targetPlatform dflags
1953	genCCall64' platform target dest_regs args
1954
1955	where divOp1 signed width results [CmmHinted arg_x _, CmmHinted arg_y _]
1956	= divOp signed width results Nothing arg_x arg_y
1957	divOp1 _ _ _ _
1958	= panic "genCCall64: Wrong number of arguments for divOp1"
1959	divOp2 signed width results [CmmHinted arg_x_high _,
1960	CmmHinted arg_x_low _,
1961	CmmHinted arg_y _]
1962	= divOp signed width results (Just arg_x_high) arg_x_low arg_y
1963	divOp2 _ _ _ _
1964	= panic "genCCall64: Wrong number of arguments for divOp2"
1965	divOp signed width [CmmHinted res_q _, CmmHinted res_r _]
1966	m_arg_x_high arg_x_low arg_y
1967	= do let size = intSize width
1968	reg_q = getRegisterReg True (CmmLocal res_q)
1969	reg_r = getRegisterReg True (CmmLocal res_r)
1970	widen \| signed = CLTD size
1971	\| otherwise = XOR size (OpReg rdx) (OpReg rdx)
1972	instr \| signed = IDIV
1973	\| otherwise = DIV
1974	(y_reg, y_code) <- getRegOrMem arg_y
1975	x_low_code <- getAnyReg arg_x_low
1976	x_high_code <- case m_arg_x_high of
1977	Just arg_x_high -> getAnyReg arg_x_high
1978	Nothing -> return $ const $ unitOL widen
1979	return $ y_code `appOL`
1980	x_low_code rax `appOL`
1981	x_high_code rdx `appOL`
1982	toOL [instr size y_reg,
1983	MOV size (OpReg rax) (OpReg reg_q),
1984	MOV size (OpReg rdx) (OpReg reg_r)]
1985	divOp _ _ _ _ _ _
1986	= panic "genCCall64: Wrong number of results for divOp"
1987
1988	genCCall64' :: Platform
1989	-> CmmCallTarget -- function to call
1990	-> [HintedCmmFormal] -- where to put the result
1991	-> [HintedCmmActual] -- arguments (of mixed type)
1992	-> NatM InstrBlock
1993	genCCall64' platform target dest_regs args = do
1994	-- load up the register arguments
1995	(stack_args, int_regs_used, fp_regs_used, load_args_code)
1996	<-
1997	if platformOS platform == OSMinGW32
1998	then load_args_win args [] [] allArgRegs nilOL
1999	else do (stack_args, aregs, fregs, load_args_code)
2000	<- load_args args allIntArgRegs allFPArgRegs nilOL
2001	let fp_regs_used = reverse (drop (length fregs) (reverse allFPArgRegs))
2002	int_regs_used = reverse (drop (length aregs) (reverse allIntArgRegs))
2003	return (stack_args, int_regs_used, fp_regs_used, load_args_code)
2004
2005	let
2006	arg_regs_used = int_regs_used ++ fp_regs_used
2007	arg_regs = [eax] ++ arg_regs_used
2008	-- for annotating the call instruction with
2009	sse_regs = length fp_regs_used
2010	arg_stack_slots = if platformOS platform == OSMinGW32
2011	then length stack_args + length allArgRegs
2012	else length stack_args
2013	tot_arg_size = arg_size * arg_stack_slots
2014
2015
2016	-- Align stack to 16n for calls, assuming a starting stack
2017	-- alignment of 16n - word_size on procedure entry. Which we
2018	-- maintiain. See Note [rts/StgCRun.c : Stack Alignment on X86]
2019	(real_size, adjust_rsp) <-
2020	if (tot_arg_size + wORD_SIZE) `rem` 16 == 0
2021	then return (tot_arg_size, nilOL)
2022	else do -- we need to adjust...
2023	delta <- getDeltaNat
2024	setDeltaNat (delta - wORD_SIZE)
2025	return (tot_arg_size + wORD_SIZE, toOL [
2026	SUB II64 (OpImm (ImmInt wORD_SIZE)) (OpReg rsp),
2027	DELTA (delta - wORD_SIZE) ])
2028
2029	-- push the stack args, right to left
2030	push_code <- push_args (reverse stack_args) nilOL
2031	-- On Win64, we also have to leave stack space for the arguments
2032	-- that we are passing in registers
2033	lss_code <- if platformOS platform == OSMinGW32
2034	then leaveStackSpace (length allArgRegs)
2035	else return nilOL
2036	delta <- getDeltaNat
2037
2038	-- deal with static vs dynamic call targets
2039	(callinsns,_cconv) <-
2040	case target of
2041	CmmCallee (CmmLit (CmmLabel lbl)) conv
2042	-> -- ToDo: stdcall arg sizes
2043	return (unitOL (CALL (Left fn_imm) arg_regs), conv)
2044	where fn_imm = ImmCLbl lbl
2045	CmmCallee expr conv
2046	-> do (dyn_r, dyn_c) <- getSomeReg expr
2047	return (dyn_c `snocOL` CALL (Right dyn_r) arg_regs, conv)
2048	CmmPrim _ _
2049	-> panic $ "genCCall: Can't handle CmmPrim call type here, error "
2050	++ "probably because too many return values."
2051
2052	let
2053	-- The x86_64 ABI requires us to set %al to the number of SSE2
2054	-- registers that contain arguments, if the called routine
2055	-- is a varargs function. We don't know whether it's a
2056	-- varargs function or not, so we have to assume it is.
2057	--
2058	-- It's not safe to omit this assignment, even if the number
2059	-- of SSE2 regs in use is zero. If %al is larger than 8
2060	-- on entry to a varargs function, seg faults ensue.
2061	assign_eax n = unitOL (MOV II32 (OpImm (ImmInt n)) (OpReg eax))
2062
2063	let call = callinsns `appOL`
2064	toOL (
2065	-- Deallocate parameters after call for ccall;
2066	-- stdcall has callee do it, but is not supported on
2067	-- x86_64 target (see #3336)
2068	(if real_size==0 then [] else
2069	[ADD (intSize wordWidth) (OpImm (ImmInt real_size)) (OpReg esp)])
2070	++
2071	[DELTA (delta + real_size)]
2072	)
2073	-- in
2074	setDeltaNat (delta + real_size)
2075
2076	let
2077	-- assign the results, if necessary
2078	assign_code [] = nilOL
2079	assign_code [CmmHinted dest _hint] =
2080	case typeWidth rep of
2081	W32 \| isFloatType rep -> unitOL (MOV (floatSize W32) (OpReg xmm0) (OpReg r_dest))
2082	W64 \| isFloatType rep -> unitOL (MOV (floatSize W64) (OpReg xmm0) (OpReg r_dest))
2083	_ -> unitOL (MOV (cmmTypeSize rep) (OpReg rax) (OpReg r_dest))
2084	where
2085	rep = localRegType dest
2086	r_dest = getRegisterReg True (CmmLocal dest)
2087	assign_code _many = panic "genCCall.assign_code many"
2088
2089	return (load_args_code `appOL`
2090	adjust_rsp `appOL`
2091	push_code `appOL`
2092	lss_code `appOL`
2093	assign_eax sse_regs `appOL`
2094	call `appOL`
2095	assign_code dest_regs)
2096
2097	where arg_size = 8 -- always, at the mo
2098
2099	load_args :: [CmmHinted CmmExpr]
2100	-> [Reg] -- int regs avail for args
2101	-> [Reg] -- FP regs avail for args
2102	-> InstrBlock
2103	-> NatM ([CmmHinted CmmExpr],[Reg],[Reg],InstrBlock)
2104	load_args args [] [] code = return (args, [], [], code)
2105	-- no more regs to use
2106	load_args [] aregs fregs code = return ([], aregs, fregs, code)
2107	-- no more args to push
2108	load_args ((CmmHinted arg hint) : rest) aregs fregs code
2109	\| isFloatType arg_rep =
2110	case fregs of
2111	[] -> push_this_arg
2112	(r:rs) -> do
2113	arg_code <- getAnyReg arg
2114	load_args rest aregs rs (code `appOL` arg_code r)
2115	\| otherwise =
2116	case aregs of
2117	[] -> push_this_arg
2118	(r:rs) -> do
2119	arg_code <- getAnyReg arg
2120	load_args rest rs fregs (code `appOL` arg_code r)
2121	where
2122	arg_rep = cmmExprType arg
2123
2124	push_this_arg = do
2125	(args',ars,frs,code') <- load_args rest aregs fregs code
2126	return ((CmmHinted arg hint):args', ars, frs, code')
2127
2128	load_args_win :: [CmmHinted CmmExpr]
2129	-> [Reg] -- used int regs
2130	-> [Reg] -- used FP regs
2131	-> [(Reg, Reg)] -- (int, FP) regs avail for args
2132	-> InstrBlock
2133	-> NatM ([CmmHinted CmmExpr],[Reg],[Reg],InstrBlock)
2134	load_args_win args usedInt usedFP [] code
2135	= return (args, usedInt, usedFP, code)
2136	-- no more regs to use
2137	load_args_win [] usedInt usedFP _ code
2138	= return ([], usedInt, usedFP, code)
2139	-- no more args to push
2140	load_args_win ((CmmHinted arg _) : rest) usedInt usedFP
2141	((ireg, freg) : regs) code
2142	\| isFloatType arg_rep = do
2143	arg_code <- getAnyReg arg
2144	load_args_win rest (ireg : usedInt) (freg : usedFP) regs
2145	(code `appOL`
2146	arg_code freg `snocOL`
2147	-- If we are calling a varargs function
2148	-- then we need to define ireg as well
2149	-- as freg
2150	MOV II64 (OpReg freg) (OpReg ireg))
2151	\| otherwise = do
2152	arg_code <- getAnyReg arg
2153	load_args_win rest (ireg : usedInt) usedFP regs
2154	(code `appOL` arg_code ireg)
2155	where
2156	arg_rep = cmmExprType arg
2157
2158	push_args [] code = return code
2159	push_args ((CmmHinted arg _):rest) code
2160	\| isFloatType arg_rep = do
2161	(arg_reg, arg_code) <- getSomeReg arg
2162	delta <- getDeltaNat
2163	setDeltaNat (delta-arg_size)
2164	let code' = code `appOL` arg_code `appOL` toOL [
2165	SUB (intSize wordWidth) (OpImm (ImmInt arg_size)) (OpReg rsp) ,
2166	DELTA (delta-arg_size),
2167	MOV (floatSize width) (OpReg arg_reg) (OpAddr (spRel platform 0))]
2168	push_args rest code'
2169
2170	\| otherwise = do
2171	-- we only ever generate word-sized function arguments. Promotion
2172	-- has already happened: our Int8# type is kept sign-extended
2173	-- in an Int#, for example.
2174	ASSERT(width == W64) return ()
2175	(arg_op, arg_code) <- getOperand arg
2176	delta <- getDeltaNat
2177	setDeltaNat (delta-arg_size)
2178	let code' = code `appOL` arg_code `appOL` toOL [
2179	PUSH II64 arg_op,
2180	DELTA (delta-arg_size)]
2181	push_args rest code'
2182	where
2183	arg_rep = cmmExprType arg
2184	width = typeWidth arg_rep
2185
2186	leaveStackSpace n = do
2187	delta <- getDeltaNat
2188	setDeltaNat (delta - n * arg_size)
2189	return $ toOL [
2190	SUB II64 (OpImm (ImmInt (n * wORD_SIZE))) (OpReg rsp),
2191	DELTA (delta - n * arg_size)]
2192
2193	-- \| We're willing to inline and unroll memcpy/memset calls that touch
2194	-- at most these many bytes. This threshold is the same as the one
2195	-- used by GCC and LLVM.
2196	maxInlineSizeThreshold :: Integer
2197	maxInlineSizeThreshold = 128
2198
2199	outOfLineCmmOp :: CallishMachOp -> Maybe HintedCmmFormal -> [HintedCmmActual] -> NatM InstrBlock
2200	outOfLineCmmOp mop res args
2201	= do
2202	dflags <- getDynFlags
2203	targetExpr <- cmmMakeDynamicReference dflags addImportNat CallReference lbl
2204	let target = CmmCallee targetExpr CCallConv
2205
2206	stmtToInstrs (CmmCall target (catMaybes [res]) args' CmmMayReturn)
2207	where
2208	-- Assume we can call these functions directly, and that they're not in a dynamic library.
2209	-- TODO: Why is this ok? Under linux this code will be in libm.so
2210	-- Is is because they're really implemented as a primitive instruction by the assembler?? -- BL 2009/12/31
2211	lbl = mkForeignLabel fn Nothing ForeignLabelInThisPackage IsFunction
2212
2213	args' = case mop of
2214	MO_Memcpy -> init args
2215	MO_Memset -> init args
2216	MO_Memmove -> init args
2217	_ -> args
2218
2219	fn = case mop of
2220	MO_F32_Sqrt -> fsLit "sqrtf"
2221	MO_F32_Sin -> fsLit "sinf"
2222	MO_F32_Cos -> fsLit "cosf"
2223	MO_F32_Tan -> fsLit "tanf"
2224	MO_F32_Exp -> fsLit "expf"
2225	MO_F32_Log -> fsLit "logf"
2226
2227	MO_F32_Asin -> fsLit "asinf"
2228	MO_F32_Acos -> fsLit "acosf"
2229	MO_F32_Atan -> fsLit "atanf"
2230
2231	MO_F32_Sinh -> fsLit "sinhf"
2232	MO_F32_Cosh -> fsLit "coshf"
2233	MO_F32_Tanh -> fsLit "tanhf"
2234	MO_F32_Pwr -> fsLit "powf"
2235
2236	MO_F64_Sqrt -> fsLit "sqrt"
2237	MO_F64_Sin -> fsLit "sin"
2238	MO_F64_Cos -> fsLit "cos"
2239	MO_F64_Tan -> fsLit "tan"
2240	MO_F64_Exp -> fsLit "exp"
2241	MO_F64_Log -> fsLit "log"
2242
2243	MO_F64_Asin -> fsLit "asin"
2244	MO_F64_Acos -> fsLit "acos"
2245	MO_F64_Atan -> fsLit "atan"
2246
2247	MO_F64_Sinh -> fsLit "sinh"
2248	MO_F64_Cosh -> fsLit "cosh"
2249	MO_F64_Tanh -> fsLit "tanh"
2250	MO_F64_Pwr -> fsLit "pow"
2251
2252	MO_Memcpy -> fsLit "memcpy"
2253	MO_Memset -> fsLit "memset"
2254	MO_Memmove -> fsLit "memmove"
2255
2256	MO_PopCnt _ -> fsLit "popcnt"
2257
2258	MO_S_QuotRem {} -> unsupported
2259	MO_U_QuotRem {} -> unsupported
2260	MO_U_QuotRem2 {} -> unsupported
2261	MO_Add2 {} -> unsupported
2262	MO_U_Mul2 {} -> unsupported
2263	MO_WriteBarrier -> unsupported
2264	MO_Touch -> unsupported
2265	unsupported = panic ("outOfLineCmmOp: " ++ show mop
2266	++ "not supported here")
2267
2268	-- -----------------------------------------------------------------------------
2269	-- Generating a table-branch
2270
2271	genSwitch :: CmmExpr -> [Maybe BlockId] -> NatM InstrBlock
2272
2273	genSwitch expr ids
2274	\| opt_PIC
2275	= do
2276	(reg,e_code) <- getSomeReg expr
2277	lbl <- getNewLabelNat
2278	dflags <- getDynFlags
2279	dynRef <- cmmMakeDynamicReference dflags addImportNat DataReference lbl
2280	(tableReg,t_code) <- getSomeReg $ dynRef
2281	let op = OpAddr (AddrBaseIndex (EABaseReg tableReg)
2282	(EAIndex reg wORD_SIZE) (ImmInt 0))
2283
2284	return $ if target32Bit (targetPlatform dflags)
2285	then e_code `appOL` t_code `appOL` toOL [
2286	ADD (intSize wordWidth) op (OpReg tableReg),
2287	JMP_TBL (OpReg tableReg) ids ReadOnlyData lbl
2288	]
2289	else case platformOS (targetPlatform dflags) of
2290	OSDarwin ->
2291	-- on Mac OS X/x86_64, put the jump table
2292	-- in the text section to work around a
2293	-- limitation of the linker.
2294	-- ld64 is unable to handle the relocations for
2295	-- .quad L1 - L0
2296	-- if L0 is not preceded by a non-anonymous
2297	-- label in its section.
2298	e_code `appOL` t_code `appOL` toOL [
2299	ADD (intSize wordWidth) op (OpReg tableReg),
2300	JMP_TBL (OpReg tableReg) ids Text lbl
2301	]
2302	_ ->
2303	-- HACK: On x86_64 binutils<2.17 is only able
2304	-- to generate PC32 relocations, hence we only
2305	-- get 32-bit offsets in the jump table. As
2306	-- these offsets are always negative we need
2307	-- to properly sign extend them to 64-bit.
2308	-- This hack should be removed in conjunction
2309	-- with the hack in PprMach.hs/pprDataItem
2310	-- once binutils 2.17 is standard.
2311	e_code `appOL` t_code `appOL` toOL [
2312	MOVSxL II32 op (OpReg reg),
2313	ADD (intSize wordWidth) (OpReg reg) (OpReg tableReg),
2314	JMP_TBL (OpReg tableReg) ids ReadOnlyData lbl
2315	]
2316	\| otherwise
2317	= do
2318	(reg,e_code) <- getSomeReg expr
2319	lbl <- getNewLabelNat
2320	let op = OpAddr (AddrBaseIndex EABaseNone (EAIndex reg wORD_SIZE) (ImmCLbl lbl))
2321	code = e_code `appOL` toOL [
2322	JMP_TBL op ids ReadOnlyData lbl
2323	]
2324	-- in
2325	return code
2326
2327	generateJumpTableForInstr :: Instr -> Maybe (NatCmmDecl (Alignment, CmmStatics) Instr)
2328	generateJumpTableForInstr (JMP_TBL _ ids section lbl) = Just (createJumpTable ids section lbl)
2329	generateJumpTableForInstr _ = Nothing
2330
2331	createJumpTable :: [Maybe BlockId] -> Section -> CLabel -> GenCmmDecl (Alignment, CmmStatics) h g
2332	createJumpTable ids section lbl
2333	= let jumpTable
2334	\| opt_PIC =
2335	let jumpTableEntryRel Nothing
2336	= CmmStaticLit (CmmInt 0 wordWidth)
2337	jumpTableEntryRel (Just blockid)
2338	= CmmStaticLit (CmmLabelDiffOff blockLabel lbl 0)
2339	where blockLabel = mkAsmTempLabel (getUnique blockid)
2340	in map jumpTableEntryRel ids
2341	\| otherwise = map jumpTableEntry ids
2342	in CmmData section (1, Statics lbl jumpTable)
2343
2344	-- -----------------------------------------------------------------------------
2345	-- 'condIntReg' and 'condFltReg': condition codes into registers
2346
2347	-- Turn those condition codes into integers now (when they appear on
2348	-- the right hand side of an assignment).
2349	--
2350	-- (If applicable) Do not fill the delay slots here; you will confuse the
2351	-- register allocator.
2352
2353	condIntReg :: Cond -> CmmExpr -> CmmExpr -> NatM Register
2354
2355	condIntReg cond x y = do
2356	CondCode _ cond cond_code <- condIntCode cond x y
2357	tmp <- getNewRegNat II8
2358	let
2359	code dst = cond_code `appOL` toOL [
2360	SETCC cond (OpReg tmp),
2361	MOVZxL II8 (OpReg tmp) (OpReg dst)
2362	]
2363	-- in
2364	return (Any II32 code)
2365
2366
2367
2368	condFltReg :: Bool -> Cond -> CmmExpr -> CmmExpr -> NatM Register
2369	condFltReg is32Bit cond x y = if_sse2 condFltReg_sse2 condFltReg_x87
2370	where
2371	condFltReg_x87 = do
2372	CondCode _ cond cond_code <- condFltCode cond x y
2373	tmp <- getNewRegNat II8
2374	let
2375	code dst = cond_code `appOL` toOL [
2376	SETCC cond (OpReg tmp),
2377	MOVZxL II8 (OpReg tmp) (OpReg dst)
2378	]
2379	-- in
2380	return (Any II32 code)
2381
2382	condFltReg_sse2 = do
2383	CondCode _ cond cond_code <- condFltCode cond x y
2384	tmp1 <- getNewRegNat (archWordSize is32Bit)
2385	tmp2 <- getNewRegNat (archWordSize is32Bit)
2386	let
2387	-- We have to worry about unordered operands (eg. comparisons
2388	-- against NaN). If the operands are unordered, the comparison
2389	-- sets the parity flag, carry flag and zero flag.
2390	-- All comparisons are supposed to return false for unordered
2391	-- operands except for !=, which returns true.
2392	--
2393	-- Optimisation: we don't have to test the parity flag if we
2394	-- know the test has already excluded the unordered case: eg >
2395	-- and >= test for a zero carry flag, which can only occur for
2396	-- ordered operands.
2397	--
2398	-- ToDo: by reversing comparisons we could avoid testing the
2399	-- parity flag in more cases.
2400
2401	code dst =
2402	cond_code `appOL`
2403	(case cond of
2404	NE -> or_unordered dst
2405	GU -> plain_test dst
2406	GEU -> plain_test dst
2407	_ -> and_ordered dst)
2408
2409	plain_test dst = toOL [
2410	SETCC cond (OpReg tmp1),
2411	MOVZxL II8 (OpReg tmp1) (OpReg dst)
2412	]
2413	or_unordered dst = toOL [
2414	SETCC cond (OpReg tmp1),
2415	SETCC PARITY (OpReg tmp2),
2416	OR II8 (OpReg tmp1) (OpReg tmp2),
2417	MOVZxL II8 (OpReg tmp2) (OpReg dst)
2418	]
2419	and_ordered dst = toOL [
2420	SETCC cond (OpReg tmp1),
2421	SETCC NOTPARITY (OpReg tmp2),
2422	AND II8 (OpReg tmp1) (OpReg tmp2),
2423	MOVZxL II8 (OpReg tmp2) (OpReg dst)
2424	]
2425	-- in
2426	return (Any II32 code)
2427
2428
2429	-- -----------------------------------------------------------------------------
2430	-- 'trivial*Code': deal with trivial instructions
2431
2432	-- Trivial (dyadic: 'trivialCode', floating-point: 'trivialFCode',
2433	-- unary: 'trivialUCode', unary fl-pt:'trivialUFCode') instructions.
2434	-- Only look for constants on the right hand side, because that's
2435	-- where the generic optimizer will have put them.
2436
2437	-- Similarly, for unary instructions, we don't have to worry about
2438	-- matching an StInt as the argument, because genericOpt will already
2439	-- have handled the constant-folding.
2440
2441
2442	{-
2443	The Rules of the Game are:
2444
2445	* You cannot assume anything about the destination register dst;
2446	it may be anything, including a fixed reg.
2447
2448	* You may compute an operand into a fixed reg, but you may not
2449	subsequently change the contents of that fixed reg. If you
2450	want to do so, first copy the value either to a temporary
2451	or into dst. You are free to modify dst even if it happens
2452	to be a fixed reg -- that's not your problem.
2453
2454	* You cannot assume that a fixed reg will stay live over an
2455	arbitrary computation. The same applies to the dst reg.
2456
2457	* Temporary regs obtained from getNewRegNat are distinct from
2458	each other and from all other regs, and stay live over
2459	arbitrary computations.
2460
2461	--------------------
2462
2463	SDM's version of The Rules:
2464
2465	* If getRegister returns Any, that means it can generate correct
2466	code which places the result in any register, period. Even if that
2467	register happens to be read during the computation.
2468
2469	Corollary #1: this means that if you are generating code for an
2470	operation with two arbitrary operands, you cannot assign the result
2471	of the first operand into the destination register before computing
2472	the second operand. The second operand might require the old value
2473	of the destination register.
2474
2475	Corollary #2: A function might be able to generate more efficient
2476	code if it knows the destination register is a new temporary (and
2477	therefore not read by any of the sub-computations).
2478
2479	* If getRegister returns Any, then the code it generates may modify only:
2480	(a) fresh temporaries
2481	(b) the destination register
2482	(c) known registers (eg. %ecx is used by shifts)
2483	In particular, it may not modify global registers, unless the global
2484	register happens to be the destination register.
2485	-}
2486
2487	trivialCode :: Width -> (Operand -> Operand -> Instr)
2488	-> Maybe (Operand -> Operand -> Instr)
2489	-> CmmExpr -> CmmExpr -> NatM Register
2490	trivialCode width instr m a b
2491	= do is32Bit <- is32BitPlatform
2492	trivialCode' is32Bit width instr m a b
2493
2494	trivialCode' :: Bool -> Width -> (Operand -> Operand -> Instr)
2495	-> Maybe (Operand -> Operand -> Instr)
2496	-> CmmExpr -> CmmExpr -> NatM Register
2497	trivialCode' is32Bit width _ (Just revinstr) (CmmLit lit_a) b
2498	\| is32BitLit is32Bit lit_a = do
2499	b_code <- getAnyReg b
2500	let
2501	code dst
2502	= b_code dst `snocOL`
2503	revinstr (OpImm (litToImm lit_a)) (OpReg dst)
2504	-- in
2505	return (Any (intSize width) code)
2506
2507	trivialCode' _ width instr _ a b
2508	= genTrivialCode (intSize width) instr a b
2509
2510	-- This is re-used for floating pt instructions too.
2511	genTrivialCode :: Size -> (Operand -> Operand -> Instr)
2512	-> CmmExpr -> CmmExpr -> NatM Register
2513	genTrivialCode rep instr a b = do
2514	(b_op, b_code) <- getNonClobberedOperand b
2515	a_code <- getAnyReg a
2516	tmp <- getNewRegNat rep
2517	let
2518	-- We want the value of b to stay alive across the computation of a.
2519	-- But, we want to calculate a straight into the destination register,
2520	-- because the instruction only has two operands (dst := dst `op` src).
2521	-- The troublesome case is when the result of b is in the same register
2522	-- as the destination reg. In this case, we have to save b in a
2523	-- new temporary across the computation of a.
2524	code dst
2525	\| dst `regClashesWithOp` b_op =
2526	b_code `appOL`
2527	unitOL (MOV rep b_op (OpReg tmp)) `appOL`
2528	a_code dst `snocOL`
2529	instr (OpReg tmp) (OpReg dst)
2530	\| otherwise =
2531	b_code `appOL`
2532	a_code dst `snocOL`
2533	instr b_op (OpReg dst)
2534	-- in
2535	return (Any rep code)
2536
2537	regClashesWithOp :: Reg -> Operand -> Bool
2538	reg `regClashesWithOp` OpReg reg2 = reg == reg2
2539	reg `regClashesWithOp` OpAddr amode = any (==reg) (addrModeRegs amode)
2540	_ `regClashesWithOp` _ = False
2541
2542	-----------
2543
2544	trivialUCode :: Size -> (Operand -> Instr)
2545	-> CmmExpr -> NatM Register
2546	trivialUCode rep instr x = do
2547	x_code <- getAnyReg x
2548	let
2549	code dst =
2550	x_code dst `snocOL`
2551	instr (OpReg dst)
2552	return (Any rep code)
2553
2554	-----------
2555
2556	trivialFCode_x87 :: (Size -> Reg -> Reg -> Reg -> Instr)
2557	-> CmmExpr -> CmmExpr -> NatM Register
2558	trivialFCode_x87 instr x y = do
2559	(x_reg, x_code) <- getNonClobberedReg x -- these work for float regs too
2560	(y_reg, y_code) <- getSomeReg y
2561	let
2562	size = FF80 -- always, on x87
2563	code dst =
2564	x_code `appOL`
2565	y_code `snocOL`
2566	instr size x_reg y_reg dst
2567	return (Any size code)
2568
2569	trivialFCode_sse2 :: Width -> (Size -> Operand -> Operand -> Instr)
2570	-> CmmExpr -> CmmExpr -> NatM Register
2571	trivialFCode_sse2 pk instr x y
2572	= genTrivialCode size (instr size) x y
2573	where size = floatSize pk
2574
2575
2576	trivialUFCode :: Size -> (Reg -> Reg -> Instr) -> CmmExpr -> NatM Register
2577	trivialUFCode size instr x = do
2578	(x_reg, x_code) <- getSomeReg x
2579	let
2580	code dst =
2581	x_code `snocOL`
2582	instr x_reg dst
2583	-- in
2584	return (Any size code)
2585
2586
2587	--------------------------------------------------------------------------------
2588	coerceInt2FP :: Width -> Width -> CmmExpr -> NatM Register
2589	coerceInt2FP from to x = if_sse2 coerce_sse2 coerce_x87
2590	where
2591	coerce_x87 = do
2592	(x_reg, x_code) <- getSomeReg x
2593	let
2594	opc = case to of W32 -> GITOF; W64 -> GITOD;
2595	n -> panic $ "coerceInt2FP.x87: unhandled width ("
2596	++ show n ++ ")"
2597	code dst = x_code `snocOL` opc x_reg dst
2598	-- ToDo: works for non-II32 reps?
2599	return (Any FF80 code)
2600
2601	coerce_sse2 = do
2602	(x_op, x_code) <- getOperand x -- ToDo: could be a safe operand
2603	let
2604	opc = case to of W32 -> CVTSI2SS; W64 -> CVTSI2SD
2605	n -> panic $ "coerceInt2FP.sse: unhandled width ("
2606	++ show n ++ ")"
2607	code dst = x_code `snocOL` opc (intSize from) x_op dst
2608	-- in
2609	return (Any (floatSize to) code)
2610	-- works even if the destination rep is <II32
2611
2612	--------------------------------------------------------------------------------
2613	coerceFP2Int :: Width -> Width -> CmmExpr -> NatM Register
2614	coerceFP2Int from to x = if_sse2 coerceFP2Int_sse2 coerceFP2Int_x87
2615	where
2616	coerceFP2Int_x87 = do
2617	(x_reg, x_code) <- getSomeReg x
2618	let
2619	opc = case from of W32 -> GFTOI; W64 -> GDTOI
2620	n -> panic $ "coerceFP2Int.x87: unhandled width ("
2621	++ show n ++ ")"
2622	code dst = x_code `snocOL` opc x_reg dst
2623	-- ToDo: works for non-II32 reps?
2624	-- in
2625	return (Any (intSize to) code)
2626
2627	coerceFP2Int_sse2 = do
2628	(x_op, x_code) <- getOperand x -- ToDo: could be a safe operand
2629	let
2630	opc = case from of W32 -> CVTTSS2SIQ; W64 -> CVTTSD2SIQ;
2631	n -> panic $ "coerceFP2Init.sse: unhandled width ("
2632	++ show n ++ ")"
2633	code dst = x_code `snocOL` opc (intSize to) x_op dst
2634	-- in
2635	return (Any (intSize to) code)
2636	-- works even if the destination rep is <II32
2637
2638
2639	--------------------------------------------------------------------------------
2640	coerceFP2FP :: Width -> CmmExpr -> NatM Register
2641	coerceFP2FP to x = do
2642	use_sse2 <- sse2Enabled
2643	(x_reg, x_code) <- getSomeReg x
2644	let
2645	opc \| use_sse2 = case to of W32 -> CVTSD2SS; W64 -> CVTSS2SD;
2646	n -> panic $ "coerceFP2FP: unhandled width ("
2647	++ show n ++ ")"
2648	\| otherwise = GDTOF
2649	code dst = x_code `snocOL` opc x_reg dst
2650	-- in
2651	return (Any (if use_sse2 then floatSize to else FF80) code)
2652
2653	--------------------------------------------------------------------------------
2654
2655	sse2NegCode :: Width -> CmmExpr -> NatM Register
2656	sse2NegCode w x = do
2657	let sz = floatSize w
2658	x_code <- getAnyReg x
2659	-- This is how gcc does it, so it can't be that bad:
2660	let
2661	const \| FF32 <- sz = CmmInt 0x80000000 W32
2662	\| otherwise = CmmInt 0x8000000000000000 W64
2663	Amode amode amode_code <- memConstant (widthInBytes w) const
2664	tmp <- getNewRegNat sz
2665	let
2666	code dst = x_code dst `appOL` amode_code `appOL` toOL [
2667	MOV sz (OpAddr amode) (OpReg tmp),
2668	XOR sz (OpReg tmp) (OpReg dst)
2669	]
2670	--
2671	return (Any sz code)

Note: See TracBrowser for help on using the browser.

Context Navigation

root/compiler/nativeGen/X86/CodeGen.hs

Download in other formats: