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