Fix the build
[ghc-hetmet.git] / compiler / codeGen / StgCmmPrim.hs
1 -----------------------------------------------------------------------------
2 --
3 -- Stg to C--: primitive operations
4 --
5 -- (c) The University of Glasgow 2004-2006
6 --
7 -----------------------------------------------------------------------------
8
9 module StgCmmPrim (
10    cgOpApp
11  ) where
12
13 #include "HsVersions.h"
14
15 import StgCmmLayout
16 import StgCmmForeign
17 import StgCmmEnv
18 import StgCmmMonad
19 import StgCmmUtils
20
21 import MkZipCfgCmm
22 import StgSyn
23 import Cmm
24 import Type     ( Type, tyConAppTyCon )
25 import TyCon
26 import CLabel
27 import CmmUtils
28 import PrimOp
29 import SMRep
30 import Constants
31 import FastString
32 import Outputable
33
34 ------------------------------------------------------------------------
35 --      Primitive operations and foreign calls
36 ------------------------------------------------------------------------
37
38 {- Note [Foreign call results]
39    ~~~~~~~~~~~~~~~~~~~~~~~~~~~
40 A foreign call always returns an unboxed tuple of results, one
41 of which is the state token.  This seems to happen even for pure
42 calls. 
43
44 Even if we returned a single result for pure calls, it'd still be
45 right to wrap it in a singleton unboxed tuple, because the result
46 might be a Haskell closure pointer, we don't want to evaluate it. -}
47
48 ----------------------------------
49 cgOpApp :: StgOp        -- The op
50         -> [StgArg]     -- Arguments
51         -> Type         -- Result type (always an unboxed tuple)
52         -> FCode ()
53
54 -- Foreign calls 
55 cgOpApp (StgFCallOp fcall _) stg_args res_ty 
56   = do  { (res_regs, res_hints) <- newUnboxedTupleRegs res_ty
57                 -- Choose result regs r1, r2
58                 -- Note [Foreign call results]
59         ; cgForeignCall res_regs res_hints fcall stg_args
60                 -- r1, r2 = foo( x, y )
61         ; emitReturn (map (CmmReg . CmmLocal) res_regs) }
62                 -- return (r1, r2) 
63       
64 -- tagToEnum# is special: we need to pull the constructor 
65 -- out of the table, and perform an appropriate return.
66
67 cgOpApp (StgPrimOp TagToEnumOp) [arg] res_ty 
68   = ASSERT(isEnumerationTyCon tycon)
69     do  { args' <- getNonVoidArgAmodes [arg]
70         ; let amode = case args' of [amode] -> amode
71                                     _ -> panic "TagToEnumOp had void arg"
72         ; emitReturn [tagToClosure tycon amode] }
73    where
74           -- If you're reading this code in the attempt to figure
75           -- out why the compiler panic'ed here, it is probably because
76           -- you used tagToEnum# in a non-monomorphic setting, e.g., 
77           --         intToTg :: Enum a => Int -> a ; intToTg (I# x#) = tagToEnum# x#
78           -- That won't work.
79         tycon = tyConAppTyCon res_ty
80
81 cgOpApp (StgPrimOp primop) args res_ty
82   | primOpOutOfLine primop
83   = do  { cmm_args <- getNonVoidArgAmodes args
84         ; let fun = CmmLit (CmmLabel (mkRtsPrimOpLabel primop))
85         ; emitCall (PrimOpCall, PrimOpReturn) fun cmm_args }
86
87   | ReturnsPrim VoidRep <- result_info
88   = do cgPrimOp [] primop args 
89        emitReturn []
90
91   | ReturnsPrim rep <- result_info
92   = do res <- newTemp (primRepCmmType rep)
93        cgPrimOp [res] primop args 
94        emitReturn [CmmReg (CmmLocal res)]
95
96   | ReturnsAlg tycon <- result_info, isUnboxedTupleTyCon tycon
97   = do (regs, _hints) <- newUnboxedTupleRegs res_ty
98        cgPrimOp regs primop args
99        emitReturn (map (CmmReg . CmmLocal) regs)
100
101   | ReturnsAlg tycon <- result_info
102   , isEnumerationTyCon tycon
103         -- c.f. cgExpr (...TagToEnumOp...)
104   = do  tag_reg <- newTemp bWord
105         cgPrimOp [tag_reg] primop args
106         emitReturn [tagToClosure tycon
107                         (CmmReg (CmmLocal tag_reg))]
108
109   | otherwise = panic "cgPrimop"
110   where
111      result_info = getPrimOpResultInfo primop
112
113 cgOpApp (StgPrimCallOp primcall) args _res_ty
114   = do  { cmm_args <- getNonVoidArgAmodes args
115         ; let fun = CmmLit (CmmLabel (mkPrimCallLabel primcall))
116         ; emitCall (PrimOpCall, PrimOpReturn) fun cmm_args }
117
118 ---------------------------------------------------
119 cgPrimOp   :: [LocalReg]        -- where to put the results
120            -> PrimOp            -- the op
121            -> [StgArg]          -- arguments
122            -> FCode ()
123
124 cgPrimOp results op args
125   = do arg_exprs <- getNonVoidArgAmodes args
126        emitPrimOp results op arg_exprs
127
128
129 ------------------------------------------------------------------------
130 --      Emitting code for a primop
131 ------------------------------------------------------------------------
132
133 emitPrimOp :: [LocalReg]        -- where to put the results
134            -> PrimOp            -- the op
135            -> [CmmExpr]         -- arguments
136            -> FCode ()
137
138 -- First we handle various awkward cases specially.  The remaining
139 -- easy cases are then handled by translateOp, defined below.
140
141 emitPrimOp [res_r,res_c] IntAddCOp [aa,bb]
142 {- 
143    With some bit-twiddling, we can define int{Add,Sub}Czh portably in
144    C, and without needing any comparisons.  This may not be the
145    fastest way to do it - if you have better code, please send it! --SDM
146   
147    Return : r = a + b,  c = 0 if no overflow, 1 on overflow.
148   
149    We currently don't make use of the r value if c is != 0 (i.e. 
150    overflow), we just convert to big integers and try again.  This
151    could be improved by making r and c the correct values for
152    plugging into a new J#.  
153    
154    { r = ((I_)(a)) + ((I_)(b));                                 \
155      c = ((StgWord)(~(((I_)(a))^((I_)(b))) & (((I_)(a))^r)))    \
156          >> (BITS_IN (I_) - 1);                                 \
157    } 
158    Wading through the mass of bracketry, it seems to reduce to:
159    c = ( (~(a^b)) & (a^r) ) >>unsigned (BITS_IN(I_)-1)
160
161 -}
162    = emit $ catAGraphs [
163         mkAssign (CmmLocal res_r) (CmmMachOp mo_wordAdd [aa,bb]),
164         mkAssign (CmmLocal res_c) $
165           CmmMachOp mo_wordUShr [
166                 CmmMachOp mo_wordAnd [
167                     CmmMachOp mo_wordNot [CmmMachOp mo_wordXor [aa,bb]],
168                     CmmMachOp mo_wordXor [aa, CmmReg (CmmLocal res_r)]
169                 ], 
170                 CmmLit (mkIntCLit (wORD_SIZE_IN_BITS - 1))
171           ]
172      ]
173
174
175 emitPrimOp [res_r,res_c] IntSubCOp [aa,bb]
176 {- Similarly:
177    #define subIntCzh(r,c,a,b)                                   \
178    { r = ((I_)(a)) - ((I_)(b));                                 \
179      c = ((StgWord)((((I_)(a))^((I_)(b))) & (((I_)(a))^r)))     \
180          >> (BITS_IN (I_) - 1);                                 \
181    }
182
183    c =  ((a^b) & (a^r)) >>unsigned (BITS_IN(I_)-1)
184 -}
185    = emit $ catAGraphs [
186         mkAssign (CmmLocal res_r) (CmmMachOp mo_wordSub [aa,bb]),
187         mkAssign (CmmLocal res_c) $
188           CmmMachOp mo_wordUShr [
189                 CmmMachOp mo_wordAnd [
190                     CmmMachOp mo_wordXor [aa,bb],
191                     CmmMachOp mo_wordXor [aa, CmmReg (CmmLocal res_r)]
192                 ], 
193                 CmmLit (mkIntCLit (wORD_SIZE_IN_BITS - 1))
194           ]
195      ]
196
197
198 emitPrimOp [res] ParOp [arg]
199   = 
200         -- for now, just implement this in a C function
201         -- later, we might want to inline it.
202     emitCCall
203         [(res,NoHint)]
204         (CmmLit (CmmLabel (mkRtsCodeLabel (sLit "newSpark"))))
205         [(CmmReg (CmmGlobal BaseReg), AddrHint), (arg,AddrHint)] 
206
207 emitPrimOp [res] ReadMutVarOp [mutv]
208    = emit (mkAssign (CmmLocal res) (cmmLoadIndexW mutv fixedHdrSize gcWord))
209
210 emitPrimOp [] WriteMutVarOp [mutv,var]
211    = do
212         emit (mkStore (cmmOffsetW mutv fixedHdrSize) var)
213         emitCCall
214                 [{-no results-}]
215                 (CmmLit (CmmLabel mkDirty_MUT_VAR_Label))
216                 [(CmmReg (CmmGlobal BaseReg), AddrHint), (mutv,AddrHint)]
217
218 --  #define sizzeofByteArrayzh(r,a) \
219 --     r = (((StgArrWords *)(a))->words * sizeof(W_))
220 emitPrimOp [res] SizeofByteArrayOp [arg]
221    = emit $
222         mkAssign (CmmLocal res) (CmmMachOp mo_wordMul [
223                           cmmLoadIndexW arg fixedHdrSize bWord,
224                           CmmLit (mkIntCLit wORD_SIZE)
225                         ])
226
227 --  #define sizzeofMutableByteArrayzh(r,a) \
228 --      r = (((StgArrWords *)(a))->words * sizeof(W_))
229 emitPrimOp [res] SizeofMutableByteArrayOp [arg]
230    = emitPrimOp [res] SizeofByteArrayOp [arg]
231
232
233 --  #define touchzh(o)                  /* nothing */
234 emitPrimOp [] TouchOp [_arg]
235    = nopC
236
237 --  #define byteArrayContentszh(r,a) r = BYTE_ARR_CTS(a)
238 emitPrimOp [res] ByteArrayContents_Char [arg]
239    = emit (mkAssign (CmmLocal res) (cmmOffsetB arg arrWordsHdrSize))
240
241 --  #define stableNameToIntzh(r,s)   (r = ((StgStableName *)s)->sn)
242 emitPrimOp [res] StableNameToIntOp [arg]
243    = emit (mkAssign (CmmLocal res) (cmmLoadIndexW arg fixedHdrSize bWord))
244
245 --  #define eqStableNamezh(r,sn1,sn2)                                   \
246 --    (r = (((StgStableName *)sn1)->sn == ((StgStableName *)sn2)->sn))
247 emitPrimOp [res] EqStableNameOp [arg1,arg2]
248    = emit (mkAssign (CmmLocal res) (CmmMachOp mo_wordEq [
249                                 cmmLoadIndexW arg1 fixedHdrSize bWord,
250                                 cmmLoadIndexW arg2 fixedHdrSize bWord
251                          ]))
252
253
254 emitPrimOp [res] ReallyUnsafePtrEqualityOp [arg1,arg2]
255    = emit (mkAssign (CmmLocal res) (CmmMachOp mo_wordEq [arg1,arg2]))
256
257 --  #define addrToHValuezh(r,a) r=(P_)a
258 emitPrimOp [res] AddrToHValueOp [arg]
259    = emit (mkAssign (CmmLocal res) arg)
260
261 --  #define dataToTagzh(r,a)  r=(GET_TAG(((StgClosure *)a)->header.info))
262 --  Note: argument may be tagged!
263 emitPrimOp [res] DataToTagOp [arg]
264    = emit (mkAssign (CmmLocal res) (getConstrTag (cmmUntag arg)))
265
266 {- Freezing arrays-of-ptrs requires changing an info table, for the
267    benefit of the generational collector.  It needs to scavenge mutable
268    objects, even if they are in old space.  When they become immutable,
269    they can be removed from this scavenge list.  -}
270
271 --  #define unsafeFreezzeArrayzh(r,a)
272 --      {
273 --        SET_INFO((StgClosure *)a,&stg_MUT_ARR_PTRS_FROZEN0_info);
274 --        r = a;
275 --      }
276 emitPrimOp [res] UnsafeFreezeArrayOp [arg]
277    = emit $ catAGraphs
278          [ setInfo arg (CmmLit (CmmLabel mkMAP_FROZEN_infoLabel)),
279            mkAssign (CmmLocal res) arg ]
280
281 --  #define unsafeFreezzeByteArrayzh(r,a)       r=(a)
282 emitPrimOp [res] UnsafeFreezeByteArrayOp [arg]
283    = emit (mkAssign (CmmLocal res) arg)
284
285 -- Reading/writing pointer arrays
286
287 emitPrimOp [r] ReadArrayOp  [obj,ix]    = doReadPtrArrayOp r obj ix
288 emitPrimOp [r] IndexArrayOp [obj,ix]    = doReadPtrArrayOp r obj ix
289 emitPrimOp []  WriteArrayOp [obj,ix,v]  = doWritePtrArrayOp obj ix v
290
291 -- IndexXXXoffAddr
292
293 emitPrimOp res IndexOffAddrOp_Char      args = doIndexOffAddrOp (Just mo_u_8ToWord) b8 res args
294 emitPrimOp res IndexOffAddrOp_WideChar  args = doIndexOffAddrOp (Just mo_u_32ToWord) b32 res args
295 emitPrimOp res IndexOffAddrOp_Int       args = doIndexOffAddrOp Nothing bWord res args
296 emitPrimOp res IndexOffAddrOp_Word      args = doIndexOffAddrOp Nothing bWord res args
297 emitPrimOp res IndexOffAddrOp_Addr      args = doIndexOffAddrOp Nothing bWord res args
298 emitPrimOp res IndexOffAddrOp_Float     args = doIndexOffAddrOp Nothing f32 res args
299 emitPrimOp res IndexOffAddrOp_Double    args = doIndexOffAddrOp Nothing f64 res args
300 emitPrimOp res IndexOffAddrOp_StablePtr args = doIndexOffAddrOp Nothing bWord res args
301 emitPrimOp res IndexOffAddrOp_Int8      args = doIndexOffAddrOp (Just mo_s_8ToWord) b8  res args
302 emitPrimOp res IndexOffAddrOp_Int16     args = doIndexOffAddrOp (Just mo_s_16ToWord) b16 res args
303 emitPrimOp res IndexOffAddrOp_Int32     args = doIndexOffAddrOp (Just mo_s_32ToWord) b32 res args
304 emitPrimOp res IndexOffAddrOp_Int64     args = doIndexOffAddrOp Nothing b64 res args
305 emitPrimOp res IndexOffAddrOp_Word8     args = doIndexOffAddrOp (Just mo_u_8ToWord) b8  res args
306 emitPrimOp res IndexOffAddrOp_Word16    args = doIndexOffAddrOp (Just mo_u_16ToWord) b16 res args
307 emitPrimOp res IndexOffAddrOp_Word32    args = doIndexOffAddrOp (Just mo_u_32ToWord) b32 res args
308 emitPrimOp res IndexOffAddrOp_Word64    args = doIndexOffAddrOp Nothing b64 res args
309
310 -- ReadXXXoffAddr, which are identical, for our purposes, to IndexXXXoffAddr.
311
312 emitPrimOp res ReadOffAddrOp_Char      args = doIndexOffAddrOp (Just mo_u_8ToWord) b8 res args
313 emitPrimOp res ReadOffAddrOp_WideChar  args = doIndexOffAddrOp (Just mo_u_32ToWord) b32 res args
314 emitPrimOp res ReadOffAddrOp_Int       args = doIndexOffAddrOp Nothing bWord res args
315 emitPrimOp res ReadOffAddrOp_Word      args = doIndexOffAddrOp Nothing bWord res args
316 emitPrimOp res ReadOffAddrOp_Addr      args = doIndexOffAddrOp Nothing bWord res args
317 emitPrimOp res ReadOffAddrOp_Float     args = doIndexOffAddrOp Nothing f32 res args
318 emitPrimOp res ReadOffAddrOp_Double    args = doIndexOffAddrOp Nothing f64 res args
319 emitPrimOp res ReadOffAddrOp_StablePtr args = doIndexOffAddrOp Nothing bWord res args
320 emitPrimOp res ReadOffAddrOp_Int8      args = doIndexOffAddrOp (Just mo_s_8ToWord) b8  res args
321 emitPrimOp res ReadOffAddrOp_Int16     args = doIndexOffAddrOp (Just mo_s_16ToWord) b16 res args
322 emitPrimOp res ReadOffAddrOp_Int32     args = doIndexOffAddrOp (Just mo_s_32ToWord) b32 res args
323 emitPrimOp res ReadOffAddrOp_Int64     args = doIndexOffAddrOp Nothing b64 res args
324 emitPrimOp res ReadOffAddrOp_Word8     args = doIndexOffAddrOp (Just mo_u_8ToWord) b8  res args
325 emitPrimOp res ReadOffAddrOp_Word16    args = doIndexOffAddrOp (Just mo_u_16ToWord) b16 res args
326 emitPrimOp res ReadOffAddrOp_Word32    args = doIndexOffAddrOp (Just mo_u_32ToWord) b32 res args
327 emitPrimOp res ReadOffAddrOp_Word64    args = doIndexOffAddrOp Nothing b64 res args
328
329 -- IndexXXXArray
330
331 emitPrimOp res IndexByteArrayOp_Char      args = doIndexByteArrayOp (Just mo_u_8ToWord) b8 res args
332 emitPrimOp res IndexByteArrayOp_WideChar  args = doIndexByteArrayOp (Just mo_u_32ToWord) b32 res args
333 emitPrimOp res IndexByteArrayOp_Int       args = doIndexByteArrayOp Nothing bWord res args
334 emitPrimOp res IndexByteArrayOp_Word      args = doIndexByteArrayOp Nothing bWord res args
335 emitPrimOp res IndexByteArrayOp_Addr      args = doIndexByteArrayOp Nothing bWord res args
336 emitPrimOp res IndexByteArrayOp_Float     args = doIndexByteArrayOp Nothing f32 res args
337 emitPrimOp res IndexByteArrayOp_Double    args = doIndexByteArrayOp Nothing f64 res args
338 emitPrimOp res IndexByteArrayOp_StablePtr args = doIndexByteArrayOp Nothing bWord res args
339 emitPrimOp res IndexByteArrayOp_Int8      args = doIndexByteArrayOp (Just mo_s_8ToWord) b8  res args
340 emitPrimOp res IndexByteArrayOp_Int16     args = doIndexByteArrayOp (Just mo_s_16ToWord) b16  res args
341 emitPrimOp res IndexByteArrayOp_Int32     args = doIndexByteArrayOp (Just mo_s_32ToWord) b32  res args
342 emitPrimOp res IndexByteArrayOp_Int64     args = doIndexByteArrayOp Nothing b64  res args
343 emitPrimOp res IndexByteArrayOp_Word8     args = doIndexByteArrayOp (Just mo_u_8ToWord) b8  res args
344 emitPrimOp res IndexByteArrayOp_Word16    args = doIndexByteArrayOp (Just mo_u_16ToWord) b16  res args
345 emitPrimOp res IndexByteArrayOp_Word32    args = doIndexByteArrayOp (Just mo_u_32ToWord) b32  res args
346 emitPrimOp res IndexByteArrayOp_Word64    args = doIndexByteArrayOp Nothing b64  res args
347
348 -- ReadXXXArray, identical to IndexXXXArray.
349
350 emitPrimOp res ReadByteArrayOp_Char       args = doIndexByteArrayOp (Just mo_u_8ToWord) b8 res args
351 emitPrimOp res ReadByteArrayOp_WideChar   args = doIndexByteArrayOp (Just mo_u_32ToWord) b32 res args
352 emitPrimOp res ReadByteArrayOp_Int        args = doIndexByteArrayOp Nothing bWord res args
353 emitPrimOp res ReadByteArrayOp_Word       args = doIndexByteArrayOp Nothing bWord res args
354 emitPrimOp res ReadByteArrayOp_Addr       args = doIndexByteArrayOp Nothing bWord res args
355 emitPrimOp res ReadByteArrayOp_Float      args = doIndexByteArrayOp Nothing f32 res args
356 emitPrimOp res ReadByteArrayOp_Double     args = doIndexByteArrayOp Nothing f64 res args
357 emitPrimOp res ReadByteArrayOp_StablePtr  args = doIndexByteArrayOp Nothing bWord res args
358 emitPrimOp res ReadByteArrayOp_Int8       args = doIndexByteArrayOp (Just mo_s_8ToWord) b8  res args
359 emitPrimOp res ReadByteArrayOp_Int16      args = doIndexByteArrayOp (Just mo_s_16ToWord) b16  res args
360 emitPrimOp res ReadByteArrayOp_Int32      args = doIndexByteArrayOp (Just mo_s_32ToWord) b32  res args
361 emitPrimOp res ReadByteArrayOp_Int64      args = doIndexByteArrayOp Nothing b64  res args
362 emitPrimOp res ReadByteArrayOp_Word8      args = doIndexByteArrayOp (Just mo_u_8ToWord) b8  res args
363 emitPrimOp res ReadByteArrayOp_Word16     args = doIndexByteArrayOp (Just mo_u_16ToWord) b16  res args
364 emitPrimOp res ReadByteArrayOp_Word32     args = doIndexByteArrayOp (Just mo_u_32ToWord) b32  res args
365 emitPrimOp res ReadByteArrayOp_Word64     args = doIndexByteArrayOp Nothing b64  res args
366
367 -- WriteXXXoffAddr
368
369 emitPrimOp res WriteOffAddrOp_Char       args = doWriteOffAddrOp (Just mo_WordTo8)  res args
370 emitPrimOp res WriteOffAddrOp_WideChar   args = doWriteOffAddrOp (Just mo_WordTo32) res args
371 emitPrimOp res WriteOffAddrOp_Int        args = doWriteOffAddrOp Nothing res args
372 emitPrimOp res WriteOffAddrOp_Word       args = doWriteOffAddrOp Nothing res args
373 emitPrimOp res WriteOffAddrOp_Addr       args = doWriteOffAddrOp Nothing res args
374 emitPrimOp res WriteOffAddrOp_Float      args = doWriteOffAddrOp Nothing res args
375 emitPrimOp res WriteOffAddrOp_Double     args = doWriteOffAddrOp Nothing res args
376 emitPrimOp res WriteOffAddrOp_StablePtr  args = doWriteOffAddrOp Nothing res args
377 emitPrimOp res WriteOffAddrOp_Int8       args = doWriteOffAddrOp (Just mo_WordTo8)  res args
378 emitPrimOp res WriteOffAddrOp_Int16      args = doWriteOffAddrOp (Just mo_WordTo16) res args
379 emitPrimOp res WriteOffAddrOp_Int32      args = doWriteOffAddrOp (Just mo_WordTo32) res args
380 emitPrimOp res WriteOffAddrOp_Int64      args = doWriteOffAddrOp Nothing res args
381 emitPrimOp res WriteOffAddrOp_Word8      args = doWriteOffAddrOp (Just mo_WordTo8)  res args
382 emitPrimOp res WriteOffAddrOp_Word16     args = doWriteOffAddrOp (Just mo_WordTo16) res args
383 emitPrimOp res WriteOffAddrOp_Word32     args = doWriteOffAddrOp (Just mo_WordTo32) res args
384 emitPrimOp res WriteOffAddrOp_Word64     args = doWriteOffAddrOp Nothing res args
385
386 -- WriteXXXArray
387
388 emitPrimOp res WriteByteArrayOp_Char      args = doWriteByteArrayOp (Just mo_WordTo8)  res args
389 emitPrimOp res WriteByteArrayOp_WideChar  args = doWriteByteArrayOp (Just mo_WordTo32) res args
390 emitPrimOp res WriteByteArrayOp_Int       args = doWriteByteArrayOp Nothing res args
391 emitPrimOp res WriteByteArrayOp_Word      args = doWriteByteArrayOp Nothing res args
392 emitPrimOp res WriteByteArrayOp_Addr      args = doWriteByteArrayOp Nothing res args
393 emitPrimOp res WriteByteArrayOp_Float     args = doWriteByteArrayOp Nothing res args
394 emitPrimOp res WriteByteArrayOp_Double    args = doWriteByteArrayOp Nothing res args
395 emitPrimOp res WriteByteArrayOp_StablePtr args = doWriteByteArrayOp Nothing res args
396 emitPrimOp res WriteByteArrayOp_Int8      args = doWriteByteArrayOp (Just mo_WordTo8)  res args
397 emitPrimOp res WriteByteArrayOp_Int16     args = doWriteByteArrayOp (Just mo_WordTo16) res args
398 emitPrimOp res WriteByteArrayOp_Int32     args = doWriteByteArrayOp (Just mo_WordTo32) res args
399 emitPrimOp res WriteByteArrayOp_Int64     args = doWriteByteArrayOp Nothing  res args
400 emitPrimOp res WriteByteArrayOp_Word8     args = doWriteByteArrayOp (Just mo_WordTo8)  res args
401 emitPrimOp res WriteByteArrayOp_Word16    args = doWriteByteArrayOp (Just mo_WordTo16) res args
402 emitPrimOp res WriteByteArrayOp_Word32    args = doWriteByteArrayOp (Just mo_WordTo32) res args
403 emitPrimOp res WriteByteArrayOp_Word64    args = doWriteByteArrayOp Nothing res args
404
405
406 -- The rest just translate straightforwardly
407 emitPrimOp [res] op [arg]
408    | nopOp op
409    = emit (mkAssign (CmmLocal res) arg)
410
411    | Just (mop,rep) <- narrowOp op
412    = emit (mkAssign (CmmLocal res) $
413            CmmMachOp (mop rep wordWidth) [CmmMachOp (mop wordWidth rep) [arg]])
414
415 emitPrimOp [res] op args
416    | Just prim <- callishOp op
417    = do emitPrimCall res prim args
418
419    | Just mop <- translateOp op
420    = let stmt = mkAssign (CmmLocal res) (CmmMachOp mop args) in
421      emit stmt
422
423 emitPrimOp _ op _
424  = pprPanic "emitPrimOp: can't translate PrimOp" (ppr op)
425
426
427 -- These PrimOps are NOPs in Cmm
428
429 nopOp :: PrimOp -> Bool
430 nopOp Int2WordOp     = True
431 nopOp Word2IntOp     = True
432 nopOp Int2AddrOp     = True
433 nopOp Addr2IntOp     = True
434 nopOp ChrOp          = True  -- Int# and Char# are rep'd the same
435 nopOp OrdOp          = True
436 nopOp _              = False
437
438 -- These PrimOps turn into double casts
439
440 narrowOp :: PrimOp -> Maybe (Width -> Width -> MachOp, Width)
441 narrowOp Narrow8IntOp   = Just (MO_SS_Conv, W8)
442 narrowOp Narrow16IntOp  = Just (MO_SS_Conv, W16)
443 narrowOp Narrow32IntOp  = Just (MO_SS_Conv, W32)
444 narrowOp Narrow8WordOp  = Just (MO_UU_Conv, W8)
445 narrowOp Narrow16WordOp = Just (MO_UU_Conv, W16)
446 narrowOp Narrow32WordOp = Just (MO_UU_Conv, W32)
447 narrowOp _              = Nothing
448
449 -- Native word signless ops
450
451 translateOp :: PrimOp -> Maybe MachOp
452 translateOp IntAddOp       = Just mo_wordAdd
453 translateOp IntSubOp       = Just mo_wordSub
454 translateOp WordAddOp      = Just mo_wordAdd
455 translateOp WordSubOp      = Just mo_wordSub
456 translateOp AddrAddOp      = Just mo_wordAdd
457 translateOp AddrSubOp      = Just mo_wordSub
458
459 translateOp IntEqOp        = Just mo_wordEq
460 translateOp IntNeOp        = Just mo_wordNe
461 translateOp WordEqOp       = Just mo_wordEq
462 translateOp WordNeOp       = Just mo_wordNe
463 translateOp AddrEqOp       = Just mo_wordEq
464 translateOp AddrNeOp       = Just mo_wordNe
465
466 translateOp AndOp          = Just mo_wordAnd
467 translateOp OrOp           = Just mo_wordOr
468 translateOp XorOp          = Just mo_wordXor
469 translateOp NotOp          = Just mo_wordNot
470 translateOp SllOp          = Just mo_wordShl
471 translateOp SrlOp          = Just mo_wordUShr
472
473 translateOp AddrRemOp      = Just mo_wordURem
474
475 -- Native word signed ops
476
477 translateOp IntMulOp        = Just mo_wordMul
478 translateOp IntMulMayOfloOp = Just (MO_S_MulMayOflo wordWidth)
479 translateOp IntQuotOp       = Just mo_wordSQuot
480 translateOp IntRemOp        = Just mo_wordSRem
481 translateOp IntNegOp        = Just mo_wordSNeg
482
483
484 translateOp IntGeOp        = Just mo_wordSGe
485 translateOp IntLeOp        = Just mo_wordSLe
486 translateOp IntGtOp        = Just mo_wordSGt
487 translateOp IntLtOp        = Just mo_wordSLt
488
489 translateOp ISllOp         = Just mo_wordShl
490 translateOp ISraOp         = Just mo_wordSShr
491 translateOp ISrlOp         = Just mo_wordUShr
492
493 -- Native word unsigned ops
494
495 translateOp WordGeOp       = Just mo_wordUGe
496 translateOp WordLeOp       = Just mo_wordULe
497 translateOp WordGtOp       = Just mo_wordUGt
498 translateOp WordLtOp       = Just mo_wordULt
499
500 translateOp WordMulOp      = Just mo_wordMul
501 translateOp WordQuotOp     = Just mo_wordUQuot
502 translateOp WordRemOp      = Just mo_wordURem
503
504 translateOp AddrGeOp       = Just mo_wordUGe
505 translateOp AddrLeOp       = Just mo_wordULe
506 translateOp AddrGtOp       = Just mo_wordUGt
507 translateOp AddrLtOp       = Just mo_wordULt
508
509 -- Char# ops
510
511 translateOp CharEqOp       = Just (MO_Eq wordWidth)
512 translateOp CharNeOp       = Just (MO_Ne wordWidth)
513 translateOp CharGeOp       = Just (MO_U_Ge wordWidth)
514 translateOp CharLeOp       = Just (MO_U_Le wordWidth)
515 translateOp CharGtOp       = Just (MO_U_Gt wordWidth)
516 translateOp CharLtOp       = Just (MO_U_Lt wordWidth)
517
518 -- Double ops
519
520 translateOp DoubleEqOp     = Just (MO_F_Eq W64)
521 translateOp DoubleNeOp     = Just (MO_F_Ne W64)
522 translateOp DoubleGeOp     = Just (MO_F_Ge W64)
523 translateOp DoubleLeOp     = Just (MO_F_Le W64)
524 translateOp DoubleGtOp     = Just (MO_F_Gt W64)
525 translateOp DoubleLtOp     = Just (MO_F_Lt W64)
526
527 translateOp DoubleAddOp    = Just (MO_F_Add W64)
528 translateOp DoubleSubOp    = Just (MO_F_Sub W64)
529 translateOp DoubleMulOp    = Just (MO_F_Mul W64)
530 translateOp DoubleDivOp    = Just (MO_F_Quot W64)
531 translateOp DoubleNegOp    = Just (MO_F_Neg W64)
532
533 -- Float ops
534
535 translateOp FloatEqOp     = Just (MO_F_Eq W32)
536 translateOp FloatNeOp     = Just (MO_F_Ne W32)
537 translateOp FloatGeOp     = Just (MO_F_Ge W32)
538 translateOp FloatLeOp     = Just (MO_F_Le W32)
539 translateOp FloatGtOp     = Just (MO_F_Gt W32)
540 translateOp FloatLtOp     = Just (MO_F_Lt W32)
541
542 translateOp FloatAddOp    = Just (MO_F_Add  W32)
543 translateOp FloatSubOp    = Just (MO_F_Sub  W32)
544 translateOp FloatMulOp    = Just (MO_F_Mul  W32)
545 translateOp FloatDivOp    = Just (MO_F_Quot W32)
546 translateOp FloatNegOp    = Just (MO_F_Neg  W32)
547
548 -- Conversions
549
550 translateOp Int2DoubleOp   = Just (MO_SF_Conv wordWidth W64)
551 translateOp Double2IntOp   = Just (MO_FS_Conv W64 wordWidth)
552
553 translateOp Int2FloatOp    = Just (MO_SF_Conv wordWidth W32)
554 translateOp Float2IntOp    = Just (MO_FS_Conv W32 wordWidth)
555
556 translateOp Float2DoubleOp = Just (MO_FF_Conv W32 W64)
557 translateOp Double2FloatOp = Just (MO_FF_Conv W64 W32)
558
559 -- Word comparisons masquerading as more exotic things.
560
561 translateOp SameMutVarOp           = Just mo_wordEq
562 translateOp SameMVarOp             = Just mo_wordEq
563 translateOp SameMutableArrayOp     = Just mo_wordEq
564 translateOp SameMutableByteArrayOp = Just mo_wordEq
565 translateOp SameTVarOp             = Just mo_wordEq
566 translateOp EqStablePtrOp          = Just mo_wordEq
567
568 translateOp _ = Nothing
569
570 -- These primops are implemented by CallishMachOps, because they sometimes
571 -- turn into foreign calls depending on the backend.
572
573 callishOp :: PrimOp -> Maybe CallishMachOp
574 callishOp DoublePowerOp  = Just MO_F64_Pwr
575 callishOp DoubleSinOp    = Just MO_F64_Sin
576 callishOp DoubleCosOp    = Just MO_F64_Cos
577 callishOp DoubleTanOp    = Just MO_F64_Tan
578 callishOp DoubleSinhOp   = Just MO_F64_Sinh
579 callishOp DoubleCoshOp   = Just MO_F64_Cosh
580 callishOp DoubleTanhOp   = Just MO_F64_Tanh
581 callishOp DoubleAsinOp   = Just MO_F64_Asin
582 callishOp DoubleAcosOp   = Just MO_F64_Acos
583 callishOp DoubleAtanOp   = Just MO_F64_Atan
584 callishOp DoubleLogOp    = Just MO_F64_Log
585 callishOp DoubleExpOp    = Just MO_F64_Exp
586 callishOp DoubleSqrtOp   = Just MO_F64_Sqrt
587
588 callishOp FloatPowerOp  = Just MO_F32_Pwr
589 callishOp FloatSinOp    = Just MO_F32_Sin
590 callishOp FloatCosOp    = Just MO_F32_Cos
591 callishOp FloatTanOp    = Just MO_F32_Tan
592 callishOp FloatSinhOp   = Just MO_F32_Sinh
593 callishOp FloatCoshOp   = Just MO_F32_Cosh
594 callishOp FloatTanhOp   = Just MO_F32_Tanh
595 callishOp FloatAsinOp   = Just MO_F32_Asin
596 callishOp FloatAcosOp   = Just MO_F32_Acos
597 callishOp FloatAtanOp   = Just MO_F32_Atan
598 callishOp FloatLogOp    = Just MO_F32_Log
599 callishOp FloatExpOp    = Just MO_F32_Exp
600 callishOp FloatSqrtOp   = Just MO_F32_Sqrt
601
602 callishOp _ = Nothing
603
604 ------------------------------------------------------------------------------
605 -- Helpers for translating various minor variants of array indexing.
606
607 doIndexOffAddrOp :: Maybe MachOp -> CmmType -> [LocalReg] -> [CmmExpr] -> FCode ()
608 doIndexOffAddrOp maybe_post_read_cast rep [res] [addr,idx]
609    = mkBasicIndexedRead 0 maybe_post_read_cast rep res addr idx
610 doIndexOffAddrOp _ _ _ _
611    = panic "CgPrimOp: doIndexOffAddrOp"
612
613 doIndexByteArrayOp :: Maybe MachOp -> CmmType -> [LocalReg] -> [CmmExpr] -> FCode ()
614 doIndexByteArrayOp maybe_post_read_cast rep [res] [addr,idx]
615    = mkBasicIndexedRead arrWordsHdrSize maybe_post_read_cast rep res addr idx
616 doIndexByteArrayOp _ _ _ _ 
617    = panic "CgPrimOp: doIndexByteArrayOp"
618
619 doReadPtrArrayOp ::  LocalReg -> CmmExpr -> CmmExpr -> FCode ()
620 doReadPtrArrayOp res addr idx
621    = mkBasicIndexedRead arrPtrsHdrSize Nothing gcWord res addr idx
622
623
624 doWriteOffAddrOp :: Maybe MachOp -> [LocalReg] -> [CmmExpr] -> FCode ()
625 doWriteOffAddrOp maybe_pre_write_cast [] [addr,idx,val]
626    = mkBasicIndexedWrite 0 maybe_pre_write_cast addr idx val
627 doWriteOffAddrOp _ _ _
628    = panic "CgPrimOp: doWriteOffAddrOp"
629
630 doWriteByteArrayOp :: Maybe MachOp -> [LocalReg] -> [CmmExpr] -> FCode ()
631 doWriteByteArrayOp maybe_pre_write_cast [] [addr,idx,val]
632    = mkBasicIndexedWrite arrWordsHdrSize maybe_pre_write_cast addr idx val
633 doWriteByteArrayOp _ _ _ 
634    = panic "CgPrimOp: doWriteByteArrayOp"
635
636 doWritePtrArrayOp :: CmmExpr -> CmmExpr -> CmmExpr -> FCode ()
637 doWritePtrArrayOp addr idx val
638    = do emit (setInfo addr (CmmLit (CmmLabel mkMAP_DIRTY_infoLabel)))
639         mkBasicIndexedWrite arrPtrsHdrSize Nothing addr idx val
640
641 mkBasicIndexedRead :: ByteOff -> Maybe MachOp -> CmmType
642                    -> LocalReg -> CmmExpr -> CmmExpr -> FCode ()
643 mkBasicIndexedRead off Nothing read_rep res base idx
644    = emit (mkAssign (CmmLocal res) (cmmLoadIndexOffExpr off read_rep base idx))
645 mkBasicIndexedRead off (Just cast) read_rep res base idx
646    = emit (mkAssign (CmmLocal res) (CmmMachOp cast [
647                                 cmmLoadIndexOffExpr off read_rep base idx]))
648
649 mkBasicIndexedWrite :: ByteOff -> Maybe MachOp
650                    -> CmmExpr -> CmmExpr -> CmmExpr -> FCode ()
651 mkBasicIndexedWrite off Nothing base idx val
652    = emit (mkStore (cmmIndexOffExpr off (typeWidth (cmmExprType val)) base idx) val)
653 mkBasicIndexedWrite off (Just cast) base idx val
654    = mkBasicIndexedWrite off Nothing base idx (CmmMachOp cast [val])
655
656 -- ----------------------------------------------------------------------------
657 -- Misc utils
658
659 cmmIndexOffExpr :: ByteOff -> Width -> CmmExpr -> CmmExpr -> CmmExpr
660 cmmIndexOffExpr off width base idx
661    = cmmIndexExpr width (cmmOffsetB base off) idx
662
663 cmmLoadIndexOffExpr :: ByteOff -> CmmType -> CmmExpr -> CmmExpr -> CmmExpr
664 cmmLoadIndexOffExpr off ty base idx
665    = CmmLoad (cmmIndexOffExpr off (typeWidth ty) base idx) ty
666
667 setInfo :: CmmExpr -> CmmExpr -> CmmAGraph
668 setInfo closure_ptr info_ptr = mkStore closure_ptr info_ptr
669