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