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