1 -----------------------------------------------------------------------------
3 -- Stg to C--: primitive operations
5 -- (c) The University of Glasgow 2004-2006
7 -----------------------------------------------------------------------------
13 #include "HsVersions.h"
29 import Type ( Type, tyConAppTyCon )
40 ------------------------------------------------------------------------
41 -- Primitive operations and foreign calls
42 ------------------------------------------------------------------------
44 {- Note [Foreign call results]
45 ~~~~~~~~~~~~~~~~~~~~~~~~~~~
46 A foreign call always returns an unboxed tuple of results, one
47 of which is the state token. This seems to happen even for pure
50 Even if we returned a single result for pure calls, it'd still be
51 right to wrap it in a singleton unboxed tuple, because the result
52 might be a Haskell closure pointer, we don't want to evaluate it. -}
54 ----------------------------------
55 cgOpApp :: StgOp -- The op
56 -> [StgArg] -- Arguments
57 -> Type -- Result type (always an unboxed tuple)
61 cgOpApp (StgFCallOp fcall _) stg_args res_ty
62 = do { (res_regs, res_hints) <- newUnboxedTupleRegs res_ty
63 -- Choose result regs r1, r2
64 -- Note [Foreign call results]
65 ; cgForeignCall res_regs res_hints fcall stg_args
66 -- r1, r2 = foo( x, y )
67 ; emitReturn (map (CmmReg . CmmLocal) res_regs) }
70 -- tagToEnum# is special: we need to pull the constructor
71 -- out of the table, and perform an appropriate return.
73 cgOpApp (StgPrimOp TagToEnumOp) [arg] res_ty
74 = ASSERT(isEnumerationTyCon tycon)
75 do { args' <- getNonVoidArgAmodes [arg]
76 ; let amode = case args' of [amode] -> amode
77 _ -> panic "TagToEnumOp had void arg"
78 ; emitReturn [tagToClosure tycon amode] }
80 -- If you're reading this code in the attempt to figure
81 -- out why the compiler panic'ed here, it is probably because
82 -- you used tagToEnum# in a non-monomorphic setting, e.g.,
83 -- intToTg :: Enum a => Int -> a ; intToTg (I# x#) = tagToEnum# x#
85 tycon = tyConAppTyCon res_ty
87 cgOpApp (StgPrimOp primop) args res_ty
88 | primOpOutOfLine primop
89 = do { cmm_args <- getNonVoidArgAmodes args
90 ; let fun = CmmLit (CmmLabel (mkRtsPrimOpLabel primop))
91 ; emitCall (PrimOpCall, PrimOpReturn) fun cmm_args }
93 | ReturnsPrim VoidRep <- result_info
94 = do cgPrimOp [] primop args
97 | ReturnsPrim rep <- result_info
98 = do res <- newTemp (primRepCmmType rep)
99 cgPrimOp [res] primop args
100 emitReturn [CmmReg (CmmLocal res)]
102 | ReturnsAlg tycon <- result_info, isUnboxedTupleTyCon tycon
103 = do (regs, _hints) <- newUnboxedTupleRegs res_ty
104 cgPrimOp regs primop args
105 emitReturn (map (CmmReg . CmmLocal) regs)
107 | ReturnsAlg tycon <- result_info
108 , isEnumerationTyCon tycon
109 -- c.f. cgExpr (...TagToEnumOp...)
110 = do tag_reg <- newTemp bWord
111 cgPrimOp [tag_reg] primop args
112 emitReturn [tagToClosure tycon
113 (CmmReg (CmmLocal tag_reg))]
115 | otherwise = panic "cgPrimop"
117 result_info = getPrimOpResultInfo primop
119 cgOpApp (StgPrimCallOp primcall) args _res_ty
120 = do { cmm_args <- getNonVoidArgAmodes args
121 ; let fun = CmmLit (CmmLabel (mkPrimCallLabel primcall))
122 ; emitCall (PrimOpCall, PrimOpReturn) fun cmm_args }
124 ---------------------------------------------------
125 cgPrimOp :: [LocalReg] -- where to put the results
127 -> [StgArg] -- arguments
130 cgPrimOp results op args
131 = do arg_exprs <- getNonVoidArgAmodes args
132 emitPrimOp results op arg_exprs
135 ------------------------------------------------------------------------
136 -- Emitting code for a primop
137 ------------------------------------------------------------------------
139 emitPrimOp :: [LocalReg] -- where to put the results
141 -> [CmmExpr] -- arguments
144 -- First we handle various awkward cases specially. The remaining
145 -- easy cases are then handled by translateOp, defined below.
147 emitPrimOp [res_r,res_c] IntAddCOp [aa,bb]
149 With some bit-twiddling, we can define int{Add,Sub}Czh portably in
150 C, and without needing any comparisons. This may not be the
151 fastest way to do it - if you have better code, please send it! --SDM
153 Return : r = a + b, c = 0 if no overflow, 1 on overflow.
155 We currently don't make use of the r value if c is != 0 (i.e.
156 overflow), we just convert to big integers and try again. This
157 could be improved by making r and c the correct values for
158 plugging into a new J#.
160 { r = ((I_)(a)) + ((I_)(b)); \
161 c = ((StgWord)(~(((I_)(a))^((I_)(b))) & (((I_)(a))^r))) \
162 >> (BITS_IN (I_) - 1); \
164 Wading through the mass of bracketry, it seems to reduce to:
165 c = ( (~(a^b)) & (a^r) ) >>unsigned (BITS_IN(I_)-1)
168 = emit $ catAGraphs [
169 mkAssign (CmmLocal res_r) (CmmMachOp mo_wordAdd [aa,bb]),
170 mkAssign (CmmLocal res_c) $
171 CmmMachOp mo_wordUShr [
172 CmmMachOp mo_wordAnd [
173 CmmMachOp mo_wordNot [CmmMachOp mo_wordXor [aa,bb]],
174 CmmMachOp mo_wordXor [aa, CmmReg (CmmLocal res_r)]
176 CmmLit (mkIntCLit (wORD_SIZE_IN_BITS - 1))
181 emitPrimOp [res_r,res_c] IntSubCOp [aa,bb]
183 #define subIntCzh(r,c,a,b) \
184 { r = ((I_)(a)) - ((I_)(b)); \
185 c = ((StgWord)((((I_)(a))^((I_)(b))) & (((I_)(a))^r))) \
186 >> (BITS_IN (I_) - 1); \
189 c = ((a^b) & (a^r)) >>unsigned (BITS_IN(I_)-1)
191 = emit $ catAGraphs [
192 mkAssign (CmmLocal res_r) (CmmMachOp mo_wordSub [aa,bb]),
193 mkAssign (CmmLocal res_c) $
194 CmmMachOp mo_wordUShr [
195 CmmMachOp mo_wordAnd [
196 CmmMachOp mo_wordXor [aa,bb],
197 CmmMachOp mo_wordXor [aa, CmmReg (CmmLocal res_r)]
199 CmmLit (mkIntCLit (wORD_SIZE_IN_BITS - 1))
204 emitPrimOp [res] ParOp [arg]
206 -- for now, just implement this in a C function
207 -- later, we might want to inline it.
210 (CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageId (fsLit "newSpark"))))
211 [(CmmReg (CmmGlobal BaseReg), AddrHint), (arg,AddrHint)]
213 emitPrimOp [res] ReadMutVarOp [mutv]
214 = emit (mkAssign (CmmLocal res) (cmmLoadIndexW mutv fixedHdrSize gcWord))
216 emitPrimOp [] WriteMutVarOp [mutv,var]
218 emit (mkStore (cmmOffsetW mutv fixedHdrSize) var)
221 (CmmLit (CmmLabel mkDirty_MUT_VAR_Label))
222 [(CmmReg (CmmGlobal BaseReg), AddrHint), (mutv,AddrHint)]
224 -- #define sizzeofByteArrayzh(r,a) \
225 -- r = ((StgArrWords *)(a))->bytes
226 emitPrimOp [res] SizeofByteArrayOp [arg]
228 mkAssign (CmmLocal res) (cmmLoadIndexW arg fixedHdrSize bWord)
230 -- #define sizzeofMutableByteArrayzh(r,a) \
231 -- r = ((StgArrWords *)(a))->bytes
232 emitPrimOp [res] SizeofMutableByteArrayOp [arg]
233 = emitPrimOp [res] SizeofByteArrayOp [arg]
236 -- #define touchzh(o) /* nothing */
237 emitPrimOp res@[] TouchOp args@[_arg]
238 = do emitPrimCall res MO_Touch args
240 -- #define byteArrayContentszh(r,a) r = BYTE_ARR_CTS(a)
241 emitPrimOp [res] ByteArrayContents_Char [arg]
242 = emit (mkAssign (CmmLocal res) (cmmOffsetB arg arrWordsHdrSize))
244 -- #define stableNameToIntzh(r,s) (r = ((StgStableName *)s)->sn)
245 emitPrimOp [res] StableNameToIntOp [arg]
246 = emit (mkAssign (CmmLocal res) (cmmLoadIndexW arg fixedHdrSize bWord))
248 -- #define eqStableNamezh(r,sn1,sn2) \
249 -- (r = (((StgStableName *)sn1)->sn == ((StgStableName *)sn2)->sn))
250 emitPrimOp [res] EqStableNameOp [arg1,arg2]
251 = emit (mkAssign (CmmLocal res) (CmmMachOp mo_wordEq [
252 cmmLoadIndexW arg1 fixedHdrSize bWord,
253 cmmLoadIndexW arg2 fixedHdrSize bWord
257 emitPrimOp [res] ReallyUnsafePtrEqualityOp [arg1,arg2]
258 = emit (mkAssign (CmmLocal res) (CmmMachOp mo_wordEq [arg1,arg2]))
260 -- #define addrToHValuezh(r,a) r=(P_)a
261 emitPrimOp [res] AddrToHValueOp [arg]
262 = emit (mkAssign (CmmLocal res) arg)
264 -- #define dataToTagzh(r,a) r=(GET_TAG(((StgClosure *)a)->header.info))
265 -- Note: argument may be tagged!
266 emitPrimOp [res] DataToTagOp [arg]
267 = emit (mkAssign (CmmLocal res) (getConstrTag (cmmUntag arg)))
269 {- Freezing arrays-of-ptrs requires changing an info table, for the
270 benefit of the generational collector. It needs to scavenge mutable
271 objects, even if they are in old space. When they become immutable,
272 they can be removed from this scavenge list. -}
274 -- #define unsafeFreezzeArrayzh(r,a)
276 -- SET_INFO((StgClosure *)a,&stg_MUT_ARR_PTRS_FROZEN0_info);
279 emitPrimOp [res] UnsafeFreezeArrayOp [arg]
281 [ setInfo arg (CmmLit (CmmLabel mkMAP_FROZEN_infoLabel)),
282 mkAssign (CmmLocal res) arg ]
284 -- #define unsafeFreezzeByteArrayzh(r,a) r=(a)
285 emitPrimOp [res] UnsafeFreezeByteArrayOp [arg]
286 = emit (mkAssign (CmmLocal res) arg)
288 -- Copying pointer arrays
290 emitPrimOp [] CopyArrayOp [src,src_off,dst,dst_off,n] =
291 doCopyArrayOp src src_off dst dst_off n
292 emitPrimOp [] CopyMutableArrayOp [src,src_off,dst,dst_off,n] =
293 doCopyMutableArrayOp src src_off dst dst_off n
294 emitPrimOp [res] CloneArrayOp [src,src_off,n] =
295 emitCloneArray mkMAP_FROZEN_infoLabel res src src_off n
296 emitPrimOp [res] CloneMutableArrayOp [src,src_off,n] =
297 emitCloneArray mkMAP_DIRTY_infoLabel res src src_off n
298 emitPrimOp [res] FreezeArrayOp [src,src_off,n] =
299 emitCloneArray mkMAP_FROZEN_infoLabel res src src_off n
300 emitPrimOp [res] ThawArrayOp [src,src_off,n] =
301 emitCloneArray mkMAP_DIRTY_infoLabel res src src_off n
303 -- Reading/writing pointer arrays
305 emitPrimOp [r] ReadArrayOp [obj,ix] = doReadPtrArrayOp r obj ix
306 emitPrimOp [r] IndexArrayOp [obj,ix] = doReadPtrArrayOp r obj ix
307 emitPrimOp [] WriteArrayOp [obj,ix,v] = doWritePtrArrayOp obj ix v
309 emitPrimOp [res] SizeofArrayOp [arg]
310 = emit $ mkAssign (CmmLocal res) (cmmLoadIndexW arg (fixedHdrSize + oFFSET_StgMutArrPtrs_ptrs) bWord)
311 emitPrimOp [res] SizeofMutableArrayOp [arg]
312 = emitPrimOp [res] SizeofArrayOp [arg]
316 emitPrimOp res IndexOffAddrOp_Char args = doIndexOffAddrOp (Just mo_u_8ToWord) b8 res args
317 emitPrimOp res IndexOffAddrOp_WideChar args = doIndexOffAddrOp (Just mo_u_32ToWord) b32 res args
318 emitPrimOp res IndexOffAddrOp_Int args = doIndexOffAddrOp Nothing bWord res args
319 emitPrimOp res IndexOffAddrOp_Word args = doIndexOffAddrOp Nothing bWord res args
320 emitPrimOp res IndexOffAddrOp_Addr args = doIndexOffAddrOp Nothing bWord res args
321 emitPrimOp res IndexOffAddrOp_Float args = doIndexOffAddrOp Nothing f32 res args
322 emitPrimOp res IndexOffAddrOp_Double args = doIndexOffAddrOp Nothing f64 res args
323 emitPrimOp res IndexOffAddrOp_StablePtr args = doIndexOffAddrOp Nothing bWord res args
324 emitPrimOp res IndexOffAddrOp_Int8 args = doIndexOffAddrOp (Just mo_s_8ToWord) b8 res args
325 emitPrimOp res IndexOffAddrOp_Int16 args = doIndexOffAddrOp (Just mo_s_16ToWord) b16 res args
326 emitPrimOp res IndexOffAddrOp_Int32 args = doIndexOffAddrOp (Just mo_s_32ToWord) b32 res args
327 emitPrimOp res IndexOffAddrOp_Int64 args = doIndexOffAddrOp Nothing b64 res args
328 emitPrimOp res IndexOffAddrOp_Word8 args = doIndexOffAddrOp (Just mo_u_8ToWord) b8 res args
329 emitPrimOp res IndexOffAddrOp_Word16 args = doIndexOffAddrOp (Just mo_u_16ToWord) b16 res args
330 emitPrimOp res IndexOffAddrOp_Word32 args = doIndexOffAddrOp (Just mo_u_32ToWord) b32 res args
331 emitPrimOp res IndexOffAddrOp_Word64 args = doIndexOffAddrOp Nothing b64 res args
333 -- ReadXXXoffAddr, which are identical, for our purposes, to IndexXXXoffAddr.
335 emitPrimOp res ReadOffAddrOp_Char args = doIndexOffAddrOp (Just mo_u_8ToWord) b8 res args
336 emitPrimOp res ReadOffAddrOp_WideChar args = doIndexOffAddrOp (Just mo_u_32ToWord) b32 res args
337 emitPrimOp res ReadOffAddrOp_Int args = doIndexOffAddrOp Nothing bWord res args
338 emitPrimOp res ReadOffAddrOp_Word args = doIndexOffAddrOp Nothing bWord res args
339 emitPrimOp res ReadOffAddrOp_Addr args = doIndexOffAddrOp Nothing bWord res args
340 emitPrimOp res ReadOffAddrOp_Float args = doIndexOffAddrOp Nothing f32 res args
341 emitPrimOp res ReadOffAddrOp_Double args = doIndexOffAddrOp Nothing f64 res args
342 emitPrimOp res ReadOffAddrOp_StablePtr args = doIndexOffAddrOp Nothing bWord res args
343 emitPrimOp res ReadOffAddrOp_Int8 args = doIndexOffAddrOp (Just mo_s_8ToWord) b8 res args
344 emitPrimOp res ReadOffAddrOp_Int16 args = doIndexOffAddrOp (Just mo_s_16ToWord) b16 res args
345 emitPrimOp res ReadOffAddrOp_Int32 args = doIndexOffAddrOp (Just mo_s_32ToWord) b32 res args
346 emitPrimOp res ReadOffAddrOp_Int64 args = doIndexOffAddrOp Nothing b64 res args
347 emitPrimOp res ReadOffAddrOp_Word8 args = doIndexOffAddrOp (Just mo_u_8ToWord) b8 res args
348 emitPrimOp res ReadOffAddrOp_Word16 args = doIndexOffAddrOp (Just mo_u_16ToWord) b16 res args
349 emitPrimOp res ReadOffAddrOp_Word32 args = doIndexOffAddrOp (Just mo_u_32ToWord) b32 res args
350 emitPrimOp res ReadOffAddrOp_Word64 args = doIndexOffAddrOp Nothing b64 res args
354 emitPrimOp res IndexByteArrayOp_Char args = doIndexByteArrayOp (Just mo_u_8ToWord) b8 res args
355 emitPrimOp res IndexByteArrayOp_WideChar args = doIndexByteArrayOp (Just mo_u_32ToWord) b32 res args
356 emitPrimOp res IndexByteArrayOp_Int args = doIndexByteArrayOp Nothing bWord res args
357 emitPrimOp res IndexByteArrayOp_Word args = doIndexByteArrayOp Nothing bWord res args
358 emitPrimOp res IndexByteArrayOp_Addr args = doIndexByteArrayOp Nothing bWord res args
359 emitPrimOp res IndexByteArrayOp_Float args = doIndexByteArrayOp Nothing f32 res args
360 emitPrimOp res IndexByteArrayOp_Double args = doIndexByteArrayOp Nothing f64 res args
361 emitPrimOp res IndexByteArrayOp_StablePtr args = doIndexByteArrayOp Nothing bWord res args
362 emitPrimOp res IndexByteArrayOp_Int8 args = doIndexByteArrayOp (Just mo_s_8ToWord) b8 res args
363 emitPrimOp res IndexByteArrayOp_Int16 args = doIndexByteArrayOp (Just mo_s_16ToWord) b16 res args
364 emitPrimOp res IndexByteArrayOp_Int32 args = doIndexByteArrayOp (Just mo_s_32ToWord) b32 res args
365 emitPrimOp res IndexByteArrayOp_Int64 args = doIndexByteArrayOp Nothing b64 res args
366 emitPrimOp res IndexByteArrayOp_Word8 args = doIndexByteArrayOp (Just mo_u_8ToWord) b8 res args
367 emitPrimOp res IndexByteArrayOp_Word16 args = doIndexByteArrayOp (Just mo_u_16ToWord) b16 res args
368 emitPrimOp res IndexByteArrayOp_Word32 args = doIndexByteArrayOp (Just mo_u_32ToWord) b32 res args
369 emitPrimOp res IndexByteArrayOp_Word64 args = doIndexByteArrayOp Nothing b64 res args
371 -- ReadXXXArray, identical to IndexXXXArray.
373 emitPrimOp res ReadByteArrayOp_Char args = doIndexByteArrayOp (Just mo_u_8ToWord) b8 res args
374 emitPrimOp res ReadByteArrayOp_WideChar args = doIndexByteArrayOp (Just mo_u_32ToWord) b32 res args
375 emitPrimOp res ReadByteArrayOp_Int args = doIndexByteArrayOp Nothing bWord res args
376 emitPrimOp res ReadByteArrayOp_Word args = doIndexByteArrayOp Nothing bWord res args
377 emitPrimOp res ReadByteArrayOp_Addr args = doIndexByteArrayOp Nothing bWord res args
378 emitPrimOp res ReadByteArrayOp_Float args = doIndexByteArrayOp Nothing f32 res args
379 emitPrimOp res ReadByteArrayOp_Double args = doIndexByteArrayOp Nothing f64 res args
380 emitPrimOp res ReadByteArrayOp_StablePtr args = doIndexByteArrayOp Nothing bWord res args
381 emitPrimOp res ReadByteArrayOp_Int8 args = doIndexByteArrayOp (Just mo_s_8ToWord) b8 res args
382 emitPrimOp res ReadByteArrayOp_Int16 args = doIndexByteArrayOp (Just mo_s_16ToWord) b16 res args
383 emitPrimOp res ReadByteArrayOp_Int32 args = doIndexByteArrayOp (Just mo_s_32ToWord) b32 res args
384 emitPrimOp res ReadByteArrayOp_Int64 args = doIndexByteArrayOp Nothing b64 res args
385 emitPrimOp res ReadByteArrayOp_Word8 args = doIndexByteArrayOp (Just mo_u_8ToWord) b8 res args
386 emitPrimOp res ReadByteArrayOp_Word16 args = doIndexByteArrayOp (Just mo_u_16ToWord) b16 res args
387 emitPrimOp res ReadByteArrayOp_Word32 args = doIndexByteArrayOp (Just mo_u_32ToWord) b32 res args
388 emitPrimOp res ReadByteArrayOp_Word64 args = doIndexByteArrayOp Nothing b64 res args
392 emitPrimOp res WriteOffAddrOp_Char args = doWriteOffAddrOp (Just mo_WordTo8) res args
393 emitPrimOp res WriteOffAddrOp_WideChar args = doWriteOffAddrOp (Just mo_WordTo32) res args
394 emitPrimOp res WriteOffAddrOp_Int args = doWriteOffAddrOp Nothing res args
395 emitPrimOp res WriteOffAddrOp_Word args = doWriteOffAddrOp Nothing res args
396 emitPrimOp res WriteOffAddrOp_Addr args = doWriteOffAddrOp Nothing res args
397 emitPrimOp res WriteOffAddrOp_Float args = doWriteOffAddrOp Nothing res args
398 emitPrimOp res WriteOffAddrOp_Double args = doWriteOffAddrOp Nothing res args
399 emitPrimOp res WriteOffAddrOp_StablePtr args = doWriteOffAddrOp Nothing res args
400 emitPrimOp res WriteOffAddrOp_Int8 args = doWriteOffAddrOp (Just mo_WordTo8) res args
401 emitPrimOp res WriteOffAddrOp_Int16 args = doWriteOffAddrOp (Just mo_WordTo16) res args
402 emitPrimOp res WriteOffAddrOp_Int32 args = doWriteOffAddrOp (Just mo_WordTo32) res args
403 emitPrimOp res WriteOffAddrOp_Int64 args = doWriteOffAddrOp Nothing res args
404 emitPrimOp res WriteOffAddrOp_Word8 args = doWriteOffAddrOp (Just mo_WordTo8) res args
405 emitPrimOp res WriteOffAddrOp_Word16 args = doWriteOffAddrOp (Just mo_WordTo16) res args
406 emitPrimOp res WriteOffAddrOp_Word32 args = doWriteOffAddrOp (Just mo_WordTo32) res args
407 emitPrimOp res WriteOffAddrOp_Word64 args = doWriteOffAddrOp Nothing res args
411 emitPrimOp res WriteByteArrayOp_Char args = doWriteByteArrayOp (Just mo_WordTo8) res args
412 emitPrimOp res WriteByteArrayOp_WideChar args = doWriteByteArrayOp (Just mo_WordTo32) res args
413 emitPrimOp res WriteByteArrayOp_Int args = doWriteByteArrayOp Nothing res args
414 emitPrimOp res WriteByteArrayOp_Word args = doWriteByteArrayOp Nothing res args
415 emitPrimOp res WriteByteArrayOp_Addr args = doWriteByteArrayOp Nothing res args
416 emitPrimOp res WriteByteArrayOp_Float args = doWriteByteArrayOp Nothing res args
417 emitPrimOp res WriteByteArrayOp_Double args = doWriteByteArrayOp Nothing res args
418 emitPrimOp res WriteByteArrayOp_StablePtr args = doWriteByteArrayOp Nothing res args
419 emitPrimOp res WriteByteArrayOp_Int8 args = doWriteByteArrayOp (Just mo_WordTo8) res args
420 emitPrimOp res WriteByteArrayOp_Int16 args = doWriteByteArrayOp (Just mo_WordTo16) res args
421 emitPrimOp res WriteByteArrayOp_Int32 args = doWriteByteArrayOp (Just mo_WordTo32) res args
422 emitPrimOp res WriteByteArrayOp_Int64 args = doWriteByteArrayOp Nothing res args
423 emitPrimOp res WriteByteArrayOp_Word8 args = doWriteByteArrayOp (Just mo_WordTo8) res args
424 emitPrimOp res WriteByteArrayOp_Word16 args = doWriteByteArrayOp (Just mo_WordTo16) res args
425 emitPrimOp res WriteByteArrayOp_Word32 args = doWriteByteArrayOp (Just mo_WordTo32) res args
426 emitPrimOp res WriteByteArrayOp_Word64 args = doWriteByteArrayOp Nothing res args
429 -- The rest just translate straightforwardly
430 emitPrimOp [res] op [arg]
432 = emit (mkAssign (CmmLocal res) arg)
434 | Just (mop,rep) <- narrowOp op
435 = emit (mkAssign (CmmLocal res) $
436 CmmMachOp (mop rep wordWidth) [CmmMachOp (mop wordWidth rep) [arg]])
438 emitPrimOp r@[res] op args
439 | Just prim <- callishOp op
440 = do emitPrimCall r prim args
442 | Just mop <- translateOp op
443 = let stmt = mkAssign (CmmLocal res) (CmmMachOp mop args) in
447 = pprPanic "emitPrimOp: can't translate PrimOp" (ppr op)
450 -- These PrimOps are NOPs in Cmm
452 nopOp :: PrimOp -> Bool
453 nopOp Int2WordOp = True
454 nopOp Word2IntOp = True
455 nopOp Int2AddrOp = True
456 nopOp Addr2IntOp = True
457 nopOp ChrOp = True -- Int# and Char# are rep'd the same
461 -- These PrimOps turn into double casts
463 narrowOp :: PrimOp -> Maybe (Width -> Width -> MachOp, Width)
464 narrowOp Narrow8IntOp = Just (MO_SS_Conv, W8)
465 narrowOp Narrow16IntOp = Just (MO_SS_Conv, W16)
466 narrowOp Narrow32IntOp = Just (MO_SS_Conv, W32)
467 narrowOp Narrow8WordOp = Just (MO_UU_Conv, W8)
468 narrowOp Narrow16WordOp = Just (MO_UU_Conv, W16)
469 narrowOp Narrow32WordOp = Just (MO_UU_Conv, W32)
472 -- Native word signless ops
474 translateOp :: PrimOp -> Maybe MachOp
475 translateOp IntAddOp = Just mo_wordAdd
476 translateOp IntSubOp = Just mo_wordSub
477 translateOp WordAddOp = Just mo_wordAdd
478 translateOp WordSubOp = Just mo_wordSub
479 translateOp AddrAddOp = Just mo_wordAdd
480 translateOp AddrSubOp = Just mo_wordSub
482 translateOp IntEqOp = Just mo_wordEq
483 translateOp IntNeOp = Just mo_wordNe
484 translateOp WordEqOp = Just mo_wordEq
485 translateOp WordNeOp = Just mo_wordNe
486 translateOp AddrEqOp = Just mo_wordEq
487 translateOp AddrNeOp = Just mo_wordNe
489 translateOp AndOp = Just mo_wordAnd
490 translateOp OrOp = Just mo_wordOr
491 translateOp XorOp = Just mo_wordXor
492 translateOp NotOp = Just mo_wordNot
493 translateOp SllOp = Just mo_wordShl
494 translateOp SrlOp = Just mo_wordUShr
496 translateOp AddrRemOp = Just mo_wordURem
498 -- Native word signed ops
500 translateOp IntMulOp = Just mo_wordMul
501 translateOp IntMulMayOfloOp = Just (MO_S_MulMayOflo wordWidth)
502 translateOp IntQuotOp = Just mo_wordSQuot
503 translateOp IntRemOp = Just mo_wordSRem
504 translateOp IntNegOp = Just mo_wordSNeg
507 translateOp IntGeOp = Just mo_wordSGe
508 translateOp IntLeOp = Just mo_wordSLe
509 translateOp IntGtOp = Just mo_wordSGt
510 translateOp IntLtOp = Just mo_wordSLt
512 translateOp ISllOp = Just mo_wordShl
513 translateOp ISraOp = Just mo_wordSShr
514 translateOp ISrlOp = Just mo_wordUShr
516 -- Native word unsigned ops
518 translateOp WordGeOp = Just mo_wordUGe
519 translateOp WordLeOp = Just mo_wordULe
520 translateOp WordGtOp = Just mo_wordUGt
521 translateOp WordLtOp = Just mo_wordULt
523 translateOp WordMulOp = Just mo_wordMul
524 translateOp WordQuotOp = Just mo_wordUQuot
525 translateOp WordRemOp = Just mo_wordURem
527 translateOp AddrGeOp = Just mo_wordUGe
528 translateOp AddrLeOp = Just mo_wordULe
529 translateOp AddrGtOp = Just mo_wordUGt
530 translateOp AddrLtOp = Just mo_wordULt
534 translateOp CharEqOp = Just (MO_Eq wordWidth)
535 translateOp CharNeOp = Just (MO_Ne wordWidth)
536 translateOp CharGeOp = Just (MO_U_Ge wordWidth)
537 translateOp CharLeOp = Just (MO_U_Le wordWidth)
538 translateOp CharGtOp = Just (MO_U_Gt wordWidth)
539 translateOp CharLtOp = Just (MO_U_Lt wordWidth)
543 translateOp DoubleEqOp = Just (MO_F_Eq W64)
544 translateOp DoubleNeOp = Just (MO_F_Ne W64)
545 translateOp DoubleGeOp = Just (MO_F_Ge W64)
546 translateOp DoubleLeOp = Just (MO_F_Le W64)
547 translateOp DoubleGtOp = Just (MO_F_Gt W64)
548 translateOp DoubleLtOp = Just (MO_F_Lt W64)
550 translateOp DoubleAddOp = Just (MO_F_Add W64)
551 translateOp DoubleSubOp = Just (MO_F_Sub W64)
552 translateOp DoubleMulOp = Just (MO_F_Mul W64)
553 translateOp DoubleDivOp = Just (MO_F_Quot W64)
554 translateOp DoubleNegOp = Just (MO_F_Neg W64)
558 translateOp FloatEqOp = Just (MO_F_Eq W32)
559 translateOp FloatNeOp = Just (MO_F_Ne W32)
560 translateOp FloatGeOp = Just (MO_F_Ge W32)
561 translateOp FloatLeOp = Just (MO_F_Le W32)
562 translateOp FloatGtOp = Just (MO_F_Gt W32)
563 translateOp FloatLtOp = Just (MO_F_Lt W32)
565 translateOp FloatAddOp = Just (MO_F_Add W32)
566 translateOp FloatSubOp = Just (MO_F_Sub W32)
567 translateOp FloatMulOp = Just (MO_F_Mul W32)
568 translateOp FloatDivOp = Just (MO_F_Quot W32)
569 translateOp FloatNegOp = Just (MO_F_Neg W32)
573 translateOp Int2DoubleOp = Just (MO_SF_Conv wordWidth W64)
574 translateOp Double2IntOp = Just (MO_FS_Conv W64 wordWidth)
576 translateOp Int2FloatOp = Just (MO_SF_Conv wordWidth W32)
577 translateOp Float2IntOp = Just (MO_FS_Conv W32 wordWidth)
579 translateOp Float2DoubleOp = Just (MO_FF_Conv W32 W64)
580 translateOp Double2FloatOp = Just (MO_FF_Conv W64 W32)
582 -- Word comparisons masquerading as more exotic things.
584 translateOp SameMutVarOp = Just mo_wordEq
585 translateOp SameMVarOp = Just mo_wordEq
586 translateOp SameMutableArrayOp = Just mo_wordEq
587 translateOp SameMutableByteArrayOp = Just mo_wordEq
588 translateOp SameTVarOp = Just mo_wordEq
589 translateOp EqStablePtrOp = Just mo_wordEq
591 translateOp _ = Nothing
593 -- These primops are implemented by CallishMachOps, because they sometimes
594 -- turn into foreign calls depending on the backend.
596 callishOp :: PrimOp -> Maybe CallishMachOp
597 callishOp DoublePowerOp = Just MO_F64_Pwr
598 callishOp DoubleSinOp = Just MO_F64_Sin
599 callishOp DoubleCosOp = Just MO_F64_Cos
600 callishOp DoubleTanOp = Just MO_F64_Tan
601 callishOp DoubleSinhOp = Just MO_F64_Sinh
602 callishOp DoubleCoshOp = Just MO_F64_Cosh
603 callishOp DoubleTanhOp = Just MO_F64_Tanh
604 callishOp DoubleAsinOp = Just MO_F64_Asin
605 callishOp DoubleAcosOp = Just MO_F64_Acos
606 callishOp DoubleAtanOp = Just MO_F64_Atan
607 callishOp DoubleLogOp = Just MO_F64_Log
608 callishOp DoubleExpOp = Just MO_F64_Exp
609 callishOp DoubleSqrtOp = Just MO_F64_Sqrt
611 callishOp FloatPowerOp = Just MO_F32_Pwr
612 callishOp FloatSinOp = Just MO_F32_Sin
613 callishOp FloatCosOp = Just MO_F32_Cos
614 callishOp FloatTanOp = Just MO_F32_Tan
615 callishOp FloatSinhOp = Just MO_F32_Sinh
616 callishOp FloatCoshOp = Just MO_F32_Cosh
617 callishOp FloatTanhOp = Just MO_F32_Tanh
618 callishOp FloatAsinOp = Just MO_F32_Asin
619 callishOp FloatAcosOp = Just MO_F32_Acos
620 callishOp FloatAtanOp = Just MO_F32_Atan
621 callishOp FloatLogOp = Just MO_F32_Log
622 callishOp FloatExpOp = Just MO_F32_Exp
623 callishOp FloatSqrtOp = Just MO_F32_Sqrt
625 callishOp _ = Nothing
627 ------------------------------------------------------------------------------
628 -- Helpers for translating various minor variants of array indexing.
630 doIndexOffAddrOp :: Maybe MachOp -> CmmType -> [LocalReg] -> [CmmExpr] -> FCode ()
631 doIndexOffAddrOp maybe_post_read_cast rep [res] [addr,idx]
632 = mkBasicIndexedRead 0 maybe_post_read_cast rep res addr idx
633 doIndexOffAddrOp _ _ _ _
634 = panic "CgPrimOp: doIndexOffAddrOp"
636 doIndexByteArrayOp :: Maybe MachOp -> CmmType -> [LocalReg] -> [CmmExpr] -> FCode ()
637 doIndexByteArrayOp maybe_post_read_cast rep [res] [addr,idx]
638 = mkBasicIndexedRead arrWordsHdrSize maybe_post_read_cast rep res addr idx
639 doIndexByteArrayOp _ _ _ _
640 = panic "CgPrimOp: doIndexByteArrayOp"
642 doReadPtrArrayOp :: LocalReg -> CmmExpr -> CmmExpr -> FCode ()
643 doReadPtrArrayOp res addr idx
644 = mkBasicIndexedRead arrPtrsHdrSize Nothing gcWord res addr idx
647 doWriteOffAddrOp :: Maybe MachOp -> [LocalReg] -> [CmmExpr] -> FCode ()
648 doWriteOffAddrOp maybe_pre_write_cast [] [addr,idx,val]
649 = mkBasicIndexedWrite 0 maybe_pre_write_cast addr idx val
650 doWriteOffAddrOp _ _ _
651 = panic "CgPrimOp: doWriteOffAddrOp"
653 doWriteByteArrayOp :: Maybe MachOp -> [LocalReg] -> [CmmExpr] -> FCode ()
654 doWriteByteArrayOp maybe_pre_write_cast [] [addr,idx,val]
655 = mkBasicIndexedWrite arrWordsHdrSize maybe_pre_write_cast addr idx val
656 doWriteByteArrayOp _ _ _
657 = panic "CgPrimOp: doWriteByteArrayOp"
659 doWritePtrArrayOp :: CmmExpr -> CmmExpr -> CmmExpr -> FCode ()
660 doWritePtrArrayOp addr idx val
661 = do mkBasicIndexedWrite arrPtrsHdrSize Nothing addr idx val
662 emit (setInfo addr (CmmLit (CmmLabel mkMAP_DIRTY_infoLabel)))
663 -- the write barrier. We must write a byte into the mark table:
664 -- bits8[a + header_size + StgMutArrPtrs_size(a) + x >> N]
667 (cmmOffsetExprW (cmmOffsetB addr arrPtrsHdrSize)
668 (loadArrPtrsSize addr))
669 (CmmMachOp mo_wordUShr [idx,
670 CmmLit (mkIntCLit mUT_ARR_PTRS_CARD_BITS)])
671 ) (CmmLit (CmmInt 1 W8))
673 loadArrPtrsSize :: CmmExpr -> CmmExpr
674 loadArrPtrsSize addr = CmmLoad (cmmOffsetB addr off) bWord
675 where off = fixedHdrSize*wORD_SIZE + oFFSET_StgMutArrPtrs_ptrs
677 mkBasicIndexedRead :: ByteOff -> Maybe MachOp -> CmmType
678 -> LocalReg -> CmmExpr -> CmmExpr -> FCode ()
679 mkBasicIndexedRead off Nothing read_rep res base idx
680 = emit (mkAssign (CmmLocal res) (cmmLoadIndexOffExpr off read_rep base idx))
681 mkBasicIndexedRead off (Just cast) read_rep res base idx
682 = emit (mkAssign (CmmLocal res) (CmmMachOp cast [
683 cmmLoadIndexOffExpr off read_rep base idx]))
685 mkBasicIndexedWrite :: ByteOff -> Maybe MachOp
686 -> CmmExpr -> CmmExpr -> CmmExpr -> FCode ()
687 mkBasicIndexedWrite off Nothing base idx val
688 = emit (mkStore (cmmIndexOffExpr off (typeWidth (cmmExprType val)) base idx) val)
689 mkBasicIndexedWrite off (Just cast) base idx val
690 = mkBasicIndexedWrite off Nothing base idx (CmmMachOp cast [val])
692 -- ----------------------------------------------------------------------------
695 cmmIndexOffExpr :: ByteOff -> Width -> CmmExpr -> CmmExpr -> CmmExpr
696 cmmIndexOffExpr off width base idx
697 = cmmIndexExpr width (cmmOffsetB base off) idx
699 cmmLoadIndexOffExpr :: ByteOff -> CmmType -> CmmExpr -> CmmExpr -> CmmExpr
700 cmmLoadIndexOffExpr off ty base idx
701 = CmmLoad (cmmIndexOffExpr off (typeWidth ty) base idx) ty
703 setInfo :: CmmExpr -> CmmExpr -> CmmAGraph
704 setInfo closure_ptr info_ptr = mkStore closure_ptr info_ptr
706 -- ----------------------------------------------------------------------------
707 -- Copying pointer arrays
709 -- EZY: This code has an unusually high amount of assignTemp calls, seen
710 -- nowhere else in the code generator. This is mostly because these
711 -- "primitive" ops result in a surprisingly large amount of code. It
712 -- will likely be worthwhile to optimize what is emitted here, so that
713 -- our optimization passes don't waste time repeatedly optimizing the
714 -- same bits of code.
716 -- More closely imitates 'assignTemp' from the old code generator, which
717 -- returns a CmmExpr rather than a LocalReg.
718 assignTempE :: CmmExpr -> FCode CmmExpr
721 return (CmmReg (CmmLocal t))
723 -- | Takes a source 'Array#', an offset in the source array, a
724 -- destination 'MutableArray#', an offset into the destination array,
725 -- and the number of elements to copy. Copies the given number of
726 -- elements from the source array to the destination array.
727 doCopyArrayOp :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr
729 doCopyArrayOp = emitCopyArray copy
731 -- Copy data (we assume the arrays aren't overlapping since
732 -- they're of different types)
733 copy _src _dst = emitMemcpyCall
735 -- | Takes a source 'MutableArray#', an offset in the source array, a
736 -- destination 'MutableArray#', an offset into the destination array,
737 -- and the number of elements to copy. Copies the given number of
738 -- elements from the source array to the destination array.
739 doCopyMutableArrayOp :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr
741 doCopyMutableArrayOp = emitCopyArray copy
743 -- The only time the memory might overlap is when the two arrays
744 -- we were provided are the same array!
745 -- TODO: Optimize branch for common case of no aliasing.
746 copy src dst dst_p src_p bytes = do
747 [moveCall, cpyCall] <- forkAlts [
748 getCode $ emitMemmoveCall dst_p src_p bytes,
749 getCode $ emitMemcpyCall dst_p src_p bytes
751 emit $ mkCmmIfThenElse (cmmEqWord src dst) moveCall cpyCall
753 emitCopyArray :: (CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr
755 -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr
757 emitCopyArray copy src0 src_off0 dst0 dst_off0 n0 = do
758 -- Passed as arguments (be careful)
759 src <- assignTempE src0
760 src_off <- assignTempE src_off0
761 dst <- assignTempE dst0
762 dst_off <- assignTempE dst_off0
765 -- Set the dirty bit in the header.
766 emit (setInfo dst (CmmLit (CmmLabel mkMAP_DIRTY_infoLabel)))
768 dst_elems_p <- assignTempE $ cmmOffsetB dst arrPtrsHdrSize
769 dst_p <- assignTempE $ cmmOffsetExprW dst_elems_p dst_off
770 src_p <- assignTempE $ cmmOffsetExprW (cmmOffsetB src arrPtrsHdrSize) src_off
771 bytes <- assignTempE $ cmmMulWord n (CmmLit (mkIntCLit wORD_SIZE))
773 copy src dst dst_p src_p bytes
775 -- The base address of the destination card table
776 dst_cards_p <- assignTempE $ cmmOffsetExprW dst_elems_p (loadArrPtrsSize dst)
778 emitSetCards dst_off dst_cards_p n
780 -- | Takes an info table label, a register to return the newly
781 -- allocated array in, a source array, an offset in the source array,
782 -- and the number of elements to copy. Allocates a new array and
783 -- initializes it form the source array.
784 emitCloneArray :: CLabel -> CmmFormal -> CmmExpr -> CmmExpr -> CmmExpr
786 emitCloneArray info_p res_r src0 src_off0 n0 = do
787 -- Passed as arguments (be careful)
788 src <- assignTempE src0
789 src_off <- assignTempE src_off0
792 card_words <- assignTempE $ (n `cmmUShrWord`
793 (CmmLit (mkIntCLit mUT_ARR_PTRS_CARD_BITS)))
794 `cmmAddWord` CmmLit (mkIntCLit 1)
795 size <- assignTempE $ n `cmmAddWord` card_words
796 words <- assignTempE $ arrPtrsHdrSizeW `cmmAddWord` size
798 arr_r <- newTemp bWord
799 emitAllocateCall arr_r myCapability words
800 tickyAllocPrim (CmmLit (mkIntCLit arrPtrsHdrSize)) (n `cmmMulWord` wordSize)
801 (CmmLit $ mkIntCLit 0)
803 let arr = CmmReg (CmmLocal arr_r)
804 emitSetDynHdr arr (CmmLit (CmmLabel info_p)) curCCSAddr
805 emit $ mkStore (cmmOffsetB arr (fixedHdrSize * wORD_SIZE +
806 oFFSET_StgMutArrPtrs_ptrs)) n
807 emit $ mkStore (cmmOffsetB arr (fixedHdrSize * wORD_SIZE +
808 oFFSET_StgMutArrPtrs_size)) size
810 dst_p <- assignTempE $ cmmOffsetB arr arrPtrsHdrSize
811 src_p <- assignTempE $ cmmOffsetExprW (cmmOffsetB src arrPtrsHdrSize)
814 emitMemcpyCall dst_p src_p (n `cmmMulWord` wordSize)
816 emitMemsetCall (cmmOffsetExprW dst_p n)
817 (CmmLit (mkIntCLit 1))
818 (card_words `cmmMulWord` wordSize)
819 emit $ mkAssign (CmmLocal res_r) arr
821 arrPtrsHdrSizeW = CmmLit $ mkIntCLit $ fixedHdrSize +
822 (sIZEOF_StgMutArrPtrs_NoHdr `div` wORD_SIZE)
823 wordSize = CmmLit (mkIntCLit wORD_SIZE)
824 myCapability = CmmReg baseReg `cmmSubWord`
825 CmmLit (mkIntCLit oFFSET_Capability_r)
827 -- | Takes and offset in the destination array, the base address of
828 -- the card table, and the number of elements affected (*not* the
829 -- number of cards). Marks the relevant cards as dirty.
830 emitSetCards :: CmmExpr -> CmmExpr -> CmmExpr -> FCode ()
831 emitSetCards dst_start dst_cards_start n = do
832 start_card <- assignTempE $ card dst_start
833 emitMemsetCall (dst_cards_start `cmmAddWord` start_card)
834 (CmmLit (mkIntCLit 1))
835 ((card (dst_start `cmmAddWord` n) `cmmSubWord` start_card)
836 `cmmAddWord` CmmLit (mkIntCLit 1))
838 -- Convert an element index to a card index
839 card i = i `cmmUShrWord` (CmmLit (mkIntCLit mUT_ARR_PTRS_CARD_BITS))
841 -- | Emit a call to @memcpy@.
842 emitMemcpyCall :: CmmExpr -> CmmExpr -> CmmExpr -> FCode ()
843 emitMemcpyCall dst src n = do
852 memcpy = CmmLit (CmmLabel (mkForeignLabel (fsLit "memcpy") Nothing
853 ForeignLabelInExternalPackage IsFunction))
855 -- | Emit a call to @memmove@.
856 emitMemmoveCall :: CmmExpr -> CmmExpr -> CmmExpr -> FCode ()
857 emitMemmoveCall dst src n = do
866 memmove = CmmLit (CmmLabel (mkForeignLabel (fsLit "memmove") Nothing
867 ForeignLabelInExternalPackage IsFunction))
869 -- | Emit a call to @memset@. The second argument must fit inside an
871 emitMemsetCall :: CmmExpr -> CmmExpr -> CmmExpr -> FCode ()
872 emitMemsetCall dst c n = do
881 memset = CmmLit (CmmLabel (mkForeignLabel (fsLit "memset") Nothing
882 ForeignLabelInExternalPackage IsFunction))
884 -- | Emit a call to @allocate@.
885 emitAllocateCall :: LocalReg -> CmmExpr -> CmmExpr -> FCode ()
886 emitAllocateCall res cap n = do
894 allocate = CmmLit (CmmLabel (mkForeignLabel (fsLit "allocate") Nothing
895 ForeignLabelInExternalPackage IsFunction))