root/compiler/codeGen/CgPrimOp.hs

Revision 8c705e997879068b51b15761fe80c1d7f27766b0, 50.6 KB (checked in by Ian Lynagh <igloo@…>, 7 hours ago)

Add a setByteArray# primop

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