76ee148ef7af4d993b7d3c04880b22371daaa992
[ghc.git] / compiler / codeGen / CgPrimOp.hs
1 -----------------------------------------------------------------------------
2 --
3 -- Code generation for PrimOps.
4 --
5 -- (c) The University of Glasgow 2004-2006
6 --
7 -----------------------------------------------------------------------------
8
9 module CgPrimOp (
10 cgPrimOp
11 ) where
12
13 import BasicTypes
14 import ForeignCall
15 import ClosureInfo
16 import StgSyn
17 import CgForeignCall
18 import CgBindery
19 import CgMonad
20 import CgHeapery
21 import CgInfoTbls
22 import CgTicky
23 import CgProf
24 import CgUtils
25 import OldCmm
26 import CLabel
27 import OldCmmUtils
28 import PrimOp
29 import SMRep
30 import Module
31 import Constants
32 import Outputable
33 import DynFlags
34 import FastString
35
36 import Control.Monad
37 import Data.Bits
38
39 -- ---------------------------------------------------------------------------
40 -- Code generation for PrimOps
41
42 cgPrimOp :: [CmmFormal] -- where to put the results
43 -> PrimOp -- the op
44 -> [StgArg] -- arguments
45 -> StgLiveVars -- live vars, in case we need to save them
46 -> Code
47
48 cgPrimOp results op args live
49 = do dflags <- getDynFlags
50 arg_exprs <- getArgAmodes args
51 let non_void_args = [ e | (r,e) <- arg_exprs, nonVoidArg r ]
52 emitPrimOp dflags results op non_void_args live
53
54
55 emitPrimOp :: DynFlags
56 -> [CmmFormal] -- where to put the results
57 -> PrimOp -- the op
58 -> [CmmExpr] -- arguments
59 -> StgLiveVars -- live vars, in case we need to save them
60 -> Code
61
62 -- First we handle various awkward cases specially. The remaining
63 -- easy cases are then handled by translateOp, defined below.
64
65 emitPrimOp dflags [res_r,res_c] IntAddCOp [aa,bb] _
66 {-
67 With some bit-twiddling, we can define int{Add,Sub}Czh portably in
68 C, and without needing any comparisons. This may not be the
69 fastest way to do it - if you have better code, please send it! --SDM
70
71 Return : r = a + b, c = 0 if no overflow, 1 on overflow.
72
73 We currently don't make use of the r value if c is != 0 (i.e.
74 overflow), we just convert to big integers and try again. This
75 could be improved by making r and c the correct values for
76 plugging into a new J#.
77
78 { r = ((I_)(a)) + ((I_)(b)); \
79 c = ((StgWord)(~(((I_)(a))^((I_)(b))) & (((I_)(a))^r))) \
80 >> (BITS_IN (I_) - 1); \
81 }
82 Wading through the mass of bracketry, it seems to reduce to:
83 c = ( (~(a^b)) & (a^r) ) >>unsigned (BITS_IN(I_)-1)
84
85 -}
86 = stmtsC [
87 CmmAssign (CmmLocal res_r) (CmmMachOp (mo_wordAdd dflags) [aa,bb]),
88 CmmAssign (CmmLocal res_c) $
89 CmmMachOp (mo_wordUShr dflags) [
90 CmmMachOp (mo_wordAnd dflags) [
91 CmmMachOp (mo_wordNot dflags) [CmmMachOp (mo_wordXor dflags) [aa,bb]],
92 CmmMachOp (mo_wordXor dflags) [aa, CmmReg (CmmLocal res_r)]
93 ],
94 mkIntExpr dflags (wORD_SIZE_IN_BITS - 1)
95 ]
96 ]
97
98
99 emitPrimOp dflags [res_r,res_c] IntSubCOp [aa,bb] _
100 {- Similarly:
101 #define subIntCzh(r,c,a,b) \
102 { r = ((I_)(a)) - ((I_)(b)); \
103 c = ((StgWord)((((I_)(a))^((I_)(b))) & (((I_)(a))^r))) \
104 >> (BITS_IN (I_) - 1); \
105 }
106
107 c = ((a^b) & (a^r)) >>unsigned (BITS_IN(I_)-1)
108 -}
109 = stmtsC [
110 CmmAssign (CmmLocal res_r) (CmmMachOp (mo_wordSub dflags) [aa,bb]),
111 CmmAssign (CmmLocal res_c) $
112 CmmMachOp (mo_wordUShr dflags) [
113 CmmMachOp (mo_wordAnd dflags) [
114 CmmMachOp (mo_wordXor dflags) [aa,bb],
115 CmmMachOp (mo_wordXor dflags) [aa, CmmReg (CmmLocal res_r)]
116 ],
117 mkIntExpr dflags (wORD_SIZE_IN_BITS - 1)
118 ]
119 ]
120
121
122 emitPrimOp _ [res] ParOp [arg] live
123 = do
124 -- for now, just implement this in a C function
125 -- later, we might want to inline it.
126 vols <- getVolatileRegs live
127 emitForeignCall' PlayRisky
128 [CmmHinted res NoHint]
129 (CmmCallee newspark CCallConv)
130 [ (CmmHinted (CmmReg (CmmGlobal BaseReg)) AddrHint)
131 , (CmmHinted arg AddrHint) ]
132 (Just vols)
133 NoC_SRT -- No SRT b/c we do PlayRisky
134 CmmMayReturn
135 where
136 newspark = CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageId (fsLit "newSpark")))
137
138 emitPrimOp dflags [res] SparkOp [arg] live = do
139 -- returns the value of arg in res. We're going to therefore
140 -- refer to arg twice (once to pass to newSpark(), and once to
141 -- assign to res), so put it in a temporary.
142 tmp <- newTemp (bWord dflags)
143 stmtC (CmmAssign (CmmLocal tmp) arg)
144
145 vols <- getVolatileRegs live
146 res' <- newTemp (bWord dflags)
147 emitForeignCall' PlayRisky
148 [CmmHinted res' NoHint]
149 (CmmCallee newspark CCallConv)
150 [ (CmmHinted (CmmReg (CmmGlobal BaseReg)) AddrHint)
151 , (CmmHinted arg AddrHint) ]
152 (Just vols)
153 NoC_SRT -- No SRT b/c we do PlayRisky
154 CmmMayReturn
155 stmtC (CmmAssign (CmmLocal res) (CmmReg (CmmLocal tmp)))
156 where
157 newspark = CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageId (fsLit "newSpark")))
158
159 emitPrimOp dflags [res] GetCCSOfOp [arg] _live
160 = stmtC (CmmAssign (CmmLocal res) val)
161 where
162 val
163 | dopt Opt_SccProfilingOn dflags = costCentreFrom dflags (cmmUntag dflags arg)
164 | otherwise = CmmLit (zeroCLit dflags)
165
166 emitPrimOp _ [res] GetCurrentCCSOp [_dummy_arg] _live
167 = stmtC (CmmAssign (CmmLocal res) curCCS)
168
169 emitPrimOp dflags [res] ReadMutVarOp [mutv] _
170 = stmtC (CmmAssign (CmmLocal res) (cmmLoadIndexW dflags mutv (fixedHdrSize dflags) (gcWord dflags)))
171
172 emitPrimOp dflags [] WriteMutVarOp [mutv,var] live
173 = do stmtC (CmmStore (cmmOffsetW dflags mutv (fixedHdrSize dflags)) var)
174 vols <- getVolatileRegs live
175 emitForeignCall' PlayRisky
176 [{-no results-}]
177 (CmmCallee (CmmLit (CmmLabel mkDirty_MUT_VAR_Label))
178 CCallConv)
179 [ (CmmHinted (CmmReg (CmmGlobal BaseReg)) AddrHint)
180 , (CmmHinted mutv AddrHint) ]
181 (Just vols)
182 NoC_SRT -- No SRT b/c we do PlayRisky
183 CmmMayReturn
184
185 -- #define sizzeofByteArrayzh(r,a) \
186 -- r = ((StgArrWords *)(a))->bytes
187 emitPrimOp dflags [res] SizeofByteArrayOp [arg] _
188 = stmtC $
189 CmmAssign (CmmLocal res)
190 (cmmLoadIndexW dflags arg (fixedHdrSize dflags) (bWord dflags))
191
192 -- #define sizzeofMutableByteArrayzh(r,a) \
193 -- r = ((StgArrWords *)(a))->bytes
194 emitPrimOp dflags [res] SizeofMutableByteArrayOp [arg] live
195 = emitPrimOp dflags [res] SizeofByteArrayOp [arg] live
196
197
198 -- #define touchzh(o) /* nothing */
199 emitPrimOp _ [] TouchOp [_] _
200 = nopC
201
202 -- #define byteArrayContentszh(r,a) r = BYTE_ARR_CTS(a)
203 emitPrimOp dflags [res] ByteArrayContents_Char [arg] _
204 = stmtC (CmmAssign (CmmLocal res) (cmmOffsetB dflags arg (arrWordsHdrSize dflags)))
205
206 -- #define stableNameToIntzh(r,s) (r = ((StgStableName *)s)->sn)
207 emitPrimOp dflags [res] StableNameToIntOp [arg] _
208 = stmtC (CmmAssign (CmmLocal res) (cmmLoadIndexW dflags arg (fixedHdrSize dflags) (bWord dflags)))
209
210 -- #define eqStableNamezh(r,sn1,sn2) \
211 -- (r = (((StgStableName *)sn1)->sn == ((StgStableName *)sn2)->sn))
212 emitPrimOp dflags [res] EqStableNameOp [arg1,arg2] _
213 = stmtC (CmmAssign (CmmLocal res) (CmmMachOp (mo_wordEq dflags) [
214 cmmLoadIndexW dflags arg1 (fixedHdrSize dflags) (bWord dflags),
215 cmmLoadIndexW dflags arg2 (fixedHdrSize dflags) (bWord dflags)
216 ]))
217
218
219 emitPrimOp dflags [res] ReallyUnsafePtrEqualityOp [arg1,arg2] _
220 = stmtC (CmmAssign (CmmLocal res) (CmmMachOp (mo_wordEq dflags) [arg1,arg2]))
221
222 -- #define addrToHValuezh(r,a) r=(P_)a
223 emitPrimOp _ [res] AddrToAnyOp [arg] _
224 = stmtC (CmmAssign (CmmLocal res) arg)
225
226 -- #define dataToTagzh(r,a) r=(GET_TAG(((StgClosure *)a)->header.info))
227 -- Note: argument may be tagged!
228 emitPrimOp dflags [res] DataToTagOp [arg] _
229 = stmtC (CmmAssign (CmmLocal res) (getConstrTag dflags (cmmUntag dflags arg)))
230
231 {- Freezing arrays-of-ptrs requires changing an info table, for the
232 benefit of the generational collector. It needs to scavenge mutable
233 objects, even if they are in old space. When they become immutable,
234 they can be removed from this scavenge list. -}
235
236 -- #define unsafeFreezzeArrayzh(r,a)
237 -- {
238 -- SET_INFO((StgClosure *)a,&stg_MUT_ARR_PTRS_FROZEN0_info);
239 -- r = a;
240 -- }
241 emitPrimOp _ [res] UnsafeFreezeArrayOp [arg] _
242 = stmtsC [ setInfo arg (CmmLit (CmmLabel mkMAP_FROZEN_infoLabel)),
243 CmmAssign (CmmLocal res) arg ]
244 emitPrimOp _ [res] UnsafeFreezeArrayArrayOp [arg] _
245 = stmtsC [ setInfo arg (CmmLit (CmmLabel mkMAP_FROZEN_infoLabel)),
246 CmmAssign (CmmLocal res) arg ]
247
248 -- #define unsafeFreezzeByteArrayzh(r,a) r=(a)
249 emitPrimOp _ [res] UnsafeFreezeByteArrayOp [arg] _
250 = stmtC (CmmAssign (CmmLocal res) arg)
251
252 emitPrimOp _ [] CopyArrayOp [src,src_off,dst,dst_off,n] live =
253 doCopyArrayOp src src_off dst dst_off n live
254 emitPrimOp _ [] CopyMutableArrayOp [src,src_off,dst,dst_off,n] live =
255 doCopyMutableArrayOp src src_off dst dst_off n live
256 emitPrimOp _ [res] CloneArrayOp [src,src_off,n] live =
257 emitCloneArray mkMAP_FROZEN_infoLabel res src src_off n live
258 emitPrimOp _ [res] CloneMutableArrayOp [src,src_off,n] live =
259 emitCloneArray mkMAP_DIRTY_infoLabel res src src_off n live
260 emitPrimOp _ [res] FreezeArrayOp [src,src_off,n] live =
261 emitCloneArray mkMAP_FROZEN_infoLabel res src src_off n live
262 emitPrimOp _ [res] ThawArrayOp [src,src_off,n] live =
263 emitCloneArray mkMAP_DIRTY_infoLabel res src src_off n live
264
265 emitPrimOp _ [] CopyArrayArrayOp [src,src_off,dst,dst_off,n] live =
266 doCopyArrayOp src src_off dst dst_off n live
267 emitPrimOp _ [] CopyMutableArrayArrayOp [src,src_off,dst,dst_off,n] live =
268 doCopyMutableArrayOp src src_off dst dst_off n live
269
270 -- Reading/writing pointer arrays
271
272 emitPrimOp _ [r] ReadArrayOp [obj,ix] _ = doReadPtrArrayOp r obj ix
273 emitPrimOp _ [r] IndexArrayOp [obj,ix] _ = doReadPtrArrayOp r obj ix
274 emitPrimOp _ [] WriteArrayOp [obj,ix,v] _ = doWritePtrArrayOp obj ix v
275
276 emitPrimOp _ [r] IndexArrayArrayOp_ByteArray [obj,ix] _ = doReadPtrArrayOp r obj ix
277 emitPrimOp _ [r] IndexArrayArrayOp_ArrayArray [obj,ix] _ = doReadPtrArrayOp r obj ix
278 emitPrimOp _ [r] ReadArrayArrayOp_ByteArray [obj,ix] _ = doReadPtrArrayOp r obj ix
279 emitPrimOp _ [r] ReadArrayArrayOp_MutableByteArray [obj,ix] _ = doReadPtrArrayOp r obj ix
280 emitPrimOp _ [r] ReadArrayArrayOp_ArrayArray [obj,ix] _ = doReadPtrArrayOp r obj ix
281 emitPrimOp _ [r] ReadArrayArrayOp_MutableArrayArray [obj,ix] _ = doReadPtrArrayOp r obj ix
282 emitPrimOp _ [] WriteArrayArrayOp_ByteArray [obj,ix,v] _ = doWritePtrArrayOp obj ix v
283 emitPrimOp _ [] WriteArrayArrayOp_MutableByteArray [obj,ix,v] _ = doWritePtrArrayOp obj ix v
284 emitPrimOp _ [] WriteArrayArrayOp_ArrayArray [obj,ix,v] _ = doWritePtrArrayOp obj ix v
285 emitPrimOp _ [] WriteArrayArrayOp_MutableArrayArray [obj,ix,v] _ = doWritePtrArrayOp obj ix v
286
287 emitPrimOp dflags [res] SizeofArrayOp [arg] _
288 = stmtC $ CmmAssign (CmmLocal res)
289 (cmmLoadIndexW dflags arg (fixedHdrSize dflags + oFFSET_StgMutArrPtrs_ptrs dflags) (bWord dflags))
290 emitPrimOp dflags [res] SizeofMutableArrayOp [arg] live
291 = emitPrimOp dflags [res] SizeofArrayOp [arg] live
292 emitPrimOp dflags [res] SizeofArrayArrayOp [arg] live
293 = emitPrimOp dflags [res] SizeofArrayOp [arg] live
294 emitPrimOp dflags [res] SizeofMutableArrayArrayOp [arg] live
295 = emitPrimOp dflags [res] SizeofArrayOp [arg] live
296
297 -- IndexXXXoffAddr
298
299 emitPrimOp dflags res IndexOffAddrOp_Char args _ = doIndexOffAddrOp (Just (mo_u_8ToWord dflags)) b8 res args
300 emitPrimOp dflags res IndexOffAddrOp_WideChar args _ = doIndexOffAddrOp (Just (mo_u_32ToWord dflags)) b32 res args
301 emitPrimOp dflags res IndexOffAddrOp_Int args _ = doIndexOffAddrOp Nothing (bWord dflags) res args
302 emitPrimOp dflags res IndexOffAddrOp_Word args _ = doIndexOffAddrOp Nothing (bWord dflags) res args
303 emitPrimOp dflags res IndexOffAddrOp_Addr args _ = doIndexOffAddrOp Nothing (bWord dflags) res args
304 emitPrimOp _ res IndexOffAddrOp_Float args _ = doIndexOffAddrOp Nothing f32 res args
305 emitPrimOp _ res IndexOffAddrOp_Double args _ = doIndexOffAddrOp Nothing f64 res args
306 emitPrimOp dflags res IndexOffAddrOp_StablePtr args _ = doIndexOffAddrOp Nothing (bWord dflags) res args
307 emitPrimOp dflags res IndexOffAddrOp_Int8 args _ = doIndexOffAddrOp (Just (mo_s_8ToWord dflags)) b8 res args
308 emitPrimOp dflags res IndexOffAddrOp_Int16 args _ = doIndexOffAddrOp (Just (mo_s_16ToWord dflags)) b16 res args
309 emitPrimOp dflags res IndexOffAddrOp_Int32 args _ = doIndexOffAddrOp (Just (mo_s_32ToWord dflags)) b32 res args
310 emitPrimOp _ res IndexOffAddrOp_Int64 args _ = doIndexOffAddrOp Nothing b64 res args
311 emitPrimOp dflags res IndexOffAddrOp_Word8 args _ = doIndexOffAddrOp (Just (mo_u_8ToWord dflags)) b8 res args
312 emitPrimOp dflags res IndexOffAddrOp_Word16 args _ = doIndexOffAddrOp (Just (mo_u_16ToWord dflags)) b16 res args
313 emitPrimOp dflags res IndexOffAddrOp_Word32 args _ = doIndexOffAddrOp (Just (mo_u_32ToWord dflags)) b32 res args
314 emitPrimOp _ res IndexOffAddrOp_Word64 args _ = doIndexOffAddrOp Nothing b64 res args
315
316 -- ReadXXXoffAddr, which are identical, for our purposes, to IndexXXXoffAddr.
317
318 emitPrimOp dflags res ReadOffAddrOp_Char args _ = doIndexOffAddrOp (Just (mo_u_8ToWord dflags)) b8 res args
319 emitPrimOp dflags res ReadOffAddrOp_WideChar args _ = doIndexOffAddrOp (Just (mo_u_32ToWord dflags)) b32 res args
320 emitPrimOp dflags res ReadOffAddrOp_Int args _ = doIndexOffAddrOp Nothing (bWord dflags) res args
321 emitPrimOp dflags res ReadOffAddrOp_Word args _ = doIndexOffAddrOp Nothing (bWord dflags) res args
322 emitPrimOp dflags res ReadOffAddrOp_Addr args _ = doIndexOffAddrOp Nothing (bWord dflags) res args
323 emitPrimOp _ res ReadOffAddrOp_Float args _ = doIndexOffAddrOp Nothing f32 res args
324 emitPrimOp _ res ReadOffAddrOp_Double args _ = doIndexOffAddrOp Nothing f64 res args
325 emitPrimOp dflags res ReadOffAddrOp_StablePtr args _ = doIndexOffAddrOp Nothing (bWord dflags) res args
326 emitPrimOp dflags res ReadOffAddrOp_Int8 args _ = doIndexOffAddrOp (Just (mo_s_8ToWord dflags)) b8 res args
327 emitPrimOp dflags res ReadOffAddrOp_Int16 args _ = doIndexOffAddrOp (Just (mo_s_16ToWord dflags)) b16 res args
328 emitPrimOp dflags res ReadOffAddrOp_Int32 args _ = doIndexOffAddrOp (Just (mo_s_32ToWord dflags)) b32 res args
329 emitPrimOp _ res ReadOffAddrOp_Int64 args _ = doIndexOffAddrOp Nothing b64 res args
330 emitPrimOp dflags res ReadOffAddrOp_Word8 args _ = doIndexOffAddrOp (Just (mo_u_8ToWord dflags)) b8 res args
331 emitPrimOp dflags res ReadOffAddrOp_Word16 args _ = doIndexOffAddrOp (Just (mo_u_16ToWord dflags)) b16 res args
332 emitPrimOp dflags res ReadOffAddrOp_Word32 args _ = doIndexOffAddrOp (Just (mo_u_32ToWord dflags)) b32 res args
333 emitPrimOp _ res ReadOffAddrOp_Word64 args _ = doIndexOffAddrOp Nothing b64 res args
334
335 -- IndexXXXArray
336
337 emitPrimOp dflags res IndexByteArrayOp_Char args _ = doIndexByteArrayOp (Just (mo_u_8ToWord dflags)) b8 res args
338 emitPrimOp dflags res IndexByteArrayOp_WideChar args _ = doIndexByteArrayOp (Just (mo_u_32ToWord dflags)) b32 res args
339 emitPrimOp dflags res IndexByteArrayOp_Int args _ = doIndexByteArrayOp Nothing (bWord dflags) res args
340 emitPrimOp dflags res IndexByteArrayOp_Word args _ = doIndexByteArrayOp Nothing (bWord dflags) res args
341 emitPrimOp dflags res IndexByteArrayOp_Addr args _ = doIndexByteArrayOp Nothing (bWord dflags) res args
342 emitPrimOp _ res IndexByteArrayOp_Float args _ = doIndexByteArrayOp Nothing f32 res args
343 emitPrimOp _ res IndexByteArrayOp_Double args _ = doIndexByteArrayOp Nothing f64 res args
344 emitPrimOp dflags res IndexByteArrayOp_StablePtr args _ = doIndexByteArrayOp Nothing (bWord dflags) res args
345 emitPrimOp dflags res IndexByteArrayOp_Int8 args _ = doIndexByteArrayOp (Just (mo_s_8ToWord dflags)) b8 res args
346 emitPrimOp dflags res IndexByteArrayOp_Int16 args _ = doIndexByteArrayOp (Just (mo_s_16ToWord dflags)) b16 res args
347 emitPrimOp dflags res IndexByteArrayOp_Int32 args _ = doIndexByteArrayOp (Just (mo_s_32ToWord dflags)) b32 res args
348 emitPrimOp _ res IndexByteArrayOp_Int64 args _ = doIndexByteArrayOp Nothing b64 res args
349 emitPrimOp dflags res IndexByteArrayOp_Word8 args _ = doIndexByteArrayOp (Just (mo_u_8ToWord dflags)) b8 res args
350 emitPrimOp dflags res IndexByteArrayOp_Word16 args _ = doIndexByteArrayOp (Just (mo_u_16ToWord dflags)) b16 res args
351 emitPrimOp dflags res IndexByteArrayOp_Word32 args _ = doIndexByteArrayOp (Just (mo_u_32ToWord dflags)) b32 res args
352 emitPrimOp _ res IndexByteArrayOp_Word64 args _ = doIndexByteArrayOp Nothing b64 res args
353
354 -- ReadXXXArray, identical to IndexXXXArray.
355
356 emitPrimOp dflags res ReadByteArrayOp_Char args _ = doIndexByteArrayOp (Just (mo_u_8ToWord dflags)) b8 res args
357 emitPrimOp dflags res ReadByteArrayOp_WideChar args _ = doIndexByteArrayOp (Just (mo_u_32ToWord dflags)) b32 res args
358 emitPrimOp dflags res ReadByteArrayOp_Int args _ = doIndexByteArrayOp Nothing (bWord dflags) res args
359 emitPrimOp dflags res ReadByteArrayOp_Word args _ = doIndexByteArrayOp Nothing (bWord dflags) res args
360 emitPrimOp dflags res ReadByteArrayOp_Addr args _ = doIndexByteArrayOp Nothing (bWord dflags) res args
361 emitPrimOp _ res ReadByteArrayOp_Float args _ = doIndexByteArrayOp Nothing f32 res args
362 emitPrimOp _ res ReadByteArrayOp_Double args _ = doIndexByteArrayOp Nothing f64 res args
363 emitPrimOp dflags res ReadByteArrayOp_StablePtr args _ = doIndexByteArrayOp Nothing (bWord dflags) res args
364 emitPrimOp dflags res ReadByteArrayOp_Int8 args _ = doIndexByteArrayOp (Just (mo_s_8ToWord dflags)) b8 res args
365 emitPrimOp dflags res ReadByteArrayOp_Int16 args _ = doIndexByteArrayOp (Just (mo_s_16ToWord dflags)) b16 res args
366 emitPrimOp dflags res ReadByteArrayOp_Int32 args _ = doIndexByteArrayOp (Just (mo_s_32ToWord dflags)) b32 res args
367 emitPrimOp _ res ReadByteArrayOp_Int64 args _ = doIndexByteArrayOp Nothing b64 res args
368 emitPrimOp dflags res ReadByteArrayOp_Word8 args _ = doIndexByteArrayOp (Just (mo_u_8ToWord dflags)) b8 res args
369 emitPrimOp dflags res ReadByteArrayOp_Word16 args _ = doIndexByteArrayOp (Just (mo_u_16ToWord dflags)) b16 res args
370 emitPrimOp dflags res ReadByteArrayOp_Word32 args _ = doIndexByteArrayOp (Just (mo_u_32ToWord dflags)) b32 res args
371 emitPrimOp _ res ReadByteArrayOp_Word64 args _ = doIndexByteArrayOp Nothing b64 res args
372
373 -- WriteXXXoffAddr
374
375 emitPrimOp dflags res WriteOffAddrOp_Char args _ = doWriteOffAddrOp (Just (mo_WordTo8 dflags)) b8 res args
376 emitPrimOp dflags res WriteOffAddrOp_WideChar args _ = doWriteOffAddrOp (Just (mo_WordTo32 dflags)) b32 res args
377 emitPrimOp dflags res WriteOffAddrOp_Int args _ = doWriteOffAddrOp Nothing (bWord dflags) res args
378 emitPrimOp dflags res WriteOffAddrOp_Word args _ = doWriteOffAddrOp Nothing (bWord dflags) res args
379 emitPrimOp dflags res WriteOffAddrOp_Addr args _ = doWriteOffAddrOp Nothing (bWord dflags) res args
380 emitPrimOp _ res WriteOffAddrOp_Float args _ = doWriteOffAddrOp Nothing f32 res args
381 emitPrimOp _ res WriteOffAddrOp_Double args _ = doWriteOffAddrOp Nothing f64 res args
382 emitPrimOp dflags res WriteOffAddrOp_StablePtr args _ = doWriteOffAddrOp Nothing (bWord dflags) res args
383 emitPrimOp dflags res WriteOffAddrOp_Int8 args _ = doWriteOffAddrOp (Just (mo_WordTo8 dflags)) b8 res args
384 emitPrimOp dflags res WriteOffAddrOp_Int16 args _ = doWriteOffAddrOp (Just (mo_WordTo16 dflags)) b16 res args
385 emitPrimOp dflags res WriteOffAddrOp_Int32 args _ = doWriteOffAddrOp (Just (mo_WordTo32 dflags)) b32 res args
386 emitPrimOp _ res WriteOffAddrOp_Int64 args _ = doWriteOffAddrOp Nothing b64 res args
387 emitPrimOp dflags res WriteOffAddrOp_Word8 args _ = doWriteOffAddrOp (Just (mo_WordTo8 dflags)) b8 res args
388 emitPrimOp dflags res WriteOffAddrOp_Word16 args _ = doWriteOffAddrOp (Just (mo_WordTo16 dflags)) b16 res args
389 emitPrimOp dflags res WriteOffAddrOp_Word32 args _ = doWriteOffAddrOp (Just (mo_WordTo32 dflags)) b32 res args
390 emitPrimOp _ res WriteOffAddrOp_Word64 args _ = doWriteOffAddrOp Nothing b64 res args
391
392 -- WriteXXXArray
393
394 emitPrimOp dflags res WriteByteArrayOp_Char args _ = doWriteByteArrayOp (Just (mo_WordTo8 dflags)) b8 res args
395 emitPrimOp dflags res WriteByteArrayOp_WideChar args _ = doWriteByteArrayOp (Just (mo_WordTo32 dflags)) b32 res args
396 emitPrimOp dflags res WriteByteArrayOp_Int args _ = doWriteByteArrayOp Nothing (bWord dflags) res args
397 emitPrimOp dflags res WriteByteArrayOp_Word args _ = doWriteByteArrayOp Nothing (bWord dflags) res args
398 emitPrimOp dflags res WriteByteArrayOp_Addr args _ = doWriteByteArrayOp Nothing (bWord dflags) res args
399 emitPrimOp _ res WriteByteArrayOp_Float args _ = doWriteByteArrayOp Nothing f32 res args
400 emitPrimOp _ res WriteByteArrayOp_Double args _ = doWriteByteArrayOp Nothing f64 res args
401 emitPrimOp dflags res WriteByteArrayOp_StablePtr args _ = doWriteByteArrayOp Nothing (bWord dflags) res args
402 emitPrimOp dflags res WriteByteArrayOp_Int8 args _ = doWriteByteArrayOp (Just (mo_WordTo8 dflags)) b8 res args
403 emitPrimOp dflags res WriteByteArrayOp_Int16 args _ = doWriteByteArrayOp (Just (mo_WordTo16 dflags)) b16 res args
404 emitPrimOp dflags res WriteByteArrayOp_Int32 args _ = doWriteByteArrayOp (Just (mo_WordTo32 dflags)) b32 res args
405 emitPrimOp _ res WriteByteArrayOp_Int64 args _ = doWriteByteArrayOp Nothing b64 res args
406 emitPrimOp dflags res WriteByteArrayOp_Word8 args _ = doWriteByteArrayOp (Just (mo_WordTo8 dflags)) b8 res args
407 emitPrimOp dflags res WriteByteArrayOp_Word16 args _ = doWriteByteArrayOp (Just (mo_WordTo16 dflags)) b16 res args
408 emitPrimOp dflags res WriteByteArrayOp_Word32 args _ = doWriteByteArrayOp (Just (mo_WordTo32 dflags)) b32 res args
409 emitPrimOp _ res WriteByteArrayOp_Word64 args _ = doWriteByteArrayOp Nothing b64 res args
410
411 -- Copying and setting byte arrays
412
413 emitPrimOp _ [] CopyByteArrayOp [src,src_off,dst,dst_off,n] live =
414 doCopyByteArrayOp src src_off dst dst_off n live
415 emitPrimOp _ [] CopyMutableByteArrayOp [src,src_off,dst,dst_off,n] live =
416 doCopyMutableByteArrayOp src src_off dst dst_off n live
417 emitPrimOp _ [] SetByteArrayOp [ba,off,len,c] live =
418 doSetByteArrayOp ba off len c live
419
420 -- Population count.
421 -- The type of the primop takes a Word#, so we have to be careful to narrow
422 -- to the correct width before calling the primop. Otherwise this can result
423 -- in a crash e.g. when calling the helper hs_popcnt8() which assumes that the
424 -- argument is <=0xff.
425 emitPrimOp dflags [res] PopCnt8Op [w] live =
426 emitPopCntCall res (CmmMachOp (mo_WordTo8 dflags) [w]) W8 live
427 emitPrimOp dflags [res] PopCnt16Op [w] live =
428 emitPopCntCall res (CmmMachOp (mo_WordTo16 dflags) [w]) W16 live
429 emitPrimOp dflags [res] PopCnt32Op [w] live =
430 emitPopCntCall res (CmmMachOp (mo_WordTo32 dflags) [w]) W32 live
431 emitPrimOp dflags [res] PopCnt64Op [w] live =
432 emitPopCntCall res (CmmMachOp (mo_WordTo64 dflags) [w]) W64 live
433 emitPrimOp dflags [res] PopCntOp [w] live =
434 emitPopCntCall res w (wordWidth dflags) live
435
436 -- The rest just translate straightforwardly
437 emitPrimOp dflags [res] op [arg] _
438 | nopOp op
439 = stmtC (CmmAssign (CmmLocal res) arg)
440
441 | Just (mop,rep) <- narrowOp op
442 = stmtC (CmmAssign (CmmLocal res) $
443 CmmMachOp (mop rep (wordWidth dflags)) [CmmMachOp (mop (wordWidth dflags) rep) [arg]])
444
445 emitPrimOp dflags [res] op args live
446 | Just prim <- callishOp op
447 = do vols <- getVolatileRegs live
448 emitForeignCall' PlayRisky
449 [CmmHinted res NoHint]
450 (CmmPrim prim Nothing)
451 [CmmHinted a NoHint | a<-args] -- ToDo: hints?
452 (Just vols)
453 NoC_SRT -- No SRT b/c we do PlayRisky
454 CmmMayReturn
455
456 | Just mop <- translateOp dflags op
457 = let stmt = CmmAssign (CmmLocal res) (CmmMachOp mop args) in
458 stmtC stmt
459
460 emitPrimOp dflags [res_q, res_r] IntQuotRemOp [arg_x, arg_y] _
461 = let genericImpl
462 = [CmmAssign (CmmLocal res_q)
463 (CmmMachOp (MO_S_Quot (wordWidth dflags)) [arg_x, arg_y]),
464 CmmAssign (CmmLocal res_r)
465 (CmmMachOp (MO_S_Rem (wordWidth dflags)) [arg_x, arg_y])]
466 stmt = CmmCall (CmmPrim (MO_S_QuotRem (wordWidth dflags)) (Just genericImpl))
467 [CmmHinted res_q NoHint,
468 CmmHinted res_r NoHint]
469 [CmmHinted arg_x NoHint,
470 CmmHinted arg_y NoHint]
471 CmmMayReturn
472 in stmtC stmt
473 emitPrimOp dflags [res_q, res_r] WordQuotRemOp [arg_x, arg_y] _
474 = let genericImpl
475 = [CmmAssign (CmmLocal res_q)
476 (CmmMachOp (MO_U_Quot (wordWidth dflags)) [arg_x, arg_y]),
477 CmmAssign (CmmLocal res_r)
478 (CmmMachOp (MO_U_Rem (wordWidth dflags)) [arg_x, arg_y])]
479 stmt = CmmCall (CmmPrim (MO_U_QuotRem (wordWidth dflags)) (Just genericImpl))
480 [CmmHinted res_q NoHint,
481 CmmHinted res_r NoHint]
482 [CmmHinted arg_x NoHint,
483 CmmHinted arg_y NoHint]
484 CmmMayReturn
485 in stmtC stmt
486 emitPrimOp dflags [res_q, res_r] WordQuotRem2Op [arg_x_high, arg_x_low, arg_y] _
487 = do let ty = cmmExprType dflags arg_x_high
488 shl x i = CmmMachOp (MO_Shl (wordWidth dflags)) [x, i]
489 shr x i = CmmMachOp (MO_U_Shr (wordWidth dflags)) [x, i]
490 or x y = CmmMachOp (MO_Or (wordWidth dflags)) [x, y]
491 ge x y = CmmMachOp (MO_U_Ge (wordWidth dflags)) [x, y]
492 ne x y = CmmMachOp (MO_Ne (wordWidth dflags)) [x, y]
493 minus x y = CmmMachOp (MO_Sub (wordWidth dflags)) [x, y]
494 times x y = CmmMachOp (MO_Mul (wordWidth dflags)) [x, y]
495 zero = lit 0
496 one = lit 1
497 negone = lit (fromIntegral (widthInBits (wordWidth dflags)) - 1)
498 lit i = CmmLit (CmmInt i (wordWidth dflags))
499 f :: Int -> CmmExpr -> CmmExpr -> CmmExpr -> FCode [CmmStmt]
500 f 0 acc high _ = return [CmmAssign (CmmLocal res_q) acc,
501 CmmAssign (CmmLocal res_r) high]
502 f i acc high low =
503 do roverflowedBit <- newLocalReg ty
504 rhigh' <- newLocalReg ty
505 rhigh'' <- newLocalReg ty
506 rlow' <- newLocalReg ty
507 risge <- newLocalReg ty
508 racc' <- newLocalReg ty
509 let high' = CmmReg (CmmLocal rhigh')
510 isge = CmmReg (CmmLocal risge)
511 overflowedBit = CmmReg (CmmLocal roverflowedBit)
512 let this = [CmmAssign (CmmLocal roverflowedBit)
513 (shr high negone),
514 CmmAssign (CmmLocal rhigh')
515 (or (shl high one) (shr low negone)),
516 CmmAssign (CmmLocal rlow')
517 (shl low one),
518 CmmAssign (CmmLocal risge)
519 (or (overflowedBit `ne` zero)
520 (high' `ge` arg_y)),
521 CmmAssign (CmmLocal rhigh'')
522 (high' `minus` (arg_y `times` isge)),
523 CmmAssign (CmmLocal racc')
524 (or (shl acc one) isge)]
525 rest <- f (i - 1) (CmmReg (CmmLocal racc'))
526 (CmmReg (CmmLocal rhigh''))
527 (CmmReg (CmmLocal rlow'))
528 return (this ++ rest)
529 genericImpl <- f (widthInBits (wordWidth dflags)) zero arg_x_high arg_x_low
530 let stmt = CmmCall (CmmPrim (MO_U_QuotRem2 (wordWidth dflags)) (Just genericImpl))
531 [CmmHinted res_q NoHint,
532 CmmHinted res_r NoHint]
533 [CmmHinted arg_x_high NoHint,
534 CmmHinted arg_x_low NoHint,
535 CmmHinted arg_y NoHint]
536 CmmMayReturn
537 stmtC stmt
538
539 emitPrimOp dflags [res_h, res_l] WordAdd2Op [arg_x, arg_y] _
540 = do r1 <- newLocalReg (cmmExprType dflags arg_x)
541 r2 <- newLocalReg (cmmExprType dflags arg_x)
542 -- This generic implementation is very simple and slow. We might
543 -- well be able to do better, but for now this at least works.
544 let genericImpl
545 = [CmmAssign (CmmLocal r1)
546 (add (bottomHalf arg_x) (bottomHalf arg_y)),
547 CmmAssign (CmmLocal r2)
548 (add (topHalf (CmmReg (CmmLocal r1)))
549 (add (topHalf arg_x) (topHalf arg_y))),
550 CmmAssign (CmmLocal res_h)
551 (topHalf (CmmReg (CmmLocal r2))),
552 CmmAssign (CmmLocal res_l)
553 (or (toTopHalf (CmmReg (CmmLocal r2)))
554 (bottomHalf (CmmReg (CmmLocal r1))))]
555 where topHalf x = CmmMachOp (MO_U_Shr (wordWidth dflags)) [x, hww]
556 toTopHalf x = CmmMachOp (MO_Shl (wordWidth dflags)) [x, hww]
557 bottomHalf x = CmmMachOp (MO_And (wordWidth dflags)) [x, hwm]
558 add x y = CmmMachOp (MO_Add (wordWidth dflags)) [x, y]
559 or x y = CmmMachOp (MO_Or (wordWidth dflags)) [x, y]
560 hww = CmmLit (CmmInt (fromIntegral (widthInBits (halfWordWidth dflags)))
561 (wordWidth dflags))
562 hwm = CmmLit (CmmInt (halfWordMask dflags) (wordWidth dflags))
563 stmt = CmmCall (CmmPrim (MO_Add2 (wordWidth dflags)) (Just genericImpl))
564 [CmmHinted res_h NoHint,
565 CmmHinted res_l NoHint]
566 [CmmHinted arg_x NoHint,
567 CmmHinted arg_y NoHint]
568 CmmMayReturn
569 stmtC stmt
570 emitPrimOp dflags [res_h, res_l] WordMul2Op [arg_x, arg_y] _
571 = do let t = cmmExprType dflags arg_x
572 xlyl <- liftM CmmLocal $ newLocalReg t
573 xlyh <- liftM CmmLocal $ newLocalReg t
574 xhyl <- liftM CmmLocal $ newLocalReg t
575 r <- liftM CmmLocal $ newLocalReg t
576 -- This generic implementation is very simple and slow. We might
577 -- well be able to do better, but for now this at least works.
578 let genericImpl
579 = [CmmAssign xlyl
580 (mul (bottomHalf arg_x) (bottomHalf arg_y)),
581 CmmAssign xlyh
582 (mul (bottomHalf arg_x) (topHalf arg_y)),
583 CmmAssign xhyl
584 (mul (topHalf arg_x) (bottomHalf arg_y)),
585 CmmAssign r
586 (sum [topHalf (CmmReg xlyl),
587 bottomHalf (CmmReg xhyl),
588 bottomHalf (CmmReg xlyh)]),
589 CmmAssign (CmmLocal res_l)
590 (or (bottomHalf (CmmReg xlyl))
591 (toTopHalf (CmmReg r))),
592 CmmAssign (CmmLocal res_h)
593 (sum [mul (topHalf arg_x) (topHalf arg_y),
594 topHalf (CmmReg xhyl),
595 topHalf (CmmReg xlyh),
596 topHalf (CmmReg r)])]
597 where topHalf x = CmmMachOp (MO_U_Shr (wordWidth dflags)) [x, hww]
598 toTopHalf x = CmmMachOp (MO_Shl (wordWidth dflags)) [x, hww]
599 bottomHalf x = CmmMachOp (MO_And (wordWidth dflags)) [x, hwm]
600 add x y = CmmMachOp (MO_Add (wordWidth dflags)) [x, y]
601 sum = foldl1 add
602 mul x y = CmmMachOp (MO_Mul (wordWidth dflags)) [x, y]
603 or x y = CmmMachOp (MO_Or (wordWidth dflags)) [x, y]
604 hww = CmmLit (CmmInt (fromIntegral (widthInBits (halfWordWidth dflags)))
605 (wordWidth dflags))
606 hwm = CmmLit (CmmInt (halfWordMask dflags) (wordWidth dflags))
607 stmt = CmmCall (CmmPrim (MO_U_Mul2 (wordWidth dflags)) (Just genericImpl))
608 [CmmHinted res_h NoHint,
609 CmmHinted res_l NoHint]
610 [CmmHinted arg_x NoHint,
611 CmmHinted arg_y NoHint]
612 CmmMayReturn
613 stmtC stmt
614
615 emitPrimOp _ _ op _ _
616 = pprPanic "emitPrimOp: can't translate PrimOp" (ppr op)
617
618 newLocalReg :: CmmType -> FCode LocalReg
619 newLocalReg t = do u <- newUnique
620 return $ LocalReg u t
621
622 -- These PrimOps are NOPs in Cmm
623
624 nopOp :: PrimOp -> Bool
625 nopOp Int2WordOp = True
626 nopOp Word2IntOp = True
627 nopOp Int2AddrOp = True
628 nopOp Addr2IntOp = True
629 nopOp ChrOp = True -- Int# and Char# are rep'd the same
630 nopOp OrdOp = True
631 nopOp _ = False
632
633 -- These PrimOps turn into double casts
634
635 narrowOp :: PrimOp -> Maybe (Width -> Width -> MachOp, Width)
636 narrowOp Narrow8IntOp = Just (MO_SS_Conv, W8)
637 narrowOp Narrow16IntOp = Just (MO_SS_Conv, W16)
638 narrowOp Narrow32IntOp = Just (MO_SS_Conv, W32)
639 narrowOp Narrow8WordOp = Just (MO_UU_Conv, W8)
640 narrowOp Narrow16WordOp = Just (MO_UU_Conv, W16)
641 narrowOp Narrow32WordOp = Just (MO_UU_Conv, W32)
642 narrowOp _ = Nothing
643
644 -- Native word signless ops
645
646 translateOp :: DynFlags -> PrimOp -> Maybe MachOp
647 translateOp dflags IntAddOp = Just (mo_wordAdd dflags)
648 translateOp dflags IntSubOp = Just (mo_wordSub dflags)
649 translateOp dflags WordAddOp = Just (mo_wordAdd dflags)
650 translateOp dflags WordSubOp = Just (mo_wordSub dflags)
651 translateOp dflags AddrAddOp = Just (mo_wordAdd dflags)
652 translateOp dflags AddrSubOp = Just (mo_wordSub dflags)
653
654 translateOp dflags IntEqOp = Just (mo_wordEq dflags)
655 translateOp dflags IntNeOp = Just (mo_wordNe dflags)
656 translateOp dflags WordEqOp = Just (mo_wordEq dflags)
657 translateOp dflags WordNeOp = Just (mo_wordNe dflags)
658 translateOp dflags AddrEqOp = Just (mo_wordEq dflags)
659 translateOp dflags AddrNeOp = Just (mo_wordNe dflags)
660
661 translateOp dflags AndOp = Just (mo_wordAnd dflags)
662 translateOp dflags OrOp = Just (mo_wordOr dflags)
663 translateOp dflags XorOp = Just (mo_wordXor dflags)
664 translateOp dflags NotOp = Just (mo_wordNot dflags)
665 translateOp dflags SllOp = Just (mo_wordShl dflags)
666 translateOp dflags SrlOp = Just (mo_wordUShr dflags)
667
668 translateOp dflags AddrRemOp = Just (mo_wordURem dflags)
669
670 -- Native word signed ops
671
672 translateOp dflags IntMulOp = Just (mo_wordMul dflags)
673 translateOp dflags IntMulMayOfloOp = Just (MO_S_MulMayOflo (wordWidth dflags))
674 translateOp dflags IntQuotOp = Just (mo_wordSQuot dflags)
675 translateOp dflags IntRemOp = Just (mo_wordSRem dflags)
676 translateOp dflags IntNegOp = Just (mo_wordSNeg dflags)
677
678
679 translateOp dflags IntGeOp = Just (mo_wordSGe dflags)
680 translateOp dflags IntLeOp = Just (mo_wordSLe dflags)
681 translateOp dflags IntGtOp = Just (mo_wordSGt dflags)
682 translateOp dflags IntLtOp = Just (mo_wordSLt dflags)
683
684 translateOp dflags ISllOp = Just (mo_wordShl dflags)
685 translateOp dflags ISraOp = Just (mo_wordSShr dflags)
686 translateOp dflags ISrlOp = Just (mo_wordUShr dflags)
687
688 -- Native word unsigned ops
689
690 translateOp dflags WordGeOp = Just (mo_wordUGe dflags)
691 translateOp dflags WordLeOp = Just (mo_wordULe dflags)
692 translateOp dflags WordGtOp = Just (mo_wordUGt dflags)
693 translateOp dflags WordLtOp = Just (mo_wordULt dflags)
694
695 translateOp dflags WordMulOp = Just (mo_wordMul dflags)
696 translateOp dflags WordQuotOp = Just (mo_wordUQuot dflags)
697 translateOp dflags WordRemOp = Just (mo_wordURem dflags)
698
699 translateOp dflags AddrGeOp = Just (mo_wordUGe dflags)
700 translateOp dflags AddrLeOp = Just (mo_wordULe dflags)
701 translateOp dflags AddrGtOp = Just (mo_wordUGt dflags)
702 translateOp dflags AddrLtOp = Just (mo_wordULt dflags)
703
704 -- Char# ops
705
706 translateOp dflags CharEqOp = Just (MO_Eq (wordWidth dflags))
707 translateOp dflags CharNeOp = Just (MO_Ne (wordWidth dflags))
708 translateOp dflags CharGeOp = Just (MO_U_Ge (wordWidth dflags))
709 translateOp dflags CharLeOp = Just (MO_U_Le (wordWidth dflags))
710 translateOp dflags CharGtOp = Just (MO_U_Gt (wordWidth dflags))
711 translateOp dflags CharLtOp = Just (MO_U_Lt (wordWidth dflags))
712
713 -- Double ops
714
715 translateOp _ DoubleEqOp = Just (MO_F_Eq W64)
716 translateOp _ DoubleNeOp = Just (MO_F_Ne W64)
717 translateOp _ DoubleGeOp = Just (MO_F_Ge W64)
718 translateOp _ DoubleLeOp = Just (MO_F_Le W64)
719 translateOp _ DoubleGtOp = Just (MO_F_Gt W64)
720 translateOp _ DoubleLtOp = Just (MO_F_Lt W64)
721
722 translateOp _ DoubleAddOp = Just (MO_F_Add W64)
723 translateOp _ DoubleSubOp = Just (MO_F_Sub W64)
724 translateOp _ DoubleMulOp = Just (MO_F_Mul W64)
725 translateOp _ DoubleDivOp = Just (MO_F_Quot W64)
726 translateOp _ DoubleNegOp = Just (MO_F_Neg W64)
727
728 -- Float ops
729
730 translateOp _ FloatEqOp = Just (MO_F_Eq W32)
731 translateOp _ FloatNeOp = Just (MO_F_Ne W32)
732 translateOp _ FloatGeOp = Just (MO_F_Ge W32)
733 translateOp _ FloatLeOp = Just (MO_F_Le W32)
734 translateOp _ FloatGtOp = Just (MO_F_Gt W32)
735 translateOp _ FloatLtOp = Just (MO_F_Lt W32)
736
737 translateOp _ FloatAddOp = Just (MO_F_Add W32)
738 translateOp _ FloatSubOp = Just (MO_F_Sub W32)
739 translateOp _ FloatMulOp = Just (MO_F_Mul W32)
740 translateOp _ FloatDivOp = Just (MO_F_Quot W32)
741 translateOp _ FloatNegOp = Just (MO_F_Neg W32)
742
743 -- Conversions
744
745 translateOp dflags Int2DoubleOp = Just (MO_SF_Conv (wordWidth dflags) W64)
746 translateOp dflags Double2IntOp = Just (MO_FS_Conv W64 (wordWidth dflags))
747
748 translateOp dflags Int2FloatOp = Just (MO_SF_Conv (wordWidth dflags) W32)
749 translateOp dflags Float2IntOp = Just (MO_FS_Conv W32 (wordWidth dflags))
750
751 translateOp _ Float2DoubleOp = Just (MO_FF_Conv W32 W64)
752 translateOp _ Double2FloatOp = Just (MO_FF_Conv W64 W32)
753
754 -- Word comparisons masquerading as more exotic things.
755
756 translateOp dflags SameMutVarOp = Just (mo_wordEq dflags)
757 translateOp dflags SameMVarOp = Just (mo_wordEq dflags)
758 translateOp dflags SameMutableArrayOp = Just (mo_wordEq dflags)
759 translateOp dflags SameMutableByteArrayOp = Just (mo_wordEq dflags)
760 translateOp dflags SameMutableArrayArrayOp= Just (mo_wordEq dflags)
761 translateOp dflags SameTVarOp = Just (mo_wordEq dflags)
762 translateOp dflags EqStablePtrOp = Just (mo_wordEq dflags)
763
764 translateOp _ _ = Nothing
765
766 -- These primops are implemented by CallishMachOps, because they sometimes
767 -- turn into foreign calls depending on the backend.
768
769 callishOp :: PrimOp -> Maybe CallishMachOp
770 callishOp DoublePowerOp = Just MO_F64_Pwr
771 callishOp DoubleSinOp = Just MO_F64_Sin
772 callishOp DoubleCosOp = Just MO_F64_Cos
773 callishOp DoubleTanOp = Just MO_F64_Tan
774 callishOp DoubleSinhOp = Just MO_F64_Sinh
775 callishOp DoubleCoshOp = Just MO_F64_Cosh
776 callishOp DoubleTanhOp = Just MO_F64_Tanh
777 callishOp DoubleAsinOp = Just MO_F64_Asin
778 callishOp DoubleAcosOp = Just MO_F64_Acos
779 callishOp DoubleAtanOp = Just MO_F64_Atan
780 callishOp DoubleLogOp = Just MO_F64_Log
781 callishOp DoubleExpOp = Just MO_F64_Exp
782 callishOp DoubleSqrtOp = Just MO_F64_Sqrt
783
784 callishOp FloatPowerOp = Just MO_F32_Pwr
785 callishOp FloatSinOp = Just MO_F32_Sin
786 callishOp FloatCosOp = Just MO_F32_Cos
787 callishOp FloatTanOp = Just MO_F32_Tan
788 callishOp FloatSinhOp = Just MO_F32_Sinh
789 callishOp FloatCoshOp = Just MO_F32_Cosh
790 callishOp FloatTanhOp = Just MO_F32_Tanh
791 callishOp FloatAsinOp = Just MO_F32_Asin
792 callishOp FloatAcosOp = Just MO_F32_Acos
793 callishOp FloatAtanOp = Just MO_F32_Atan
794 callishOp FloatLogOp = Just MO_F32_Log
795 callishOp FloatExpOp = Just MO_F32_Exp
796 callishOp FloatSqrtOp = Just MO_F32_Sqrt
797
798 callishOp _ = Nothing
799
800 ------------------------------------------------------------------------------
801 -- Helpers for translating various minor variants of array indexing.
802
803 -- Bytearrays outside the heap; hence non-pointers
804 doIndexOffAddrOp, doIndexByteArrayOp
805 :: Maybe MachOp -> CmmType
806 -> [LocalReg] -> [CmmExpr] -> Code
807 doIndexOffAddrOp maybe_post_read_cast rep [res] [addr,idx]
808 = mkBasicIndexedRead 0 maybe_post_read_cast rep res addr idx
809 doIndexOffAddrOp _ _ _ _
810 = panic "CgPrimOp: doIndexOffAddrOp"
811
812 doIndexByteArrayOp maybe_post_read_cast rep [res] [addr,idx]
813 = do dflags <- getDynFlags
814 mkBasicIndexedRead (arrWordsHdrSize dflags) maybe_post_read_cast rep res addr idx
815 doIndexByteArrayOp _ _ _ _
816 = panic "CgPrimOp: doIndexByteArrayOp"
817
818 doReadPtrArrayOp :: LocalReg -> CmmExpr -> CmmExpr -> Code
819 doReadPtrArrayOp res addr idx
820 = do dflags <- getDynFlags
821 mkBasicIndexedRead (arrPtrsHdrSize dflags) Nothing (gcWord dflags) res addr idx
822
823
824 doWriteOffAddrOp, doWriteByteArrayOp
825 :: Maybe MachOp -> CmmType
826 -> [LocalReg] -> [CmmExpr] -> Code
827 doWriteOffAddrOp maybe_pre_write_cast rep [] [addr,idx,val]
828 = mkBasicIndexedWrite 0 maybe_pre_write_cast rep addr idx val
829 doWriteOffAddrOp _ _ _ _
830 = panic "CgPrimOp: doWriteOffAddrOp"
831
832 doWriteByteArrayOp maybe_pre_write_cast rep [] [addr,idx,val]
833 = do dflags <- getDynFlags
834 mkBasicIndexedWrite (arrWordsHdrSize dflags) maybe_pre_write_cast rep addr idx val
835 doWriteByteArrayOp _ _ _ _
836 = panic "CgPrimOp: doWriteByteArrayOp"
837
838 doWritePtrArrayOp :: CmmExpr -> CmmExpr -> CmmExpr -> Code
839 doWritePtrArrayOp addr idx val
840 = do dflags <- getDynFlags
841 mkBasicIndexedWrite (arrPtrsHdrSize dflags) Nothing (bWord dflags) addr idx val
842 stmtC (setInfo addr (CmmLit (CmmLabel mkMAP_DIRTY_infoLabel)))
843 -- the write barrier. We must write a byte into the mark table:
844 -- bits8[a + header_size + StgMutArrPtrs_size(a) + x >> N]
845 stmtC $ CmmStore (
846 cmmOffsetExpr dflags
847 (cmmOffsetExprW dflags (cmmOffsetB dflags addr (arrPtrsHdrSize dflags))
848 (loadArrPtrsSize dflags addr))
849 (card dflags idx)
850 ) (CmmLit (CmmInt 1 W8))
851
852 loadArrPtrsSize :: DynFlags -> CmmExpr -> CmmExpr
853 loadArrPtrsSize dflags addr = CmmLoad (cmmOffsetB dflags addr off) (bWord dflags)
854 where off = fixedHdrSize dflags * wORD_SIZE + oFFSET_StgMutArrPtrs_ptrs dflags
855
856 mkBasicIndexedRead :: ByteOff -> Maybe MachOp -> CmmType
857 -> LocalReg -> CmmExpr -> CmmExpr -> Code
858 mkBasicIndexedRead off Nothing read_rep res base idx
859 = do dflags <- getDynFlags
860 stmtC (CmmAssign (CmmLocal res) (cmmLoadIndexOffExpr dflags off read_rep base idx))
861 mkBasicIndexedRead off (Just cast) read_rep res base idx
862 = do dflags <- getDynFlags
863 stmtC (CmmAssign (CmmLocal res) (CmmMachOp cast [
864 cmmLoadIndexOffExpr dflags off read_rep base idx]))
865
866 mkBasicIndexedWrite :: ByteOff -> Maybe MachOp -> CmmType
867 -> CmmExpr -> CmmExpr -> CmmExpr -> Code
868 mkBasicIndexedWrite off Nothing write_rep base idx val
869 = do dflags <- getDynFlags
870 stmtC (CmmStore (cmmIndexOffExpr dflags off write_rep base idx) val)
871 mkBasicIndexedWrite off (Just cast) write_rep base idx val
872 = do dflags <- getDynFlags
873 stmtC (CmmStore (cmmIndexOffExpr dflags off write_rep base idx) (CmmMachOp cast [val]))
874
875 -- ----------------------------------------------------------------------------
876 -- Misc utils
877
878 cmmIndexOffExpr :: DynFlags -> ByteOff -> CmmType -> CmmExpr -> CmmExpr -> CmmExpr
879 cmmIndexOffExpr dflags off rep base idx
880 = cmmIndexExpr dflags (typeWidth rep) (cmmOffsetB dflags base off) idx
881
882 cmmLoadIndexOffExpr :: DynFlags -> ByteOff -> CmmType -> CmmExpr -> CmmExpr -> CmmExpr
883 cmmLoadIndexOffExpr dflags off rep base idx
884 = CmmLoad (cmmIndexOffExpr dflags off rep base idx) rep
885
886 setInfo :: CmmExpr -> CmmExpr -> CmmStmt
887 setInfo closure_ptr info_ptr = CmmStore closure_ptr info_ptr
888
889 -- ----------------------------------------------------------------------------
890 -- Copying byte arrays
891
892 -- | Takes a source 'ByteArray#', an offset in the source array, a
893 -- destination 'MutableByteArray#', an offset into the destination
894 -- array, and the number of bytes to copy. Copies the given number of
895 -- bytes from the source array to the destination array.
896 doCopyByteArrayOp :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr
897 -> StgLiveVars -> Code
898 doCopyByteArrayOp = emitCopyByteArray copy
899 where
900 -- Copy data (we assume the arrays aren't overlapping since
901 -- they're of different types)
902 copy _src _dst dst_p src_p bytes live =
903 do dflags <- getDynFlags
904 emitMemcpyCall dst_p src_p bytes (CmmLit (mkIntCLit dflags 1)) live
905
906 -- | Takes a source 'MutableByteArray#', an offset in the source
907 -- array, a destination 'MutableByteArray#', an offset into the
908 -- destination array, and the number of bytes to copy. Copies the
909 -- given number of bytes from the source array to the destination
910 -- array.
911 doCopyMutableByteArrayOp :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr
912 -> StgLiveVars -> Code
913 doCopyMutableByteArrayOp = emitCopyByteArray copy
914 where
915 -- The only time the memory might overlap is when the two arrays
916 -- we were provided are the same array!
917 -- TODO: Optimize branch for common case of no aliasing.
918 copy src dst dst_p src_p bytes live =
919 do dflags <- getDynFlags
920 emitIfThenElse (cmmEqWord dflags src dst)
921 (emitMemmoveCall dst_p src_p bytes (CmmLit (mkIntCLit dflags 1)) live)
922 (emitMemcpyCall dst_p src_p bytes (CmmLit (mkIntCLit dflags 1)) live)
923
924 emitCopyByteArray :: (CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr
925 -> StgLiveVars -> Code)
926 -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr
927 -> StgLiveVars
928 -> Code
929 emitCopyByteArray copy src src_off dst dst_off n live = do
930 dflags <- getDynFlags
931 dst_p <- assignTemp $ cmmOffsetExpr dflags (cmmOffsetB dflags dst (arrWordsHdrSize dflags)) dst_off
932 src_p <- assignTemp $ cmmOffsetExpr dflags (cmmOffsetB dflags src (arrWordsHdrSize dflags)) src_off
933 copy src dst dst_p src_p n live
934
935 -- ----------------------------------------------------------------------------
936 -- Setting byte arrays
937
938 -- | Takes a 'MutableByteArray#', an offset into the array, a length,
939 -- and a byte, and sets each of the selected bytes in the array to the
940 -- character.
941 doSetByteArrayOp :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr
942 -> StgLiveVars -> Code
943 doSetByteArrayOp ba off len c live
944 = do dflags <- getDynFlags
945 p <- assignTemp $ cmmOffsetExpr dflags (cmmOffsetB dflags ba (arrWordsHdrSize dflags)) off
946 emitMemsetCall p c len (CmmLit (mkIntCLit dflags 1)) live
947
948 -- ----------------------------------------------------------------------------
949 -- Copying pointer arrays
950
951 -- EZY: This code has an unusually high amount of assignTemp calls, seen
952 -- nowhere else in the code generator. This is mostly because these
953 -- "primitive" ops result in a surprisingly large amount of code. It
954 -- will likely be worthwhile to optimize what is emitted here, so that
955 -- our optimization passes don't waste time repeatedly optimizing the
956 -- same bits of code.
957
958 -- | Takes a source 'Array#', an offset in the source array, a
959 -- destination 'MutableArray#', an offset into the destination array,
960 -- and the number of elements to copy. Copies the given number of
961 -- elements from the source array to the destination array.
962 doCopyArrayOp :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr
963 -> StgLiveVars -> Code
964 doCopyArrayOp = emitCopyArray copy
965 where
966 -- Copy data (we assume the arrays aren't overlapping since
967 -- they're of different types)
968 copy _src _dst dst_p src_p bytes live =
969 do dflags <- getDynFlags
970 emitMemcpyCall dst_p src_p bytes (CmmLit (mkIntCLit dflags wORD_SIZE)) live
971
972 -- | Takes a source 'MutableArray#', an offset in the source array, a
973 -- destination 'MutableArray#', an offset into the destination array,
974 -- and the number of elements to copy. Copies the given number of
975 -- elements from the source array to the destination array.
976 doCopyMutableArrayOp :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr
977 -> StgLiveVars -> Code
978 doCopyMutableArrayOp = emitCopyArray copy
979 where
980 -- The only time the memory might overlap is when the two arrays
981 -- we were provided are the same array!
982 -- TODO: Optimize branch for common case of no aliasing.
983 copy src dst dst_p src_p bytes live =
984 do dflags <- getDynFlags
985 emitIfThenElse (cmmEqWord dflags src dst)
986 (emitMemmoveCall dst_p src_p bytes (CmmLit (mkIntCLit dflags wORD_SIZE)) live)
987 (emitMemcpyCall dst_p src_p bytes (CmmLit (mkIntCLit dflags wORD_SIZE)) live)
988
989 emitCopyArray :: (CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr
990 -> StgLiveVars -> Code)
991 -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr
992 -> StgLiveVars
993 -> Code
994 emitCopyArray copy src0 src_off0 dst0 dst_off0 n0 live = do
995 dflags <- getDynFlags
996 -- Assign the arguments to temporaries so the code generator can
997 -- calculate liveness for us.
998 src <- assignTemp_ src0
999 src_off <- assignTemp_ src_off0
1000 dst <- assignTemp_ dst0
1001 dst_off <- assignTemp_ dst_off0
1002 n <- assignTemp_ n0
1003
1004 -- Set the dirty bit in the header.
1005 stmtC (setInfo dst (CmmLit (CmmLabel mkMAP_DIRTY_infoLabel)))
1006
1007 dst_elems_p <- assignTemp $ cmmOffsetB dflags dst (arrPtrsHdrSize dflags)
1008 dst_p <- assignTemp $ cmmOffsetExprW dflags dst_elems_p dst_off
1009 src_p <- assignTemp $ cmmOffsetExprW dflags (cmmOffsetB dflags src (arrPtrsHdrSize dflags)) src_off
1010 bytes <- assignTemp $ cmmMulWord dflags n (CmmLit (mkIntCLit dflags wORD_SIZE))
1011
1012 copy src dst dst_p src_p bytes live
1013
1014 -- The base address of the destination card table
1015 dst_cards_p <- assignTemp $ cmmOffsetExprW dflags dst_elems_p (loadArrPtrsSize dflags dst)
1016
1017 emitSetCards dst_off dst_cards_p n live
1018
1019 -- | Takes an info table label, a register to return the newly
1020 -- allocated array in, a source array, an offset in the source array,
1021 -- and the number of elements to copy. Allocates a new array and
1022 -- initializes it form the source array.
1023 emitCloneArray :: CLabel -> CmmFormal -> CmmExpr -> CmmExpr -> CmmExpr
1024 -> StgLiveVars -> Code
1025 emitCloneArray info_p res_r src0 src_off0 n0 live = do
1026 dflags <- getDynFlags
1027 let arrPtrsHdrSizeW dflags = CmmLit $ mkIntCLit dflags $ fixedHdrSize dflags +
1028 (sIZEOF_StgMutArrPtrs_NoHdr dflags `div` wORD_SIZE)
1029 myCapability = cmmSubWord dflags (CmmReg baseReg)
1030 (CmmLit (mkIntCLit dflags (oFFSET_Capability_r dflags)))
1031 -- Assign the arguments to temporaries so the code generator can
1032 -- calculate liveness for us.
1033 src <- assignTemp_ src0
1034 src_off <- assignTemp_ src_off0
1035 n <- assignTemp_ n0
1036
1037 card_bytes <- assignTemp $ cardRoundUp dflags n
1038 size <- assignTemp $ cmmAddWord dflags n (bytesToWordsRoundUp dflags card_bytes)
1039 words <- assignTemp $ cmmAddWord dflags (arrPtrsHdrSizeW dflags) size
1040
1041 arr_r <- newTemp (bWord dflags)
1042 emitAllocateCall arr_r myCapability words live
1043 tickyAllocPrim (CmmLit (mkIntCLit dflags (arrPtrsHdrSize dflags))) (cmmMulWord dflags n (wordSize dflags))
1044 (CmmLit $ mkIntCLit dflags 0)
1045
1046 let arr = CmmReg (CmmLocal arr_r)
1047 emitSetDynHdr arr (CmmLit (CmmLabel info_p)) curCCS
1048 stmtC $ CmmStore (cmmOffsetB dflags arr (fixedHdrSize dflags * wORD_SIZE +
1049 oFFSET_StgMutArrPtrs_ptrs dflags)) n
1050 stmtC $ CmmStore (cmmOffsetB dflags arr (fixedHdrSize dflags * wORD_SIZE +
1051 oFFSET_StgMutArrPtrs_size dflags)) size
1052
1053 dst_p <- assignTemp $ cmmOffsetB dflags arr (arrPtrsHdrSize dflags)
1054 src_p <- assignTemp $ cmmOffsetExprW dflags (cmmOffsetB dflags src (arrPtrsHdrSize dflags))
1055 src_off
1056
1057 emitMemcpyCall dst_p src_p (cmmMulWord dflags n (wordSize dflags))
1058 (CmmLit (mkIntCLit dflags wORD_SIZE)) live
1059
1060 emitMemsetCall (cmmOffsetExprW dflags dst_p n)
1061 (CmmLit (mkIntCLit dflags 1))
1062 card_bytes
1063 (CmmLit (mkIntCLit dflags wORD_SIZE))
1064 live
1065 stmtC $ CmmAssign (CmmLocal res_r) arr
1066
1067 -- | Takes and offset in the destination array, the base address of
1068 -- the card table, and the number of elements affected (*not* the
1069 -- number of cards). Marks the relevant cards as dirty.
1070 emitSetCards :: CmmExpr -> CmmExpr -> CmmExpr -> StgLiveVars -> Code
1071 emitSetCards dst_start dst_cards_start n live = do
1072 dflags <- getDynFlags
1073 start_card <- assignTemp $ card dflags dst_start
1074 emitMemsetCall (cmmAddWord dflags dst_cards_start start_card)
1075 (CmmLit (mkIntCLit dflags 1))
1076 (cardRoundUp dflags n)
1077 (CmmLit (mkIntCLit dflags 1)) -- no alignment (1 byte)
1078 live
1079
1080 -- Convert an element index to a card index
1081 card :: DynFlags -> CmmExpr -> CmmExpr
1082 card dflags i = cmmUShrWord dflags i (CmmLit (mkIntCLit dflags mUT_ARR_PTRS_CARD_BITS))
1083
1084 -- Convert a number of elements to a number of cards, rounding up
1085 cardRoundUp :: DynFlags -> CmmExpr -> CmmExpr
1086 cardRoundUp dflags i = card dflags (cmmAddWord dflags i (CmmLit (mkIntCLit dflags ((1 `shiftL` mUT_ARR_PTRS_CARD_BITS) - 1))))
1087
1088 bytesToWordsRoundUp :: DynFlags -> CmmExpr -> CmmExpr
1089 bytesToWordsRoundUp dflags e
1090 = cmmQuotWord dflags
1091 (cmmAddWord dflags e (CmmLit (mkIntCLit dflags (wORD_SIZE - 1))))
1092 (wordSize dflags)
1093
1094 wordSize :: DynFlags -> CmmExpr
1095 wordSize dflags = CmmLit (mkIntCLit dflags wORD_SIZE)
1096
1097 -- | Emit a call to @memcpy@.
1098 emitMemcpyCall :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> StgLiveVars
1099 -> Code
1100 emitMemcpyCall dst src n align live = do
1101 vols <- getVolatileRegs live
1102 emitForeignCall' PlayRisky
1103 [{-no results-}]
1104 (CmmPrim MO_Memcpy Nothing)
1105 [ (CmmHinted dst AddrHint)
1106 , (CmmHinted src AddrHint)
1107 , (CmmHinted n NoHint)
1108 , (CmmHinted align NoHint)
1109 ]
1110 (Just vols)
1111 NoC_SRT -- No SRT b/c we do PlayRisky
1112 CmmMayReturn
1113
1114 -- | Emit a call to @memmove@.
1115 emitMemmoveCall :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> StgLiveVars
1116 -> Code
1117 emitMemmoveCall dst src n align live = do
1118 vols <- getVolatileRegs live
1119 emitForeignCall' PlayRisky
1120 [{-no results-}]
1121 (CmmPrim MO_Memmove Nothing)
1122 [ (CmmHinted dst AddrHint)
1123 , (CmmHinted src AddrHint)
1124 , (CmmHinted n NoHint)
1125 , (CmmHinted align NoHint)
1126 ]
1127 (Just vols)
1128 NoC_SRT -- No SRT b/c we do PlayRisky
1129 CmmMayReturn
1130
1131 -- | Emit a call to @memset@. The second argument must be a word but
1132 -- its value must fit inside an unsigned char.
1133 emitMemsetCall :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> StgLiveVars
1134 -> Code
1135 emitMemsetCall dst c n align live = do
1136 vols <- getVolatileRegs live
1137 emitForeignCall' PlayRisky
1138 [{-no results-}]
1139 (CmmPrim MO_Memset Nothing)
1140 [ (CmmHinted dst AddrHint)
1141 , (CmmHinted c NoHint)
1142 , (CmmHinted n NoHint)
1143 , (CmmHinted align NoHint)
1144 ]
1145 (Just vols)
1146 NoC_SRT -- No SRT b/c we do PlayRisky
1147 CmmMayReturn
1148
1149 -- | Emit a call to @allocate@.
1150 emitAllocateCall :: LocalReg -> CmmExpr -> CmmExpr -> StgLiveVars -> Code
1151 emitAllocateCall res cap n live = do
1152 vols <- getVolatileRegs live
1153 emitForeignCall' PlayRisky
1154 [CmmHinted res AddrHint]
1155 (CmmCallee allocate CCallConv)
1156 [ (CmmHinted cap AddrHint)
1157 , (CmmHinted n NoHint)
1158 ]
1159 (Just vols)
1160 NoC_SRT -- No SRT b/c we do PlayRisky
1161 CmmMayReturn
1162 where
1163 allocate = CmmLit (CmmLabel (mkForeignLabel (fsLit "allocate") Nothing
1164 ForeignLabelInExternalPackage IsFunction))
1165
1166 emitPopCntCall :: LocalReg -> CmmExpr -> Width -> StgLiveVars -> Code
1167 emitPopCntCall res x width live = do
1168 vols <- getVolatileRegs live
1169 emitForeignCall' PlayRisky
1170 [CmmHinted res NoHint]
1171 (CmmPrim (MO_PopCnt width) Nothing)
1172 [(CmmHinted x NoHint)]
1173 (Just vols)
1174 NoC_SRT -- No SRT b/c we do PlayRisky
1175 CmmMayReturn