StgCmmPrim.hs 55.8 KB
Newer Older
1
2
3
4
5
6
7
8
-----------------------------------------------------------------------------
--
-- Stg to C--: primitive operations
--
-- (c) The University of Glasgow 2004-2006
--
-----------------------------------------------------------------------------

Ian Lynagh's avatar
Ian Lynagh committed
9
10
11
12
13
14
15
{-# OPTIONS -fno-warn-tabs #-}
-- The above warning supression flag is a temporary kludge.
-- While working on this module you are encouraged to remove it and
-- detab the module (please do the detabbing in a separate patch). See
--     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces
-- for details

16
module StgCmmPrim (
17
18
19
   cgOpApp,
   cgPrimOp -- internal(ish), used by cgCase to get code for a
            -- comparison without also turning it into a Bool.
20
21
22
23
24
25
26
27
28
 ) where

#include "HsVersions.h"

import StgCmmLayout
import StgCmmForeign
import StgCmmEnv
import StgCmmMonad
import StgCmmUtils
29
30
31
import StgCmmTicky
import StgCmmHeap
import StgCmmProf
32

33
34
import DynFlags
import Platform
35
import BasicTypes
36
import MkGraph
37
import StgSyn
38
import Cmm
39
40
41
42
43
44
import Type	( Type, tyConAppTyCon )
import TyCon
import CLabel
import CmmUtils
import PrimOp
import SMRep
45
import Module
46
47
import FastString
import Outputable
48
import Util
49

50
import Control.Monad (liftM)
51
import Data.Bits
52

53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
------------------------------------------------------------------------
--	Primitive operations and foreign calls
------------------------------------------------------------------------

{- Note [Foreign call results]
   ~~~~~~~~~~~~~~~~~~~~~~~~~~~
A foreign call always returns an unboxed tuple of results, one
of which is the state token.  This seems to happen even for pure
calls. 

Even if we returned a single result for pure calls, it'd still be
right to wrap it in a singleton unboxed tuple, because the result
might be a Haskell closure pointer, we don't want to evaluate it. -}

----------------------------------
cgOpApp :: StgOp	-- The op
	-> [StgArg]	-- Arguments
	-> Type		-- Result type (always an unboxed tuple)
71
        -> FCode ReturnKind
72
73
74

-- Foreign calls 
cgOpApp (StgFCallOp fcall _) stg_args res_ty 
75
76
77
  = cgForeignCall fcall stg_args res_ty
      -- Note [Foreign call results]

78
79
80
81
82
-- tagToEnum# is special: we need to pull the constructor 
-- out of the table, and perform an appropriate return.

cgOpApp (StgPrimOp TagToEnumOp) [arg] res_ty 
  = ASSERT(isEnumerationTyCon tycon)
83
84
    do	{ dflags <- getDynFlags
        ; args' <- getNonVoidArgAmodes [arg]
85
86
        ; let amode = case args' of [amode] -> amode
                                    _ -> panic "TagToEnumOp had void arg"
87
	; emitReturn [tagToClosure dflags tycon amode] }
88
89
90
91
92
93
94
95
96
97
98
   where
	  -- If you're reading this code in the attempt to figure
	  -- out why the compiler panic'ed here, it is probably because
	  -- you used tagToEnum# in a non-monomorphic setting, e.g., 
	  --         intToTg :: Enum a => Int -> a ; intToTg (I# x#) = tagToEnum# x#
	  -- That won't work.
	tycon = tyConAppTyCon res_ty

cgOpApp (StgPrimOp primop) args res_ty
  | primOpOutOfLine primop
  = do	{ cmm_args <- getNonVoidArgAmodes args
99
        ; let fun = CmmLit (CmmLabel (mkRtsPrimOpLabel primop))
100
        ; emitCall (NativeNodeCall, NativeReturn) fun cmm_args }
101
102
103
104
105
106

  | ReturnsPrim VoidRep <- result_info
  = do cgPrimOp [] primop args 
       emitReturn []

  | ReturnsPrim rep <- result_info
107
108
  = do dflags <- getDynFlags
       res <- newTemp (primRepCmmType dflags rep)
109
110
111
112
113
114
115
116
117
118
119
       cgPrimOp [res] primop args 
       emitReturn [CmmReg (CmmLocal res)]

  | ReturnsAlg tycon <- result_info, isUnboxedTupleTyCon tycon
  = do (regs, _hints) <- newUnboxedTupleRegs res_ty
       cgPrimOp regs primop args
       emitReturn (map (CmmReg . CmmLocal) regs)

  | ReturnsAlg tycon <- result_info
  , isEnumerationTyCon tycon
	-- c.f. cgExpr (...TagToEnumOp...)
120
121
122
123
124
  = do dflags <- getDynFlags
       tag_reg <- newTemp (bWord dflags)
       cgPrimOp [tag_reg] primop args
       emitReturn [tagToClosure dflags tycon
                                (CmmReg (CmmLocal tag_reg))]
125
126
127
128
129

  | otherwise = panic "cgPrimop"
  where
     result_info = getPrimOpResultInfo primop

130
131
132
cgOpApp (StgPrimCallOp primcall) args _res_ty
  = do	{ cmm_args <- getNonVoidArgAmodes args
        ; let fun = CmmLit (CmmLabel (mkPrimCallLabel primcall))
133
        ; emitCall (NativeNodeCall, NativeReturn) fun cmm_args }
134

135
136
137
138
139
140
141
---------------------------------------------------
cgPrimOp   :: [LocalReg]	-- where to put the results
	   -> PrimOp		-- the op
	   -> [StgArg]		-- arguments
	   -> FCode ()

cgPrimOp results op args
142
143
144
  = do dflags <- getDynFlags
       arg_exprs <- getNonVoidArgAmodes args
       emitPrimOp dflags results op arg_exprs
145
146
147
148
149
150


------------------------------------------------------------------------
--	Emitting code for a primop
------------------------------------------------------------------------

151
152
emitPrimOp :: DynFlags
           -> [LocalReg]	-- where to put the results
153
154
155
156
157
158
159
	   -> PrimOp		-- the op
	   -> [CmmExpr]		-- arguments
	   -> FCode ()

-- First we handle various awkward cases specially.  The remaining
-- easy cases are then handled by translateOp, defined below.

160
emitPrimOp dflags [res_r,res_c] IntAddCOp [aa,bb]
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
{- 
   With some bit-twiddling, we can define int{Add,Sub}Czh portably in
   C, and without needing any comparisons.  This may not be the
   fastest way to do it - if you have better code, please send it! --SDM
  
   Return : r = a + b,  c = 0 if no overflow, 1 on overflow.
  
   We currently don't make use of the r value if c is != 0 (i.e. 
   overflow), we just convert to big integers and try again.  This
   could be improved by making r and c the correct values for
   plugging into a new J#.  
   
   { r = ((I_)(a)) + ((I_)(b));					\
     c = ((StgWord)(~(((I_)(a))^((I_)(b))) & (((I_)(a))^r)))	\
         >> (BITS_IN (I_) - 1);					\
   } 
   Wading through the mass of bracketry, it seems to reduce to:
   c = ( (~(a^b)) & (a^r) ) >>unsigned (BITS_IN(I_)-1)

-}
   = emit $ catAGraphs [
182
        mkAssign (CmmLocal res_r) (CmmMachOp (mo_wordAdd dflags) [aa,bb]),
183
        mkAssign (CmmLocal res_c) $
184
185
186
187
	  CmmMachOp (mo_wordUShr dflags) [
		CmmMachOp (mo_wordAnd dflags) [
		    CmmMachOp (mo_wordNot dflags) [CmmMachOp (mo_wordXor dflags) [aa,bb]],
		    CmmMachOp (mo_wordXor dflags) [aa, CmmReg (CmmLocal res_r)]
188
		], 
189
                mkIntExpr dflags (wORD_SIZE_IN_BITS dflags - 1)
190
191
192
193
	  ]
     ]


194
emitPrimOp dflags [res_r,res_c] IntSubCOp [aa,bb]
195
196
197
198
199
200
201
202
203
204
{- Similarly:
   #define subIntCzh(r,c,a,b)					\
   { r = ((I_)(a)) - ((I_)(b));					\
     c = ((StgWord)((((I_)(a))^((I_)(b))) & (((I_)(a))^r)))	\
         >> (BITS_IN (I_) - 1);					\
   }

   c =  ((a^b) & (a^r)) >>unsigned (BITS_IN(I_)-1)
-}
   = emit $ catAGraphs [
205
        mkAssign (CmmLocal res_r) (CmmMachOp (mo_wordSub dflags) [aa,bb]),
206
        mkAssign (CmmLocal res_c) $
207
208
209
210
	  CmmMachOp (mo_wordUShr dflags) [
		CmmMachOp (mo_wordAnd dflags) [
		    CmmMachOp (mo_wordXor dflags) [aa,bb],
		    CmmMachOp (mo_wordXor dflags) [aa, CmmReg (CmmLocal res_r)]
211
		], 
212
                mkIntExpr dflags (wORD_SIZE_IN_BITS dflags - 1)
213
214
215
216
	  ]
     ]


217
emitPrimOp _ [res] ParOp [arg]
218
219
220
221
222
  = 
	-- for now, just implement this in a C function
	-- later, we might want to inline it.
    emitCCall
	[(res,NoHint)]
223
    	(CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageId (fsLit "newSpark"))))
224
225
	[(CmmReg (CmmGlobal BaseReg), AddrHint), (arg,AddrHint)] 

226
emitPrimOp dflags [res] SparkOp [arg]
227
228
229
230
231
  = do
        -- returns the value of arg in res.  We're going to therefore
        -- refer to arg twice (once to pass to newSpark(), and once to
        -- assign to res), so put it in a temporary.
        tmp <- assignTemp arg
232
        tmp2 <- newTemp (bWord dflags)
233
        emitCCall
234
            [(tmp2,NoHint)]
235
236
            (CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageId (fsLit "newSpark"))))
            [(CmmReg (CmmGlobal BaseReg), AddrHint), ((CmmReg (CmmLocal tmp)), AddrHint)]
237
        emitAssign (CmmLocal res) (CmmReg (CmmLocal tmp))
238

239
240
emitPrimOp dflags [res] GetCCSOfOp [arg]
  = emitAssign (CmmLocal res) val
241
  where
242
    val
243
244
     | dopt Opt_SccProfilingOn dflags = costCentreFrom dflags (cmmUntag dflags arg)
     | otherwise                      = CmmLit (zeroCLit dflags)
245

246
emitPrimOp _ [res] GetCurrentCCSOp [_dummy_arg]
247
   = emitAssign (CmmLocal res) curCCS
248

249
emitPrimOp dflags [res] ReadMutVarOp [mutv]
250
   = emitAssign (CmmLocal res) (cmmLoadIndexW dflags mutv (fixedHdrSize dflags) (gcWord dflags))
251

252
253
emitPrimOp dflags [] WriteMutVarOp [mutv,var]
   = do emitStore (cmmOffsetW dflags mutv (fixedHdrSize dflags)) var
254
255
256
257
258
259
	emitCCall
		[{-no results-}]
		(CmmLit (CmmLabel mkDirty_MUT_VAR_Label))
		[(CmmReg (CmmGlobal BaseReg), AddrHint), (mutv,AddrHint)]

--  #define sizzeofByteArrayzh(r,a) \
260
--     r = ((StgArrWords *)(a))->bytes
261
262
emitPrimOp dflags [res] SizeofByteArrayOp [arg]
   = emit $ mkAssign (CmmLocal res) (cmmLoadIndexW dflags arg (fixedHdrSize dflags) (bWord dflags))
263
264

--  #define sizzeofMutableByteArrayzh(r,a) \
265
--      r = ((StgArrWords *)(a))->bytes
266
267
emitPrimOp dflags [res] SizeofMutableByteArrayOp [arg]
   = emitPrimOp dflags [res] SizeofByteArrayOp [arg]
268
269
270


--  #define touchzh(o)                  /* nothing */
271
emitPrimOp _ res@[] TouchOp args@[_arg]
272
   = do emitPrimCall res MO_Touch args
273
274

--  #define byteArrayContentszh(r,a) r = BYTE_ARR_CTS(a)
275
276
emitPrimOp dflags [res] ByteArrayContents_Char [arg]
   = emitAssign (CmmLocal res) (cmmOffsetB dflags arg (arrWordsHdrSize dflags))
277
278

--  #define stableNameToIntzh(r,s)   (r = ((StgStableName *)s)->sn)
279
280
emitPrimOp dflags [res] StableNameToIntOp [arg]
   = emitAssign (CmmLocal res) (cmmLoadIndexW dflags arg (fixedHdrSize dflags) (bWord dflags))
281
282
283

--  #define eqStableNamezh(r,sn1,sn2)					\
--    (r = (((StgStableName *)sn1)->sn == ((StgStableName *)sn2)->sn))
284
emitPrimOp dflags [res] EqStableNameOp [arg1,arg2]
285
   = emitAssign (CmmLocal res) (CmmMachOp (mo_wordEq dflags) [
286
287
                                   cmmLoadIndexW dflags arg1 (fixedHdrSize dflags) (bWord dflags),
                                   cmmLoadIndexW dflags arg2 (fixedHdrSize dflags) (bWord dflags)
288
                         ])
289
290


291
292
emitPrimOp dflags [res] ReallyUnsafePtrEqualityOp [arg1,arg2]
   = emitAssign (CmmLocal res) (CmmMachOp (mo_wordEq dflags) [arg1,arg2])
293
294

--  #define addrToHValuezh(r,a) r=(P_)a
295
emitPrimOp _      [res] AddrToAnyOp [arg]
296
   = emitAssign (CmmLocal res) arg
297
298
299

--  #define dataToTagzh(r,a)  r=(GET_TAG(((StgClosure *)a)->header.info))
--  Note: argument may be tagged!
300
emitPrimOp dflags [res] DataToTagOp [arg]
301
   = emitAssign (CmmLocal res) (getConstrTag dflags (cmmUntag dflags arg))
302
303
304
305
306
307
308
309
310
311
312

{- Freezing arrays-of-ptrs requires changing an info table, for the
   benefit of the generational collector.  It needs to scavenge mutable
   objects, even if they are in old space.  When they become immutable,
   they can be removed from this scavenge list.	 -}

--  #define unsafeFreezzeArrayzh(r,a)
--	{
--        SET_INFO((StgClosure *)a,&stg_MUT_ARR_PTRS_FROZEN0_info);
--	  r = a;
--	}
313
emitPrimOp _      [res] UnsafeFreezeArrayOp [arg]
314
   = emit $ catAGraphs
315
316
   [ setInfo arg (CmmLit (CmmLabel mkMAP_FROZEN_infoLabel)),
     mkAssign (CmmLocal res) arg ]
317
emitPrimOp _      [res] UnsafeFreezeArrayArrayOp [arg]
318
319
320
   = emit $ catAGraphs
   [ setInfo arg (CmmLit (CmmLabel mkMAP_FROZEN_infoLabel)),
     mkAssign (CmmLocal res) arg ]
321
322

--  #define unsafeFreezzeByteArrayzh(r,a)	r=(a)
323
emitPrimOp _      [res] UnsafeFreezeByteArrayOp [arg]
324
   = emitAssign (CmmLocal res) arg
325

326
327
-- Copying pointer arrays

328
emitPrimOp _      [] CopyArrayOp [src,src_off,dst,dst_off,n] =
329
    doCopyArrayOp src src_off dst dst_off n
330
emitPrimOp _      [] CopyMutableArrayOp [src,src_off,dst,dst_off,n] =
331
    doCopyMutableArrayOp src src_off dst dst_off n
332
emitPrimOp _      [res] CloneArrayOp [src,src_off,n] =
333
    emitCloneArray mkMAP_FROZEN_infoLabel res src src_off n
334
emitPrimOp _      [res] CloneMutableArrayOp [src,src_off,n] =
335
    emitCloneArray mkMAP_DIRTY_infoLabel res src src_off n
336
emitPrimOp _      [res] FreezeArrayOp [src,src_off,n] =
337
    emitCloneArray mkMAP_FROZEN_infoLabel res src src_off n
338
emitPrimOp _      [res] ThawArrayOp [src,src_off,n] =
339
340
    emitCloneArray mkMAP_DIRTY_infoLabel res src src_off n

341
emitPrimOp _      [] CopyArrayArrayOp [src,src_off,dst,dst_off,n] =
342
    doCopyArrayOp src src_off dst dst_off n
343
emitPrimOp _      [] CopyMutableArrayArrayOp [src,src_off,dst,dst_off,n] =
344
345
    doCopyMutableArrayOp src src_off dst dst_off n

346
347
-- Reading/writing pointer arrays

348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
emitPrimOp _      [res] ReadArrayOp  [obj,ix]    = doReadPtrArrayOp res obj ix
emitPrimOp _      [res] IndexArrayOp [obj,ix]    = doReadPtrArrayOp res obj ix
emitPrimOp _      []  WriteArrayOp [obj,ix,v]  = doWritePtrArrayOp obj ix v

emitPrimOp _      [res] IndexArrayArrayOp_ByteArray         [obj,ix]   = doReadPtrArrayOp res obj ix
emitPrimOp _      [res] IndexArrayArrayOp_ArrayArray        [obj,ix]   = doReadPtrArrayOp res obj ix
emitPrimOp _      [res] ReadArrayArrayOp_ByteArray          [obj,ix]   = doReadPtrArrayOp res obj ix
emitPrimOp _      [res] ReadArrayArrayOp_MutableByteArray   [obj,ix]   = doReadPtrArrayOp res obj ix
emitPrimOp _      [res] ReadArrayArrayOp_ArrayArray         [obj,ix]   = doReadPtrArrayOp res obj ix
emitPrimOp _      [res] ReadArrayArrayOp_MutableArrayArray  [obj,ix]   = doReadPtrArrayOp res obj ix
emitPrimOp _      []  WriteArrayArrayOp_ByteArray         [obj,ix,v] = doWritePtrArrayOp obj ix v
emitPrimOp _      []  WriteArrayArrayOp_MutableByteArray  [obj,ix,v] = doWritePtrArrayOp obj ix v
emitPrimOp _      []  WriteArrayArrayOp_ArrayArray        [obj,ix,v] = doWritePtrArrayOp obj ix v
emitPrimOp _      []  WriteArrayArrayOp_MutableArrayArray [obj,ix,v] = doWritePtrArrayOp obj ix v

emitPrimOp dflags [res] SizeofArrayOp [arg]
364
   = emit $ mkAssign (CmmLocal res) (cmmLoadIndexW dflags arg (fixedHdrSize dflags + oFFSET_StgMutArrPtrs_ptrs dflags) (bWord dflags))
365
366
367
368
369
370
emitPrimOp dflags [res] SizeofMutableArrayOp [arg]
   = emitPrimOp dflags [res] SizeofArrayOp [arg]
emitPrimOp dflags [res] SizeofArrayArrayOp [arg]
   = emitPrimOp dflags [res] SizeofArrayOp [arg]
emitPrimOp dflags [res] SizeofMutableArrayArrayOp [arg]
   = emitPrimOp dflags [res] SizeofArrayOp [arg]
pumpkin's avatar
pumpkin committed
371

372
373
-- IndexXXXoffAddr

374
375
emitPrimOp dflags res IndexOffAddrOp_Char      args = doIndexOffAddrOp (Just (mo_u_8ToWord dflags)) b8 res args
emitPrimOp dflags res IndexOffAddrOp_WideChar  args = doIndexOffAddrOp (Just (mo_u_32ToWord dflags)) b32 res args
376
377
378
379
380
381
emitPrimOp dflags res IndexOffAddrOp_Int       args = doIndexOffAddrOp Nothing (bWord dflags) res args
emitPrimOp dflags res IndexOffAddrOp_Word      args = doIndexOffAddrOp Nothing (bWord dflags) res args
emitPrimOp dflags res IndexOffAddrOp_Addr      args = doIndexOffAddrOp Nothing (bWord dflags) res args
emitPrimOp _      res IndexOffAddrOp_Float     args = doIndexOffAddrOp Nothing f32 res args
emitPrimOp _      res IndexOffAddrOp_Double    args = doIndexOffAddrOp Nothing f64 res args
emitPrimOp dflags res IndexOffAddrOp_StablePtr args = doIndexOffAddrOp Nothing (bWord dflags) res args
382
383
384
emitPrimOp dflags res IndexOffAddrOp_Int8      args = doIndexOffAddrOp (Just (mo_s_8ToWord dflags)) b8  res args
emitPrimOp dflags res IndexOffAddrOp_Int16     args = doIndexOffAddrOp (Just (mo_s_16ToWord dflags)) b16 res args
emitPrimOp dflags res IndexOffAddrOp_Int32     args = doIndexOffAddrOp (Just (mo_s_32ToWord dflags)) b32 res args
385
emitPrimOp _      res IndexOffAddrOp_Int64     args = doIndexOffAddrOp Nothing b64 res args
386
387
388
emitPrimOp dflags res IndexOffAddrOp_Word8     args = doIndexOffAddrOp (Just (mo_u_8ToWord dflags)) b8  res args
emitPrimOp dflags res IndexOffAddrOp_Word16    args = doIndexOffAddrOp (Just (mo_u_16ToWord dflags)) b16 res args
emitPrimOp dflags res IndexOffAddrOp_Word32    args = doIndexOffAddrOp (Just (mo_u_32ToWord dflags)) b32 res args
389
emitPrimOp _      res IndexOffAddrOp_Word64    args = doIndexOffAddrOp Nothing b64 res args
390
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
emitPrimOp dflags res ReadOffAddrOp_WideChar  args = doIndexOffAddrOp (Just (mo_u_32ToWord dflags)) b32 res args
395
396
397
398
399
400
emitPrimOp dflags res ReadOffAddrOp_Int       args = doIndexOffAddrOp Nothing (bWord dflags) res args
emitPrimOp dflags res ReadOffAddrOp_Word      args = doIndexOffAddrOp Nothing (bWord dflags) res args
emitPrimOp dflags res ReadOffAddrOp_Addr      args = doIndexOffAddrOp Nothing (bWord dflags) res args
emitPrimOp _      res ReadOffAddrOp_Float     args = doIndexOffAddrOp Nothing f32 res args
emitPrimOp _      res ReadOffAddrOp_Double    args = doIndexOffAddrOp Nothing f64 res args
emitPrimOp dflags res ReadOffAddrOp_StablePtr args = doIndexOffAddrOp Nothing (bWord dflags) res args
401
402
403
emitPrimOp dflags res ReadOffAddrOp_Int8      args = doIndexOffAddrOp (Just (mo_s_8ToWord dflags)) b8  res args
emitPrimOp dflags res ReadOffAddrOp_Int16     args = doIndexOffAddrOp (Just (mo_s_16ToWord dflags)) b16 res args
emitPrimOp dflags res ReadOffAddrOp_Int32     args = doIndexOffAddrOp (Just (mo_s_32ToWord dflags)) b32 res args
404
emitPrimOp _      res ReadOffAddrOp_Int64     args = doIndexOffAddrOp Nothing b64 res args
405
406
407
emitPrimOp dflags res ReadOffAddrOp_Word8     args = doIndexOffAddrOp (Just (mo_u_8ToWord dflags)) b8  res args
emitPrimOp dflags res ReadOffAddrOp_Word16    args = doIndexOffAddrOp (Just (mo_u_16ToWord dflags)) b16 res args
emitPrimOp dflags res ReadOffAddrOp_Word32    args = doIndexOffAddrOp (Just (mo_u_32ToWord dflags)) b32 res args
408
emitPrimOp _      res ReadOffAddrOp_Word64    args = doIndexOffAddrOp Nothing b64 res args
409
410
411

-- IndexXXXArray

412
413
emitPrimOp dflags res IndexByteArrayOp_Char      args = doIndexByteArrayOp (Just (mo_u_8ToWord dflags)) b8 res args
emitPrimOp dflags res IndexByteArrayOp_WideChar  args = doIndexByteArrayOp (Just (mo_u_32ToWord dflags)) b32 res args
414
415
416
417
418
419
emitPrimOp dflags res IndexByteArrayOp_Int       args = doIndexByteArrayOp Nothing (bWord dflags) res args
emitPrimOp dflags res IndexByteArrayOp_Word      args = doIndexByteArrayOp Nothing (bWord dflags) res args
emitPrimOp dflags res IndexByteArrayOp_Addr      args = doIndexByteArrayOp Nothing (bWord dflags) res args
emitPrimOp _      res IndexByteArrayOp_Float     args = doIndexByteArrayOp Nothing f32 res args
emitPrimOp _      res IndexByteArrayOp_Double    args = doIndexByteArrayOp Nothing f64 res args
emitPrimOp dflags res IndexByteArrayOp_StablePtr args = doIndexByteArrayOp Nothing (bWord dflags) res args
420
421
422
emitPrimOp dflags res IndexByteArrayOp_Int8      args = doIndexByteArrayOp (Just (mo_s_8ToWord dflags)) b8  res args
emitPrimOp dflags res IndexByteArrayOp_Int16     args = doIndexByteArrayOp (Just (mo_s_16ToWord dflags)) b16  res args
emitPrimOp dflags res IndexByteArrayOp_Int32     args = doIndexByteArrayOp (Just (mo_s_32ToWord dflags)) b32  res args
423
emitPrimOp _      res IndexByteArrayOp_Int64     args = doIndexByteArrayOp Nothing b64  res args
424
425
426
emitPrimOp dflags res IndexByteArrayOp_Word8     args = doIndexByteArrayOp (Just (mo_u_8ToWord dflags)) b8  res args
emitPrimOp dflags res IndexByteArrayOp_Word16    args = doIndexByteArrayOp (Just (mo_u_16ToWord dflags)) b16  res args
emitPrimOp dflags res IndexByteArrayOp_Word32    args = doIndexByteArrayOp (Just (mo_u_32ToWord dflags)) b32  res args
427
emitPrimOp _      res IndexByteArrayOp_Word64    args = doIndexByteArrayOp Nothing b64  res args
428
429
430

-- ReadXXXArray, identical to IndexXXXArray.

431
432
emitPrimOp dflags res ReadByteArrayOp_Char       args = doIndexByteArrayOp (Just (mo_u_8ToWord dflags)) b8 res args
emitPrimOp dflags res ReadByteArrayOp_WideChar   args = doIndexByteArrayOp (Just (mo_u_32ToWord dflags)) b32 res args
433
434
435
436
437
438
emitPrimOp dflags res ReadByteArrayOp_Int        args = doIndexByteArrayOp Nothing (bWord dflags) res args
emitPrimOp dflags res ReadByteArrayOp_Word       args = doIndexByteArrayOp Nothing (bWord dflags) res args
emitPrimOp dflags res ReadByteArrayOp_Addr       args = doIndexByteArrayOp Nothing (bWord dflags) res args
emitPrimOp _      res ReadByteArrayOp_Float      args = doIndexByteArrayOp Nothing f32 res args
emitPrimOp _      res ReadByteArrayOp_Double     args = doIndexByteArrayOp Nothing f64 res args
emitPrimOp dflags res ReadByteArrayOp_StablePtr  args = doIndexByteArrayOp Nothing (bWord dflags) res args
439
440
441
emitPrimOp dflags res ReadByteArrayOp_Int8       args = doIndexByteArrayOp (Just (mo_s_8ToWord dflags)) b8  res args
emitPrimOp dflags res ReadByteArrayOp_Int16      args = doIndexByteArrayOp (Just (mo_s_16ToWord dflags)) b16  res args
emitPrimOp dflags res ReadByteArrayOp_Int32      args = doIndexByteArrayOp (Just (mo_s_32ToWord dflags)) b32  res args
442
emitPrimOp _      res ReadByteArrayOp_Int64      args = doIndexByteArrayOp Nothing b64  res args
443
444
445
emitPrimOp dflags res ReadByteArrayOp_Word8      args = doIndexByteArrayOp (Just (mo_u_8ToWord dflags)) b8  res args
emitPrimOp dflags res ReadByteArrayOp_Word16     args = doIndexByteArrayOp (Just (mo_u_16ToWord dflags)) b16  res args
emitPrimOp dflags res ReadByteArrayOp_Word32     args = doIndexByteArrayOp (Just (mo_u_32ToWord dflags)) b32  res args
446
emitPrimOp _      res ReadByteArrayOp_Word64     args = doIndexByteArrayOp Nothing b64  res args
447
448
449

-- WriteXXXoffAddr

450
451
emitPrimOp dflags res WriteOffAddrOp_Char       args = doWriteOffAddrOp (Just (mo_WordTo8 dflags))  res args
emitPrimOp dflags res WriteOffAddrOp_WideChar   args = doWriteOffAddrOp (Just (mo_WordTo32 dflags)) res args
452
453
454
455
456
457
emitPrimOp _      res WriteOffAddrOp_Int        args = doWriteOffAddrOp Nothing res args
emitPrimOp _      res WriteOffAddrOp_Word       args = doWriteOffAddrOp Nothing res args
emitPrimOp _      res WriteOffAddrOp_Addr       args = doWriteOffAddrOp Nothing res args
emitPrimOp _      res WriteOffAddrOp_Float      args = doWriteOffAddrOp Nothing res args
emitPrimOp _      res WriteOffAddrOp_Double     args = doWriteOffAddrOp Nothing res args
emitPrimOp _      res WriteOffAddrOp_StablePtr  args = doWriteOffAddrOp Nothing res args
458
459
460
emitPrimOp dflags res WriteOffAddrOp_Int8       args = doWriteOffAddrOp (Just (mo_WordTo8 dflags))  res args
emitPrimOp dflags res WriteOffAddrOp_Int16      args = doWriteOffAddrOp (Just (mo_WordTo16 dflags)) res args
emitPrimOp dflags res WriteOffAddrOp_Int32      args = doWriteOffAddrOp (Just (mo_WordTo32 dflags)) res args
461
emitPrimOp _      res WriteOffAddrOp_Int64      args = doWriteOffAddrOp Nothing res args
462
463
464
emitPrimOp dflags res WriteOffAddrOp_Word8      args = doWriteOffAddrOp (Just (mo_WordTo8 dflags))  res args
emitPrimOp dflags res WriteOffAddrOp_Word16     args = doWriteOffAddrOp (Just (mo_WordTo16 dflags)) res args
emitPrimOp dflags res WriteOffAddrOp_Word32     args = doWriteOffAddrOp (Just (mo_WordTo32 dflags)) res args
465
emitPrimOp _      res WriteOffAddrOp_Word64     args = doWriteOffAddrOp Nothing res args
466
467
468

-- WriteXXXArray

469
470
emitPrimOp dflags res WriteByteArrayOp_Char      args = doWriteByteArrayOp (Just (mo_WordTo8 dflags))  res args
emitPrimOp dflags res WriteByteArrayOp_WideChar  args = doWriteByteArrayOp (Just (mo_WordTo32 dflags)) res args
471
472
473
474
475
476
emitPrimOp _      res WriteByteArrayOp_Int       args = doWriteByteArrayOp Nothing res args
emitPrimOp _      res WriteByteArrayOp_Word      args = doWriteByteArrayOp Nothing res args
emitPrimOp _      res WriteByteArrayOp_Addr      args = doWriteByteArrayOp Nothing res args
emitPrimOp _      res WriteByteArrayOp_Float     args = doWriteByteArrayOp Nothing res args
emitPrimOp _      res WriteByteArrayOp_Double    args = doWriteByteArrayOp Nothing res args
emitPrimOp _      res WriteByteArrayOp_StablePtr args = doWriteByteArrayOp Nothing res args
477
478
479
emitPrimOp dflags res WriteByteArrayOp_Int8      args = doWriteByteArrayOp (Just (mo_WordTo8 dflags))  res args
emitPrimOp dflags res WriteByteArrayOp_Int16     args = doWriteByteArrayOp (Just (mo_WordTo16 dflags)) res args
emitPrimOp dflags res WriteByteArrayOp_Int32     args = doWriteByteArrayOp (Just (mo_WordTo32 dflags)) res args
480
emitPrimOp _      res WriteByteArrayOp_Int64     args = doWriteByteArrayOp Nothing  res args
481
482
483
emitPrimOp dflags res WriteByteArrayOp_Word8     args = doWriteByteArrayOp (Just (mo_WordTo8 dflags))  res args
emitPrimOp dflags res WriteByteArrayOp_Word16    args = doWriteByteArrayOp (Just (mo_WordTo16 dflags)) res args
emitPrimOp dflags res WriteByteArrayOp_Word32    args = doWriteByteArrayOp (Just (mo_WordTo32 dflags)) res args
484
emitPrimOp _      res WriteByteArrayOp_Word64    args = doWriteByteArrayOp Nothing res args
485

Ian Lynagh's avatar
Ian Lynagh committed
486
-- Copying and setting byte arrays
487
emitPrimOp _      [] CopyByteArrayOp [src,src_off,dst,dst_off,n] =
488
    doCopyByteArrayOp src src_off dst dst_off n
489
emitPrimOp _      [] CopyMutableByteArrayOp [src,src_off,dst,dst_off,n] =
490
    doCopyMutableByteArrayOp src src_off dst dst_off n
491
emitPrimOp _      [] SetByteArrayOp [ba,off,len,c] =
Ian Lynagh's avatar
Ian Lynagh committed
492
    doSetByteArrayOp ba off len c
493

tibbe's avatar
tibbe committed
494
-- Population count
495
496
497
498
499
500
emitPrimOp dflags [res] PopCnt8Op [w] =
  emitPopCntCall res (CmmMachOp (mo_WordTo8 dflags) [w]) W8
emitPrimOp dflags [res] PopCnt16Op [w] =
  emitPopCntCall res (CmmMachOp (mo_WordTo16 dflags) [w]) W16
emitPrimOp dflags [res] PopCnt32Op [w] =
  emitPopCntCall res (CmmMachOp (mo_WordTo32 dflags) [w]) W32
501
emitPrimOp _      [res] PopCnt64Op [w] =
502
  emitPopCntCall res w W64 -- arg always has type W64, no need to narrow
503
504
emitPrimOp dflags [res] PopCntOp [w] =
  emitPopCntCall res w (wordWidth dflags)
tibbe's avatar
tibbe committed
505

506
-- The rest just translate straightforwardly
507
emitPrimOp dflags [res] op [arg]
508
   | nopOp op
509
   = emitAssign (CmmLocal res) arg
510
511

   | Just (mop,rep) <- narrowOp op
512
   = emitAssign (CmmLocal res) $
513
           CmmMachOp (mop rep (wordWidth dflags)) [CmmMachOp (mop (wordWidth dflags) rep) [arg]]
514

515
emitPrimOp dflags r@[res] op args
516
   | Just prim <- callishOp op
517
   = do emitPrimCall r prim args
518

519
   | Just mop <- translateOp dflags op
520
521
522
   = let stmt = mkAssign (CmmLocal res) (CmmMachOp mop args) in
     emit stmt

523
524
emitPrimOp dflags results op args
   = case callishPrimOpSupported dflags op of
525
526
527
528
529
530
531
532
          Left op   -> emit $ mkUnsafeCall (PrimTarget op) results args
          Right gen -> gen results args

type GenericOp = [CmmFormal] -> [CmmActual] -> FCode ()

callishPrimOpSupported :: DynFlags -> PrimOp -> Either CallishMachOp GenericOp
callishPrimOpSupported dflags op
  = case op of
533
534
      IntQuotRemOp   | ncg && x86ish  -> Left (MO_S_QuotRem  (wordWidth dflags))
                     | otherwise      -> Right (genericIntQuotRemOp dflags)
535

536
537
      WordQuotRemOp  | ncg && x86ish  -> Left (MO_U_QuotRem  (wordWidth dflags))
                     | otherwise      -> Right (genericWordQuotRemOp dflags)
538

539
      WordQuotRem2Op | ncg && x86ish  -> Left (MO_U_QuotRem2 (wordWidth dflags))
540
                     | otherwise      -> Right (genericWordQuotRem2Op dflags)
541

542
      WordAdd2Op     | ncg && x86ish  -> Left (MO_Add2       (wordWidth dflags))
543
544
                     | otherwise      -> Right genericWordAdd2Op

545
      WordMul2Op     | ncg && x86ish  -> Left (MO_U_Mul2     (wordWidth dflags))
546
547
548
549
550
551
552
553
554
555
556
557
558
                     | otherwise      -> Right genericWordMul2Op

      _ -> panic "emitPrimOp: can't translate PrimOp" (ppr op)
 where
  ncg = case hscTarget dflags of
           HscAsm -> True
           _      -> False

  x86ish = case platformArch (targetPlatform dflags) of
             ArchX86    -> True
             ArchX86_64 -> True
             _          -> False

559
560
genericIntQuotRemOp :: DynFlags -> GenericOp
genericIntQuotRemOp dflags [res_q, res_r] [arg_x, arg_y]
561
   = emit $ mkAssign (CmmLocal res_q)
562
              (CmmMachOp (MO_S_Quot (wordWidth dflags)) [arg_x, arg_y]) <*>
563
            mkAssign (CmmLocal res_r)
564
565
              (CmmMachOp (MO_S_Rem  (wordWidth dflags)) [arg_x, arg_y])
genericIntQuotRemOp _ _ _ = panic "genericIntQuotRemOp"
566

567
568
genericWordQuotRemOp :: DynFlags -> GenericOp
genericWordQuotRemOp dflags [res_q, res_r] [arg_x, arg_y]
569
    = emit $ mkAssign (CmmLocal res_q)
570
               (CmmMachOp (MO_U_Quot (wordWidth dflags)) [arg_x, arg_y]) <*>
571
             mkAssign (CmmLocal res_r)
572
573
               (CmmMachOp (MO_U_Rem  (wordWidth dflags)) [arg_x, arg_y])
genericWordQuotRemOp _ _ _ = panic "genericWordQuotRemOp"
574

575
576
genericWordQuotRem2Op :: DynFlags -> GenericOp
genericWordQuotRem2Op dflags [res_q, res_r] [arg_x_high, arg_x_low, arg_y]
577
    = emit =<< f (widthInBits (wordWidth dflags)) zero arg_x_high arg_x_low
578
    where    ty = cmmExprType dflags arg_x_high
579
580
581
582
583
584
585
             shl   x i = CmmMachOp (MO_Shl   (wordWidth dflags)) [x, i]
             shr   x i = CmmMachOp (MO_U_Shr (wordWidth dflags)) [x, i]
             or    x y = CmmMachOp (MO_Or    (wordWidth dflags)) [x, y]
             ge    x y = CmmMachOp (MO_U_Ge  (wordWidth dflags)) [x, y]
             ne    x y = CmmMachOp (MO_Ne    (wordWidth dflags)) [x, y]
             minus x y = CmmMachOp (MO_Sub   (wordWidth dflags)) [x, y]
             times x y = CmmMachOp (MO_Mul   (wordWidth dflags)) [x, y]
586
587
             zero   = lit 0
             one    = lit 1
588
589
             negone = lit (fromIntegral (widthInBits (wordWidth dflags)) - 1)
             lit i = CmmLit (CmmInt i (wordWidth dflags))
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621

             f :: Int -> CmmExpr -> CmmExpr -> CmmExpr -> FCode CmmAGraph
             f 0 acc high _ = return (mkAssign (CmmLocal res_q) acc <*>
                                      mkAssign (CmmLocal res_r) high)
             f i acc high low =
                 do roverflowedBit <- newTemp ty
                    rhigh'         <- newTemp ty
                    rhigh''        <- newTemp ty
                    rlow'          <- newTemp ty
                    risge          <- newTemp ty
                    racc'          <- newTemp ty
                    let high'         = CmmReg (CmmLocal rhigh')
                        isge          = CmmReg (CmmLocal risge)
                        overflowedBit = CmmReg (CmmLocal roverflowedBit)
                    let this = catAGraphs
                               [mkAssign (CmmLocal roverflowedBit)
                                          (shr high negone),
                                mkAssign (CmmLocal rhigh')
                                          (or (shl high one) (shr low negone)),
                                mkAssign (CmmLocal rlow')
                                          (shl low one),
                                mkAssign (CmmLocal risge)
                                          (or (overflowedBit `ne` zero)
                                              (high' `ge` arg_y)),
                                mkAssign (CmmLocal rhigh'')
                                          (high' `minus` (arg_y `times` isge)),
                                mkAssign (CmmLocal racc')
                                          (or (shl acc one) isge)]
                    rest <- f (i - 1) (CmmReg (CmmLocal racc'))
                                      (CmmReg (CmmLocal rhigh''))
                                      (CmmReg (CmmLocal rlow'))
                    return (this <*> rest)
622
genericWordQuotRem2Op _ _ _ = panic "genericWordQuotRem2Op"
623
624
625

genericWordAdd2Op :: GenericOp
genericWordAdd2Op [res_h, res_l] [arg_x, arg_y]
626
  = do dflags <- getDynFlags
627
628
       r1 <- newTemp (cmmExprType dflags arg_x)
       r2 <- newTemp (cmmExprType dflags arg_x)
629
630
631
632
633
       let topHalf x = CmmMachOp (MO_U_Shr (wordWidth dflags)) [x, hww]
           toTopHalf x = CmmMachOp (MO_Shl (wordWidth dflags)) [x, hww]
           bottomHalf x = CmmMachOp (MO_And (wordWidth dflags)) [x, hwm]
           add x y = CmmMachOp (MO_Add (wordWidth dflags)) [x, y]
           or x y = CmmMachOp (MO_Or (wordWidth dflags)) [x, y]
634
           hww = CmmLit (CmmInt (fromIntegral (widthInBits (halfWordWidth dflags)))
635
636
                                (wordWidth dflags))
           hwm = CmmLit (CmmInt (halfWordMask dflags) (wordWidth dflags))
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
       emit $ catAGraphs
          [mkAssign (CmmLocal r1)
               (add (bottomHalf arg_x) (bottomHalf arg_y)),
           mkAssign (CmmLocal r2)
               (add (topHalf (CmmReg (CmmLocal r1)))
                    (add (topHalf arg_x) (topHalf arg_y))),
           mkAssign (CmmLocal res_h)
               (topHalf (CmmReg (CmmLocal r2))),
           mkAssign (CmmLocal res_l)
               (or (toTopHalf (CmmReg (CmmLocal r2)))
                   (bottomHalf (CmmReg (CmmLocal r1))))]
genericWordAdd2Op _ _ = panic "genericWordAdd2Op"

genericWordMul2Op :: GenericOp
genericWordMul2Op [res_h, res_l] [arg_x, arg_y]
652
 = do dflags <- getDynFlags
653
      let t = cmmExprType dflags arg_x
654
655
656
657
658
659
      xlyl <- liftM CmmLocal $ newTemp t
      xlyh <- liftM CmmLocal $ newTemp t
      xhyl <- liftM CmmLocal $ newTemp t
      r    <- liftM CmmLocal $ newTemp t
      -- This generic implementation is very simple and slow. We might
      -- well be able to do better, but for now this at least works.
660
661
662
663
      let topHalf x = CmmMachOp (MO_U_Shr (wordWidth dflags)) [x, hww]
          toTopHalf x = CmmMachOp (MO_Shl (wordWidth dflags)) [x, hww]
          bottomHalf x = CmmMachOp (MO_And (wordWidth dflags)) [x, hwm]
          add x y = CmmMachOp (MO_Add (wordWidth dflags)) [x, y]
664
          sum = foldl1 add
665
666
          mul x y = CmmMachOp (MO_Mul (wordWidth dflags)) [x, y]
          or x y = CmmMachOp (MO_Or (wordWidth dflags)) [x, y]
667
          hww = CmmLit (CmmInt (fromIntegral (widthInBits (halfWordWidth dflags)))
668
669
                               (wordWidth dflags))
          hwm = CmmLit (CmmInt (halfWordMask dflags) (wordWidth dflags))
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
      emit $ catAGraphs
             [mkAssign xlyl
                  (mul (bottomHalf arg_x) (bottomHalf arg_y)),
              mkAssign xlyh
                  (mul (bottomHalf arg_x) (topHalf arg_y)),
              mkAssign xhyl
                  (mul (topHalf arg_x) (bottomHalf arg_y)),
              mkAssign r
                  (sum [topHalf    (CmmReg xlyl),
                        bottomHalf (CmmReg xhyl),
                        bottomHalf (CmmReg xlyh)]),
              mkAssign (CmmLocal res_l)
                  (or (bottomHalf (CmmReg xlyl))
                      (toTopHalf (CmmReg r))),
              mkAssign (CmmLocal res_h)
                  (sum [mul (topHalf arg_x) (topHalf arg_y),
                        topHalf (CmmReg xhyl),
                        topHalf (CmmReg xlyh),
                        topHalf (CmmReg r)])]
genericWordMul2Op _ _ = panic "genericWordMul2Op"
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714

-- These PrimOps are NOPs in Cmm

nopOp :: PrimOp -> Bool
nopOp Int2WordOp     = True
nopOp Word2IntOp     = True
nopOp Int2AddrOp     = True
nopOp Addr2IntOp     = True
nopOp ChrOp	     = True  -- Int# and Char# are rep'd the same
nopOp OrdOp	     = True
nopOp _		     = False

-- These PrimOps turn into double casts

narrowOp :: PrimOp -> Maybe (Width -> Width -> MachOp, Width)
narrowOp Narrow8IntOp   = Just (MO_SS_Conv, W8)
narrowOp Narrow16IntOp  = Just (MO_SS_Conv, W16)
narrowOp Narrow32IntOp  = Just (MO_SS_Conv, W32)
narrowOp Narrow8WordOp  = Just (MO_UU_Conv, W8)
narrowOp Narrow16WordOp = Just (MO_UU_Conv, W16)
narrowOp Narrow32WordOp = Just (MO_UU_Conv, W32)
narrowOp _ 		= Nothing

-- Native word signless ops

715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
translateOp :: DynFlags -> PrimOp -> Maybe MachOp
translateOp dflags IntAddOp       = Just (mo_wordAdd dflags)
translateOp dflags IntSubOp       = Just (mo_wordSub dflags)
translateOp dflags WordAddOp      = Just (mo_wordAdd dflags)
translateOp dflags WordSubOp      = Just (mo_wordSub dflags)
translateOp dflags AddrAddOp      = Just (mo_wordAdd dflags)
translateOp dflags AddrSubOp      = Just (mo_wordSub dflags)

translateOp dflags IntEqOp        = Just (mo_wordEq dflags)
translateOp dflags IntNeOp        = Just (mo_wordNe dflags)
translateOp dflags WordEqOp       = Just (mo_wordEq dflags)
translateOp dflags WordNeOp       = Just (mo_wordNe dflags)
translateOp dflags AddrEqOp       = Just (mo_wordEq dflags)
translateOp dflags AddrNeOp       = Just (mo_wordNe dflags)

translateOp dflags AndOp          = Just (mo_wordAnd dflags)
translateOp dflags OrOp           = Just (mo_wordOr dflags)
translateOp dflags XorOp          = Just (mo_wordXor dflags)
translateOp dflags NotOp          = Just (mo_wordNot dflags)
translateOp dflags SllOp          = Just (mo_wordShl dflags)
translateOp dflags SrlOp          = Just (mo_wordUShr dflags)

translateOp dflags AddrRemOp      = Just (mo_wordURem dflags)
738
739
740

-- Native word signed ops

741
742
743
744
745
translateOp dflags IntMulOp        = Just (mo_wordMul dflags)
translateOp dflags IntMulMayOfloOp = Just (MO_S_MulMayOflo (wordWidth dflags))
translateOp dflags IntQuotOp       = Just (mo_wordSQuot dflags)
translateOp dflags IntRemOp        = Just (mo_wordSRem dflags)
translateOp dflags IntNegOp        = Just (mo_wordSNeg dflags)
746
747


748
749
750
751
translateOp dflags IntGeOp        = Just (mo_wordSGe dflags)
translateOp dflags IntLeOp        = Just (mo_wordSLe dflags)
translateOp dflags IntGtOp        = Just (mo_wordSGt dflags)
translateOp dflags IntLtOp        = Just (mo_wordSLt dflags)
752

753
754
755
translateOp dflags ISllOp         = Just (mo_wordShl dflags)
translateOp dflags ISraOp         = Just (mo_wordSShr dflags)
translateOp dflags ISrlOp         = Just (mo_wordUShr dflags)
756
757
758

-- Native word unsigned ops

759
760
761
762
translateOp dflags WordGeOp       = Just (mo_wordUGe dflags)
translateOp dflags WordLeOp       = Just (mo_wordULe dflags)
translateOp dflags WordGtOp       = Just (mo_wordUGt dflags)
translateOp dflags WordLtOp       = Just (mo_wordULt dflags)
763

764
765
766
translateOp dflags WordMulOp      = Just (mo_wordMul dflags)
translateOp dflags WordQuotOp     = Just (mo_wordUQuot dflags)
translateOp dflags WordRemOp      = Just (mo_wordURem dflags)
767

768
769
770
771
translateOp dflags AddrGeOp       = Just (mo_wordUGe dflags)
translateOp dflags AddrLeOp       = Just (mo_wordULe dflags)
translateOp dflags AddrGtOp       = Just (mo_wordUGt dflags)
translateOp dflags AddrLtOp       = Just (mo_wordULt dflags)
772
773
774

-- Char# ops

775
776
777
778
779
780
translateOp dflags CharEqOp       = Just (MO_Eq (wordWidth dflags))
translateOp dflags CharNeOp       = Just (MO_Ne (wordWidth dflags))
translateOp dflags CharGeOp       = Just (MO_U_Ge (wordWidth dflags))
translateOp dflags CharLeOp       = Just (MO_U_Le (wordWidth dflags))
translateOp dflags CharGtOp       = Just (MO_U_Gt (wordWidth dflags))
translateOp dflags CharLtOp       = Just (MO_U_Lt (wordWidth dflags))
781
782
783

-- Double ops

784
785
786
787
788
789
translateOp _      DoubleEqOp     = Just (MO_F_Eq W64)
translateOp _      DoubleNeOp     = Just (MO_F_Ne W64)
translateOp _      DoubleGeOp     = Just (MO_F_Ge W64)
translateOp _      DoubleLeOp     = Just (MO_F_Le W64)
translateOp _      DoubleGtOp     = Just (MO_F_Gt W64)
translateOp _      DoubleLtOp     = Just (MO_F_Lt W64)
790

791
792
793
794
795
translateOp _      DoubleAddOp    = Just (MO_F_Add W64)
translateOp _      DoubleSubOp    = Just (MO_F_Sub W64)
translateOp _      DoubleMulOp    = Just (MO_F_Mul W64)
translateOp _      DoubleDivOp    = Just (MO_F_Quot W64)
translateOp _      DoubleNegOp    = Just (MO_F_Neg W64)
796
797
798

-- Float ops

799
800
801
802
803
804
translateOp _      FloatEqOp     = Just (MO_F_Eq W32)
translateOp _      FloatNeOp     = Just (MO_F_Ne W32)
translateOp _      FloatGeOp     = Just (MO_F_Ge W32)
translateOp _      FloatLeOp     = Just (MO_F_Le W32)
translateOp _      FloatGtOp     = Just (MO_F_Gt W32)
translateOp _      FloatLtOp     = Just (MO_F_Lt W32)
805

806
807
808
809
810
translateOp _      FloatAddOp    = Just (MO_F_Add  W32)
translateOp _      FloatSubOp    = Just (MO_F_Sub  W32)
translateOp _      FloatMulOp    = Just (MO_F_Mul  W32)
translateOp _      FloatDivOp    = Just (MO_F_Quot W32)
translateOp _      FloatNegOp    = Just (MO_F_Neg  W32)
811
812
813

-- Conversions

814
815
translateOp dflags Int2DoubleOp   = Just (MO_SF_Conv (wordWidth dflags) W64)
translateOp dflags Double2IntOp   = Just (MO_FS_Conv W64 (wordWidth dflags))
816

817
818
translateOp dflags Int2FloatOp    = Just (MO_SF_Conv (wordWidth dflags) W32)
translateOp dflags Float2IntOp    = Just (MO_FS_Conv W32 (wordWidth dflags))
819

820
821
translateOp _      Float2DoubleOp = Just (MO_FF_Conv W32 W64)
translateOp _      Double2FloatOp = Just (MO_FF_Conv W64 W32)
822
823
824

-- Word comparisons masquerading as more exotic things.

825
826
827
828
829
830
831
translateOp dflags SameMutVarOp           = Just (mo_wordEq dflags)
translateOp dflags SameMVarOp             = Just (mo_wordEq dflags)
translateOp dflags SameMutableArrayOp     = Just (mo_wordEq dflags)
translateOp dflags SameMutableByteArrayOp = Just (mo_wordEq dflags)
translateOp dflags SameMutableArrayArrayOp= Just (mo_wordEq dflags)
translateOp dflags SameTVarOp             = Just (mo_wordEq dflags)
translateOp dflags EqStablePtrOp          = Just (mo_wordEq dflags)
832

833
translateOp _      _ = Nothing
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879

-- These primops are implemented by CallishMachOps, because they sometimes
-- turn into foreign calls depending on the backend.

callishOp :: PrimOp -> Maybe CallishMachOp
callishOp DoublePowerOp  = Just MO_F64_Pwr
callishOp DoubleSinOp    = Just MO_F64_Sin
callishOp DoubleCosOp    = Just MO_F64_Cos
callishOp DoubleTanOp    = Just MO_F64_Tan
callishOp DoubleSinhOp   = Just MO_F64_Sinh
callishOp DoubleCoshOp   = Just MO_F64_Cosh
callishOp DoubleTanhOp   = Just MO_F64_Tanh
callishOp DoubleAsinOp   = Just MO_F64_Asin
callishOp DoubleAcosOp   = Just MO_F64_Acos
callishOp DoubleAtanOp   = Just MO_F64_Atan
callishOp DoubleLogOp    = Just MO_F64_Log
callishOp DoubleExpOp    = Just MO_F64_Exp
callishOp DoubleSqrtOp   = Just MO_F64_Sqrt

callishOp FloatPowerOp  = Just MO_F32_Pwr
callishOp FloatSinOp    = Just MO_F32_Sin
callishOp FloatCosOp    = Just MO_F32_Cos
callishOp FloatTanOp    = Just MO_F32_Tan
callishOp FloatSinhOp   = Just MO_F32_Sinh
callishOp FloatCoshOp   = Just MO_F32_Cosh
callishOp FloatTanhOp   = Just MO_F32_Tanh
callishOp FloatAsinOp   = Just MO_F32_Asin
callishOp FloatAcosOp   = Just MO_F32_Acos
callishOp FloatAtanOp   = Just MO_F32_Atan
callishOp FloatLogOp    = Just MO_F32_Log
callishOp FloatExpOp    = Just MO_F32_Exp
callishOp FloatSqrtOp   = Just MO_F32_Sqrt

callishOp _ = Nothing

------------------------------------------------------------------------------
-- Helpers for translating various minor variants of array indexing.

doIndexOffAddrOp :: Maybe MachOp -> CmmType -> [LocalReg] -> [CmmExpr] -> FCode ()
doIndexOffAddrOp maybe_post_read_cast rep [res] [addr,idx]
   = mkBasicIndexedRead 0 maybe_post_read_cast rep res addr idx
doIndexOffAddrOp _ _ _ _
   = panic "CgPrimOp: doIndexOffAddrOp"

doIndexByteArrayOp :: Maybe MachOp -> CmmType -> [LocalReg] -> [CmmExpr] -> FCode ()
doIndexByteArrayOp maybe_post_read_cast rep [res] [addr,idx]
880
881
   = do dflags <- getDynFlags
        mkBasicIndexedRead (arrWordsHdrSize dflags) maybe_post_read_cast rep res addr idx
882
883
884
885
886
doIndexByteArrayOp _ _ _ _ 
   = panic "CgPrimOp: doIndexByteArrayOp"

doReadPtrArrayOp ::  LocalReg -> CmmExpr -> CmmExpr -> FCode ()
doReadPtrArrayOp res addr idx
887
   = do dflags <- getDynFlags
888
        mkBasicIndexedRead (arrPtrsHdrSize dflags) Nothing (gcWord dflags) res addr idx
889
890
891
892
893
894
895
896
897
898


doWriteOffAddrOp :: Maybe MachOp -> [LocalReg] -> [CmmExpr] -> FCode ()
doWriteOffAddrOp maybe_pre_write_cast [] [addr,idx,val]
   = mkBasicIndexedWrite 0 maybe_pre_write_cast addr idx val
doWriteOffAddrOp _ _ _
   = panic "CgPrimOp: doWriteOffAddrOp"

doWriteByteArrayOp :: Maybe MachOp -> [LocalReg] -> [CmmExpr] -> FCode ()
doWriteByteArrayOp maybe_pre_write_cast [] [addr,idx,val]
899
900
   = do dflags <- getDynFlags
        mkBasicIndexedWrite (arrWordsHdrSize dflags) maybe_pre_write_cast addr idx val
901
902
903
904
905
doWriteByteArrayOp _ _ _ 
   = panic "CgPrimOp: doWriteByteArrayOp"

doWritePtrArrayOp :: CmmExpr -> CmmExpr -> CmmExpr -> FCode ()
doWritePtrArrayOp addr idx val
906
907
  = do dflags <- getDynFlags
       mkBasicIndexedWrite (arrPtrsHdrSize dflags) Nothing addr idx val
908
909
910
911
       emit (setInfo addr (CmmLit (CmmLabel mkMAP_DIRTY_infoLabel)))
  -- the write barrier.  We must write a byte into the mark table:
  -- bits8[a + header_size + StgMutArrPtrs_size(a) + x >> N]
       emit $ mkStore (
912
913
         cmmOffsetExpr dflags
          (cmmOffsetExprW dflags (cmmOffsetB dflags addr (arrPtrsHdrSize dflags))
914
                         (loadArrPtrsSize dflags addr))
915
          (CmmMachOp (mo_wordUShr dflags) [idx,
916
                                           mkIntExpr dflags (mUT_ARR_PTRS_CARD_BITS dflags)])
917
918
         ) (CmmLit (CmmInt 1 W8))
       
919
loadArrPtrsSize :: DynFlags -> CmmExpr -> CmmExpr
920
loadArrPtrsSize dflags addr = CmmLoad (cmmOffsetB dflags addr off) (bWord dflags)
921
 where off = fixedHdrSize dflags * wORD_SIZE dflags + oFFSET_StgMutArrPtrs_ptrs dflags
922
923
924
925

mkBasicIndexedRead :: ByteOff -> Maybe MachOp -> CmmType
		   -> LocalReg -> CmmExpr -> CmmExpr -> FCode ()
mkBasicIndexedRead off Nothing read_rep res base idx
926
927
   = do dflags <- getDynFlags
        emitAssign (CmmLocal res) (cmmLoadIndexOffExpr dflags off read_rep base idx)
928
mkBasicIndexedRead off (Just cast) read_rep res base idx
929
930
931
   = do dflags <- getDynFlags
        emitAssign (CmmLocal res) (CmmMachOp cast [
                                   cmmLoadIndexOffExpr dflags off read_rep base idx])
932
933
934
935

mkBasicIndexedWrite :: ByteOff -> Maybe MachOp
		   -> CmmExpr -> CmmExpr -> CmmExpr -> FCode ()
mkBasicIndexedWrite off Nothing base idx val
936
937
   = do dflags <- getDynFlags
        emitStore (cmmIndexOffExpr dflags off (typeWidth (cmmExprType dflags val)) base idx) val
938
939
940
941
942
943
mkBasicIndexedWrite off (Just cast) base idx val
   = mkBasicIndexedWrite off Nothing base idx (CmmMachOp cast [val])

-- ----------------------------------------------------------------------------
-- Misc utils

944
945
946
cmmIndexOffExpr :: DynFlags -> ByteOff -> Width -> CmmExpr -> CmmExpr -> CmmExpr
cmmIndexOffExpr dflags off width base idx
   = cmmIndexExpr dflags width (cmmOffsetB dflags base off) idx
947

948
949
950
cmmLoadIndexOffExpr :: DynFlags -> ByteOff -> CmmType -> CmmExpr -> CmmExpr -> CmmExpr
cmmLoadIndexOffExpr dflags off ty base idx
   = CmmLoad (cmmIndexOffExpr dflags off (typeWidth ty) base idx) ty
951
952
953
954

setInfo :: CmmExpr -> CmmExpr -> CmmAGraph
setInfo closure_ptr info_ptr = mkStore closure_ptr info_ptr

955
956
957
958
959
960
961
962
963
964
965
966
967
968
-- ----------------------------------------------------------------------------
-- Copying byte arrays

-- | Takes a source 'ByteArray#', an offset in the source array, a
-- destination 'MutableByteArray#', an offset into the destination
-- array, and the number of bytes to copy.  Copies the given number of
-- bytes from the source array to the destination array.
doCopyByteArrayOp :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr
                  -> FCode ()
doCopyByteArrayOp = emitCopyByteArray copy
  where
    -- Copy data (we assume the arrays aren't overlapping since
    -- they're of different types)
    copy _src _dst dst_p src_p bytes =
969
970
        do dflags <- getDynFlags
           emitMemcpyCall dst_p src_p bytes (mkIntExpr dflags 1)
971
972
973
974
975
976
977
978
979
980
981
982
983
984

-- | Takes a source 'MutableByteArray#', an offset in the source
-- array, a destination 'MutableByteArray#', an offset into the
-- destination array, and the number of bytes to copy.  Copies the
-- given number of bytes from the source array to the destination
-- array.
doCopyMutableByteArrayOp :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr
                         -> FCode ()
doCopyMutableByteArrayOp = emitCopyByteArray copy
  where
    -- The only time the memory might overlap is when the two arrays
    -- we were provided are the same array!
    -- TODO: Optimize branch for common case of no aliasing.
    copy src dst dst_p src_p bytes = do
985
        dflags <- getDynFlags
986
        [moveCall, cpyCall] <- forkAlts [
987
988
            getCode $ emitMemmoveCall dst_p src_p bytes (mkIntExpr dflags 1),
            getCode $ emitMemcpyCall  dst_p src_p bytes (mkIntExpr dflags 1)
989
            ]
990
        emit =<< mkCmmIfThenElse (cmmEqWord dflags src dst) moveCall cpyCall
991
992
993
994
995

emitCopyByteArray :: (CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr
                      -> FCode ())
                  -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr
                  -> FCode ()
996
emitCopyByteArray copy src src_off dst dst_off n = do
997
    dflags <- getDynFlags
998
999
    dst_p <- assignTempE $ cmmOffsetExpr dflags (cmmOffsetB dflags dst (arrWordsHdrSize dflags)) dst_off
    src_p <- assignTempE $ cmmOffsetExpr dflags (cmmOffsetB dflags src (arrWordsHdrSize dflags)) src_off
1000
1001
    copy src dst dst_p src_p n

Ian Lynagh's avatar
Ian Lynagh committed
1002
1003
1004
1005
1006
1007
1008
1009
1010
-- ----------------------------------------------------------------------------
-- Setting byte arrays

-- | Takes a 'MutableByteArray#', an offset into the array, a length,
-- and a byte, and sets each of the selected bytes in the array to the
-- character.
doSetByteArrayOp :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr
                 -> FCode ()
doSetByteArrayOp ba off len c
1011
    = do dflags <- getDynFlags
1012
         p <- assignTempE $ cmmOffsetExpr dflags (cmmOffsetB dflags ba (arrWordsHdrSize dflags)) off
1013
         emitMemsetCall p c len (mkIntExpr dflags 1)
Ian Lynagh's avatar
Ian Lynagh committed
1014

1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
-- ----------------------------------------------------------------------------
-- Copying pointer arrays

-- EZY: This code has an unusually high amount of assignTemp calls, seen
-- nowhere else in the code generator.  This is mostly because these
-- "primitive" ops result in a surprisingly large amount of code.  It
-- will likely be worthwhile to optimize what is emitted here, so that
-- our optimization passes don't waste time repeatedly optimizing the
-- same bits of code.

-- More closely imitates 'assignTemp' from the old code generator, which
-- returns a CmmExpr rather than a LocalReg.
assignTempE :: CmmExpr -> FCode CmmExpr
assignTempE e = do
    t <- assignTemp e
    return (CmmReg (CmmLocal t))

-- | Takes a source 'Array#', an offset in the source array, a
-- destination 'MutableArray#', an offset into the destination array,
-- and the number of elements to copy.  Copies the given number of
-- elements from the source array to the destination array.
doCopyArrayOp :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr
              -> FCode ()
doCopyArrayOp = emitCopyArray copy
  where
    -- Copy data (we assume the arrays aren't overlapping since
    -- they're of different types)
1042
    copy _src _dst dst_p src_p bytes =
1043
        do dflags <- getDynFlags
1044
           emitMemcpyCall dst_p src_p bytes (mkIntExpr dflags (wORD_SIZE dflags))
1045

1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058

-- | Takes a source 'MutableArray#', an offset in the source array, a
-- destination 'MutableArray#', an offset into the destination array,
-- and the number of elements to copy.  Copies the given number of
-- elements from the source array to the destination array.
doCopyMutableArrayOp :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr
                     -> FCode ()
doCopyMutableArrayOp = emitCopyArray copy
  where
    -- The only time the memory might overlap is when the two arrays
    -- we were provided are the same array!
    -- TODO: Optimize branch for common case of no aliasing.
    copy src dst dst_p src_p bytes = do
1059
        dflags <- getDynFlags
1060
        [moveCall, cpyCall] <- forkAlts [
1061
1062
            getCode $ emitMemmoveCall dst_p src_p bytes (mkIntExpr dflags (wORD_SIZE dflags)),
            getCode $ emitMemcpyCall  dst_p src_p bytes (mkIntExpr dflags (wORD_SIZE dflags))
1063
            ]
1064
        emit =<< mkCmmIfThenElse (cmmEqWord dflags src dst) moveCall cpyCall
1065
1066
1067
1068
1069
1070

emitCopyArray :: (CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr
                  -> FCode ())
              -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr
              -> FCode ()
emitCopyArray copy src0 src_off0 dst0 dst_off0 n0 = do
1071
    dflags <- getDynFlags
1072
    n       <- assignTempE n0
1073
1074
1075
1076
1077
1078
1079
1080
1081
    nonzero <- getCode $ do
        -- Passed as arguments (be careful)
        src     <- assignTempE src0
        src_off <- assignTempE src_off0
        dst     <- assignTempE dst0
        dst_off <- assignTempE dst_off0

        -- Set the dirty bit in the header.
        emit (setInfo dst (CmmLit (CmmLabel mkMAP_DIRTY_infoLabel)))
1082

1083
1084
1085
1086
        dst_elems_p <- assignTempE $ cmmOffsetB dflags dst (arrPtrsHdrSize dflags)
        dst_p <- assignTempE $ cmmOffsetExprW dflags dst_elems_p dst_off
        src_p <- assignTempE $ cmmOffsetExprW dflags (cmmOffsetB dflags src (arrPtrsHdrSize dflags)) src_off
        bytes <- assignTempE $ cmmMulWord dflags n (mkIntExpr dflags (wORD_SIZE dflags))
1087

1088
        copy src dst dst_p src_p bytes
1089

1090
1091
        -- The base address of the destination card table
        dst_cards_p <- assignTempE $ cmmOffsetExprW dflags dst_elems_p (loadArrPtrsSize dflags dst)
1092

1093
        emitSetCards dst_off dst_cards_p n
1094

1095
    emit =<< mkCmmIfThen (cmmNeWord dflags n (mkIntExpr dflags 0)) nonzero
1096
1097
1098
1099
1100
1101
1102
1103

-- | Takes an info table label, a register to return the newly
-- allocated array in, a source array, an offset in the source array,
-- and the number of elements to copy.  Allocates a new array and
-- initializes it form the source array.
emitCloneArray :: CLabel -> CmmFormal -> CmmExpr -> CmmExpr -> CmmExpr
               -> FCode ()
emitCloneArray info_p res_r src0 src_off0 n0 = do
1104
1105
    dflags <- getDynFlags
    let arrPtrsHdrSizeW dflags = mkIntExpr dflags (fixedHdrSize dflags +
1106
                                     (sIZEOF_StgMutArrPtrs_NoHdr dflags `div` wORD_SIZE dflags))
1107
        myCapability = cmmSubWord dflags (CmmReg baseReg) (mkIntExpr dflags (oFFSET_Capability_r dflags))
1108
1109
1110
1111
1112
    -- Passed as arguments (be careful)
    src     <- assignTempE src0
    src_off <- assignTempE src_off0
    n       <- assignTempE n0

1113
1114
1115
    card_bytes <-