1 /* -----------------------------------------------------------------------------
2 * $Id: PrimOps.h,v 1.57 2000/06/04 20:32:49 panne Exp $
4 * (c) The GHC Team, 1998-1999
6 * Macros for primitive operations in STG-ish C code.
8 * ---------------------------------------------------------------------------*/
13 /* -----------------------------------------------------------------------------
15 -------------------------------------------------------------------------- */
17 #define gtCharzh(r,a,b) r=(I_)((a)> (b))
18 #define geCharzh(r,a,b) r=(I_)((a)>=(b))
19 #define eqCharzh(r,a,b) r=(I_)((a)==(b))
20 #define neCharzh(r,a,b) r=(I_)((a)!=(b))
21 #define ltCharzh(r,a,b) r=(I_)((a)< (b))
22 #define leCharzh(r,a,b) r=(I_)((a)<=(b))
24 /* Int comparisons: >#, >=# etc */
25 #define zgzh(r,a,b) r=(I_)((I_)(a) >(I_)(b))
26 #define zgzezh(r,a,b) r=(I_)((I_)(a)>=(I_)(b))
27 #define zezezh(r,a,b) r=(I_)((I_)(a)==(I_)(b))
28 #define zszezh(r,a,b) r=(I_)((I_)(a)!=(I_)(b))
29 #define zlzh(r,a,b) r=(I_)((I_)(a) <(I_)(b))
30 #define zlzezh(r,a,b) r=(I_)((I_)(a)<=(I_)(b))
32 #define gtWordzh(r,a,b) r=(I_)((W_)(a) >(W_)(b))
33 #define geWordzh(r,a,b) r=(I_)((W_)(a)>=(W_)(b))
34 #define eqWordzh(r,a,b) r=(I_)((W_)(a)==(W_)(b))
35 #define neWordzh(r,a,b) r=(I_)((W_)(a)!=(W_)(b))
36 #define ltWordzh(r,a,b) r=(I_)((W_)(a) <(W_)(b))
37 #define leWordzh(r,a,b) r=(I_)((W_)(a)<=(W_)(b))
39 #define gtAddrzh(r,a,b) r=(I_)((a) >(b))
40 #define geAddrzh(r,a,b) r=(I_)((a)>=(b))
41 #define eqAddrzh(r,a,b) r=(I_)((a)==(b))
42 #define neAddrzh(r,a,b) r=(I_)((a)!=(b))
43 #define ltAddrzh(r,a,b) r=(I_)((a) <(b))
44 #define leAddrzh(r,a,b) r=(I_)((a)<=(b))
46 #define gtFloatzh(r,a,b) r=(I_)((a)> (b))
47 #define geFloatzh(r,a,b) r=(I_)((a)>=(b))
48 #define eqFloatzh(r,a,b) r=(I_)((a)==(b))
49 #define neFloatzh(r,a,b) r=(I_)((a)!=(b))
50 #define ltFloatzh(r,a,b) r=(I_)((a)< (b))
51 #define leFloatzh(r,a,b) r=(I_)((a)<=(b))
53 /* Double comparisons: >##, >=#@ etc */
54 #define zgzhzh(r,a,b) r=(I_)((a) >(b))
55 #define zgzezhzh(r,a,b) r=(I_)((a)>=(b))
56 #define zezezhzh(r,a,b) r=(I_)((a)==(b))
57 #define zszezhzh(r,a,b) r=(I_)((a)!=(b))
58 #define zlzhzh(r,a,b) r=(I_)((a) <(b))
59 #define zlzezhzh(r,a,b) r=(I_)((a)<=(b))
61 /* -----------------------------------------------------------------------------
63 -------------------------------------------------------------------------- */
65 #define ordzh(r,a) r=(I_)((W_) (a))
66 #define chrzh(r,a) r=(StgChar)((W_)(a))
68 /* -----------------------------------------------------------------------------
70 -------------------------------------------------------------------------- */
72 I_ stg_div (I_ a, I_ b);
74 #define zpzh(r,a,b) r=(a)+(b)
75 #define zmzh(r,a,b) r=(a)-(b)
76 #define ztzh(r,a,b) r=(a)*(b)
77 #define quotIntzh(r,a,b) r=(a)/(b)
78 #define zszh(r,a,b) r=ULTRASAFESTGCALL2(I_,(void *, I_, I_),stg_div,(a),(b))
79 #define remIntzh(r,a,b) r=(a)%(b)
80 #define negateIntzh(r,a) r=-(a)
82 /* -----------------------------------------------------------------------------
83 * Int operations with carry.
84 * -------------------------------------------------------------------------- */
86 /* With some bit-twiddling, we can define int{Add,Sub}Czh portably in
87 * C, and without needing any comparisons. This may not be the
88 * fastest way to do it - if you have better code, please send it! --SDM
90 * Return : r = a + b, c = 0 if no overflow, 1 on overflow.
92 * We currently don't make use of the r value if c is != 0 (i.e.
93 * overflow), we just convert to big integers and try again. This
94 * could be improved by making r and c the correct values for
95 * plugging into a new J#.
97 #define addIntCzh(r,c,a,b) \
99 c = ((StgWord)(~(a^b) & (a^r))) \
100 >> (BITS_PER_BYTE * sizeof(I_) - 1); \
104 #define subIntCzh(r,c,a,b) \
106 c = ((StgWord)((a^b) & (a^r))) \
107 >> (BITS_PER_BYTE * sizeof(I_) - 1); \
110 /* Multiply with overflow checking.
112 * This is slightly more tricky - the usual sign rules for add/subtract
115 * On x86 hardware we use a hand-crafted assembly fragment to do the job.
117 * On other 32-bit machines we use gcc's 'long long' types, finding
118 * overflow with some careful bit-twiddling.
120 * On 64-bit machines where gcc's 'long long' type is also 64-bits,
121 * we use a crude approximation, testing whether either operand is
122 * larger than 32-bits; if neither is, then we go ahead with the
128 #define mulIntCzh(r,c,a,b) \
130 __asm__("xorl %1,%1\n\t \
135 : "=r" (r), "=&r" (c) : "r" (a), "0" (b)); \
138 #elif SIZEOF_VOID_P == 4
140 #ifdef WORDS_BIGENDIAN
153 #define mulIntCzh(r,c,a,b) \
156 z.l = (StgInt64)a * (StgInt64)b; \
159 if (c == 0 || c == -1) { \
160 c = ((StgWord)((a^b) ^ r)) \
161 >> (BITS_PER_BYTE * sizeof(I_) - 1); \
164 /* Careful: the carry calculation above is extremely delicate. Make sure
165 * you test it thoroughly after changing it.
170 #define HALF_INT (1 << (BITS_PER_BYTE * sizeof(I_) / 2))
172 #define stg_abs(a) ((a) < 0 ? -(a) : (a))
174 #define mulIntCzh(r,c,a,b) \
176 if (stg_abs(a) >= HALF_INT \
177 stg_abs(b) >= HALF_INT) { \
186 /* -----------------------------------------------------------------------------
188 -------------------------------------------------------------------------- */
190 #define quotWordzh(r,a,b) r=((W_)a)/((W_)b)
191 #define remWordzh(r,a,b) r=((W_)a)%((W_)b)
193 #define andzh(r,a,b) r=(a)&(b)
194 #define orzh(r,a,b) r=(a)|(b)
195 #define xorzh(r,a,b) r=(a)^(b)
196 #define notzh(r,a) r=~(a)
198 /* The extra tests below properly define the behaviour when shifting
199 * by offsets larger than the width of the value being shifted. Doing
200 * so is undefined in C (and in fact gives different answers depending
201 * on whether the operation is constant folded or not with gcc on x86!)
204 #define shiftLzh(r,a,b) r=((b) >= BITS_IN(W_)) ? 0 : (a)<<(b)
205 #define shiftRLzh(r,a,b) r=((b) >= BITS_IN(W_)) ? 0 : (a)>>(b)
206 #define iShiftLzh(r,a,b) r=((b) >= BITS_IN(W_)) ? 0 : (a)<<(b)
207 /* Right shifting of signed quantities is not portable in C, so
208 the behaviour you'll get from using these primops depends
209 on the whatever your C compiler is doing. ToDo: fix/document. -- sof 8/98
211 #define iShiftRAzh(r,a,b) r=((b) >= BITS_IN(I_)) ? (((a) < 0) ? -1 : 0) : (a)>>(b)
212 #define iShiftRLzh(r,a,b) r=((b) >= BITS_IN(I_)) ? 0 : ((W_)(a))>>(b)
214 #define int2Wordzh(r,a) r=(W_)(a)
215 #define word2Intzh(r,a) r=(I_)(a)
217 /* -----------------------------------------------------------------------------
219 -------------------------------------------------------------------------- */
221 #define int2Addrzh(r,a) r=(A_)(a)
222 #define addr2Intzh(r,a) r=(I_)(a)
224 #define readCharOffAddrzh(r,a,i) r= ((C_ *)(a))[i]
225 #define readIntOffAddrzh(r,a,i) r= ((I_ *)(a))[i]
226 #define readWordOffAddrzh(r,a,i) r= ((W_ *)(a))[i]
227 #define readAddrOffAddrzh(r,a,i) r= ((PP_)(a))[i]
228 #define readFloatOffAddrzh(r,a,i) r= PK_FLT((P_) (((StgFloat *)(a)) + i))
229 #define readDoubleOffAddrzh(r,a,i) r= PK_DBL((P_) (((StgDouble *)(a)) + i))
230 #define readStablePtrOffAddrzh(r,a,i) r= ((StgStablePtr *)(a))[i]
231 #ifdef SUPPORT_LONG_LONGS
232 #define readInt64OffAddrzh(r,a,i) r= ((LI_ *)(a))[i]
233 #define readWord64OffAddrzh(r,a,i) r= ((LW_ *)(a))[i]
236 #define writeCharOffAddrzh(a,i,v) ((C_ *)(a))[i] = (v)
237 #define writeIntOffAddrzh(a,i,v) ((I_ *)(a))[i] = (v)
238 #define writeWordOffAddrzh(a,i,v) ((W_ *)(a))[i] = (v)
239 #define writeAddrOffAddrzh(a,i,v) ((PP_)(a))[i] = (v)
240 #define writeForeignObjOffAddrzh(a,i,v) ((PP_)(a))[i] = ForeignObj_CLOSURE_DATA(v)
241 #define writeFloatOffAddrzh(a,i,v) ASSIGN_FLT((P_) (((StgFloat *)(a)) + i),v)
242 #define writeDoubleOffAddrzh(a,i,v) ASSIGN_DBL((P_) (((StgDouble *)(a)) + i),v)
243 #define writeStablePtrOffAddrzh(a,i,v) ((StgStablePtr *)(a))[i] = (v)
244 #ifdef SUPPORT_LONG_LONGS
245 #define writeInt64OffAddrzh(a,i,v) ((LI_ *)(a))[i] = (v)
246 #define writeWord64OffAddrzh(a,i,v) ((LW_ *)(a))[i] = (v)
249 #define indexCharOffAddrzh(r,a,i) r= ((C_ *)(a))[i]
250 #define indexIntOffAddrzh(r,a,i) r= ((I_ *)(a))[i]
251 #define indexWordOffAddrzh(r,a,i) r= ((W_ *)(a))[i]
252 #define indexAddrOffAddrzh(r,a,i) r= ((PP_)(a))[i]
253 #define indexFloatOffAddrzh(r,a,i) r= PK_FLT((P_) (((StgFloat *)(a)) + i))
254 #define indexDoubleOffAddrzh(r,a,i) r= PK_DBL((P_) (((StgDouble *)(a)) + i))
255 #define indexStablePtrOffAddrzh(r,a,i) r= ((StgStablePtr *)(a))[i]
256 #ifdef SUPPORT_LONG_LONGS
257 #define indexInt64OffAddrzh(r,a,i) r= ((LI_ *)(a))[i]
258 #define indexWord64OffAddrzh(r,a,i) r= ((LW_ *)(a))[i]
261 /* -----------------------------------------------------------------------------
263 -------------------------------------------------------------------------- */
265 #define plusFloatzh(r,a,b) r=(a)+(b)
266 #define minusFloatzh(r,a,b) r=(a)-(b)
267 #define timesFloatzh(r,a,b) r=(a)*(b)
268 #define divideFloatzh(r,a,b) r=(a)/(b)
269 #define negateFloatzh(r,a) r=-(a)
271 #define int2Floatzh(r,a) r=(StgFloat)(a)
272 #define float2Intzh(r,a) r=(I_)(a)
274 #define expFloatzh(r,a) r=(StgFloat) RET_PRIM_STGCALL1(StgDouble,exp,a)
275 #define logFloatzh(r,a) r=(StgFloat) RET_PRIM_STGCALL1(StgDouble,log,a)
276 #define sqrtFloatzh(r,a) r=(StgFloat) RET_PRIM_STGCALL1(StgDouble,sqrt,a)
277 #define sinFloatzh(r,a) r=(StgFloat) RET_PRIM_STGCALL1(StgDouble,sin,a)
278 #define cosFloatzh(r,a) r=(StgFloat) RET_PRIM_STGCALL1(StgDouble,cos,a)
279 #define tanFloatzh(r,a) r=(StgFloat) RET_PRIM_STGCALL1(StgDouble,tan,a)
280 #define asinFloatzh(r,a) r=(StgFloat) RET_PRIM_STGCALL1(StgDouble,asin,a)
281 #define acosFloatzh(r,a) r=(StgFloat) RET_PRIM_STGCALL1(StgDouble,acos,a)
282 #define atanFloatzh(r,a) r=(StgFloat) RET_PRIM_STGCALL1(StgDouble,atan,a)
283 #define sinhFloatzh(r,a) r=(StgFloat) RET_PRIM_STGCALL1(StgDouble,sinh,a)
284 #define coshFloatzh(r,a) r=(StgFloat) RET_PRIM_STGCALL1(StgDouble,cosh,a)
285 #define tanhFloatzh(r,a) r=(StgFloat) RET_PRIM_STGCALL1(StgDouble,tanh,a)
286 #define powerFloatzh(r,a,b) r=(StgFloat) RET_PRIM_STGCALL2(StgDouble,pow,a,b)
288 /* -----------------------------------------------------------------------------
290 -------------------------------------------------------------------------- */
292 #define zpzhzh(r,a,b) r=(a)+(b)
293 #define zmzhzh(r,a,b) r=(a)-(b)
294 #define ztzhzh(r,a,b) r=(a)*(b)
295 #define zszhzh(r,a,b) r=(a)/(b)
296 #define negateDoublezh(r,a) r=-(a)
298 #define int2Doublezh(r,a) r=(StgDouble)(a)
299 #define double2Intzh(r,a) r=(I_)(a)
301 #define float2Doublezh(r,a) r=(StgDouble)(a)
302 #define double2Floatzh(r,a) r=(StgFloat)(a)
304 #define expDoublezh(r,a) r=(StgDouble) RET_PRIM_STGCALL1(StgDouble,exp,a)
305 #define logDoublezh(r,a) r=(StgDouble) RET_PRIM_STGCALL1(StgDouble,log,a)
306 #define sqrtDoublezh(r,a) r=(StgDouble) RET_PRIM_STGCALL1(StgDouble,sqrt,a)
307 #define sinDoublezh(r,a) r=(StgDouble) RET_PRIM_STGCALL1(StgDouble,sin,a)
308 #define cosDoublezh(r,a) r=(StgDouble) RET_PRIM_STGCALL1(StgDouble,cos,a)
309 #define tanDoublezh(r,a) r=(StgDouble) RET_PRIM_STGCALL1(StgDouble,tan,a)
310 #define asinDoublezh(r,a) r=(StgDouble) RET_PRIM_STGCALL1(StgDouble,asin,a)
311 #define acosDoublezh(r,a) r=(StgDouble) RET_PRIM_STGCALL1(StgDouble,acos,a)
312 #define atanDoublezh(r,a) r=(StgDouble) RET_PRIM_STGCALL1(StgDouble,atan,a)
313 #define sinhDoublezh(r,a) r=(StgDouble) RET_PRIM_STGCALL1(StgDouble,sinh,a)
314 #define coshDoublezh(r,a) r=(StgDouble) RET_PRIM_STGCALL1(StgDouble,cosh,a)
315 #define tanhDoublezh(r,a) r=(StgDouble) RET_PRIM_STGCALL1(StgDouble,tanh,a)
317 #define ztztzhzh(r,a,b) r=(StgDouble) RET_PRIM_STGCALL2(StgDouble,pow,a,b)
319 /* -----------------------------------------------------------------------------
321 -------------------------------------------------------------------------- */
323 /* We can do integer2Int and cmpInteger inline, since they don't need
324 * to allocate any memory.
326 * integer2Int# is now modular.
329 #define integer2Intzh(r, sa,da) \
330 { StgWord word0 = ((StgWord *)BYTE_ARR_CTS(da))[0]; \
336 ( size < 0 && word0 != 0x8000000 ) ? \
341 #define integer2Wordzh(r, sa,da) \
342 { StgWord word0 = ((StgWord *)BYTE_ARR_CTS(da))[0]; \
344 (r) = ( size == 0 ) ? 0 : word0 ; \
347 #define cmpIntegerzh(r, s1,d1, s2,d2) \
351 arg1._mp_size = (s1); \
352 arg1._mp_alloc= ((StgArrWords *)d1)->words; \
353 arg1._mp_d = (unsigned long int *) (BYTE_ARR_CTS(d1)); \
354 arg2._mp_size = (s2); \
355 arg2._mp_alloc= ((StgArrWords *)d2)->words; \
356 arg2._mp_d = (unsigned long int *) (BYTE_ARR_CTS(d2)); \
358 (r) = RET_PRIM_STGCALL2(I_,mpz_cmp,&arg1,&arg2); \
361 #define cmpIntegerIntzh(r, s,d, i) \
364 arg._mp_size = (s); \
365 arg._mp_alloc = ((StgArrWords *)d)->words; \
366 arg._mp_d = (unsigned long int *) (BYTE_ARR_CTS(d)); \
368 (r) = RET_PRIM_STGCALL2(I_,mpz_cmp_si,&arg,i); \
371 /* NOTE: gcdIntzh and gcdIntegerIntzh work only for positive inputs! */
373 /* mp_limb_t must be able to hold an StgInt for this to work properly */
374 #define gcdIntzh(r,a,b) \
375 { mp_limb_t aa = (mp_limb_t)(a); \
376 r = RET_STGCALL3(StgInt, mpn_gcd_1, (mp_limb_t *)(&aa), 1, (mp_limb_t)(b)); \
379 #define gcdIntegerIntzh(r,sa,a,b) \
380 r = RET_STGCALL3(StgInt, mpn_gcd_1, (mp_limb_t *)(BYTE_ARR_CTS(a)), sa, b)
382 /* The rest are all out-of-line: -------- */
384 /* Integer arithmetic */
385 EF_(plusIntegerzh_fast);
386 EF_(minusIntegerzh_fast);
387 EF_(timesIntegerzh_fast);
388 EF_(gcdIntegerzh_fast);
389 EF_(quotRemIntegerzh_fast);
390 EF_(quotIntegerzh_fast);
391 EF_(remIntegerzh_fast);
392 EF_(divExactIntegerzh_fast);
393 EF_(divModIntegerzh_fast);
396 EF_(int2Integerzh_fast);
397 EF_(word2Integerzh_fast);
398 EF_(addr2Integerzh_fast);
400 /* Floating-point decodings */
401 EF_(decodeFloatzh_fast);
402 EF_(decodeDoublezh_fast);
404 /* -----------------------------------------------------------------------------
406 -------------------------------------------------------------------------- */
408 #ifdef SUPPORT_LONG_LONGS
410 #define integerToWord64zh(r, sa,da) \
411 { unsigned long int* d; \
415 d = (unsigned long int *) (BYTE_ARR_CTS(da)); \
419 } else if ( s == 1) { \
422 res = (LW_)d[0] + (LW_)d[1] * 0x100000000ULL; \
427 #define integerToInt64zh(r, sa,da) \
428 { unsigned long int* d; \
432 d = (unsigned long int *) (BYTE_ARR_CTS(da)); \
436 } else if ( s == 1) { \
439 res = (LI_)d[0] + (LI_)d[1] * 0x100000000LL; \
448 EF_(int64ToIntegerzh_fast);
449 EF_(word64ToIntegerzh_fast);
451 /* The rest are (way!) out of line, implemented via C entry points.
453 I_ stg_gtWord64 (StgWord64, StgWord64);
454 I_ stg_geWord64 (StgWord64, StgWord64);
455 I_ stg_eqWord64 (StgWord64, StgWord64);
456 I_ stg_neWord64 (StgWord64, StgWord64);
457 I_ stg_ltWord64 (StgWord64, StgWord64);
458 I_ stg_leWord64 (StgWord64, StgWord64);
460 I_ stg_gtInt64 (StgInt64, StgInt64);
461 I_ stg_geInt64 (StgInt64, StgInt64);
462 I_ stg_eqInt64 (StgInt64, StgInt64);
463 I_ stg_neInt64 (StgInt64, StgInt64);
464 I_ stg_ltInt64 (StgInt64, StgInt64);
465 I_ stg_leInt64 (StgInt64, StgInt64);
467 LW_ stg_remWord64 (StgWord64, StgWord64);
468 LW_ stg_quotWord64 (StgWord64, StgWord64);
470 LI_ stg_remInt64 (StgInt64, StgInt64);
471 LI_ stg_quotInt64 (StgInt64, StgInt64);
472 LI_ stg_negateInt64 (StgInt64);
473 LI_ stg_plusInt64 (StgInt64, StgInt64);
474 LI_ stg_minusInt64 (StgInt64, StgInt64);
475 LI_ stg_timesInt64 (StgInt64, StgInt64);
477 LW_ stg_and64 (StgWord64, StgWord64);
478 LW_ stg_or64 (StgWord64, StgWord64);
479 LW_ stg_xor64 (StgWord64, StgWord64);
480 LW_ stg_not64 (StgWord64);
482 LW_ stg_shiftL64 (StgWord64, StgInt);
483 LW_ stg_shiftRL64 (StgWord64, StgInt);
484 LI_ stg_iShiftL64 (StgInt64, StgInt);
485 LI_ stg_iShiftRL64 (StgInt64, StgInt);
486 LI_ stg_iShiftRA64 (StgInt64, StgInt);
488 LI_ stg_intToInt64 (StgInt);
489 I_ stg_int64ToInt (StgInt64);
490 LW_ stg_int64ToWord64 (StgInt64);
492 LW_ stg_wordToWord64 (StgWord);
493 W_ stg_word64ToWord (StgWord64);
494 LI_ stg_word64ToInt64 (StgWord64);
497 /* -----------------------------------------------------------------------------
499 -------------------------------------------------------------------------- */
501 /* We cast to void* instead of StgChar* because this avoids a warning
502 * about increasing the alignment requirements.
504 #define REAL_BYTE_ARR_CTS(a) ((void *) (((StgArrWords *)(a))->payload))
505 #define REAL_PTRS_ARR_CTS(a) ((P_) (((StgMutArrPtrs *)(a))->payload))
508 #define BYTE_ARR_CTS(a) \
509 ({ ASSERT(GET_INFO((StgArrWords *)(a)) == &ARR_WORDS_info); \
510 REAL_BYTE_ARR_CTS(a); })
511 #define PTRS_ARR_CTS(a) \
512 ({ ASSERT((GET_INFO((StgMutArrPtrs *)(a)) == &MUT_ARR_PTRS_FROZEN_info) \
513 || (GET_INFO((StgMutArrPtrs *)(a)) == &MUT_ARR_PTRS_info)); \
514 REAL_PTRS_ARR_CTS(a); })
516 #define BYTE_ARR_CTS(a) REAL_BYTE_ARR_CTS(a)
517 #define PTRS_ARR_CTS(a) REAL_PTRS_ARR_CTS(a)
520 extern I_ genSymZh(void);
521 extern I_ resetGenSymZh(void);
523 /*--- everything except new*Array is done inline: */
525 #define sameMutableArrayzh(r,a,b) r=(I_)((a)==(b))
526 #define sameMutableByteArrayzh(r,a,b) r=(I_)((a)==(b))
528 #define readArrayzh(r,a,i) r=((PP_) PTRS_ARR_CTS(a))[(i)]
530 #define readCharArrayzh(r,a,i) indexCharOffAddrzh(r,BYTE_ARR_CTS(a),i)
531 #define readIntArrayzh(r,a,i) indexIntOffAddrzh(r,BYTE_ARR_CTS(a),i)
532 #define readWordArrayzh(r,a,i) indexWordOffAddrzh(r,BYTE_ARR_CTS(a),i)
533 #define readAddrArrayzh(r,a,i) indexAddrOffAddrzh(r,BYTE_ARR_CTS(a),i)
534 #define readFloatArrayzh(r,a,i) indexFloatOffAddrzh(r,BYTE_ARR_CTS(a),i)
535 #define readDoubleArrayzh(r,a,i) indexDoubleOffAddrzh(r,BYTE_ARR_CTS(a),i)
536 #define readStablePtrArrayzh(r,a,i) indexStablePtrOffAddrzh(r,BYTE_ARR_CTS(a),i)
537 #ifdef SUPPORT_LONG_LONGS
538 #define readInt64Arrayzh(r,a,i) indexInt64OffAddrzh(r,BYTE_ARR_CTS(a),i)
539 #define readWord64Arrayzh(r,a,i) indexWord64OffAddrzh(r,BYTE_ARR_CTS(a),i)
542 /* result ("r") arg ignored in write macros! */
543 #define writeArrayzh(a,i,v) ((PP_) PTRS_ARR_CTS(a))[(i)]=(v)
545 #define writeCharArrayzh(a,i,v) ((C_ *)(BYTE_ARR_CTS(a)))[i] = (v)
546 #define writeIntArrayzh(a,i,v) ((I_ *)(BYTE_ARR_CTS(a)))[i] = (v)
547 #define writeWordArrayzh(a,i,v) ((W_ *)(BYTE_ARR_CTS(a)))[i] = (v)
548 #define writeAddrArrayzh(a,i,v) ((PP_)(BYTE_ARR_CTS(a)))[i] = (v)
549 #define writeFloatArrayzh(a,i,v) \
550 ASSIGN_FLT((P_) (((StgFloat *)(BYTE_ARR_CTS(a))) + i),v)
551 #define writeDoubleArrayzh(a,i,v) \
552 ASSIGN_DBL((P_) (((StgDouble *)(BYTE_ARR_CTS(a))) + i),v)
553 #define writeStablePtrArrayzh(a,i,v) ((StgStablePtr *)(BYTE_ARR_CTS(a)))[i] = (v)
554 #ifdef SUPPORT_LONG_LONGS
555 #define writeInt64Arrayzh(a,i,v) ((LI_ *)(BYTE_ARR_CTS(a)))[i] = (v)
556 #define writeWord64Arrayzh(a,i,v) ((LW_ *)(BYTE_ARR_CTS(a)))[i] = (v)
559 #define indexArrayzh(r,a,i) r=((PP_) PTRS_ARR_CTS(a))[(i)]
561 #define indexCharArrayzh(r,a,i) indexCharOffAddrzh(r,BYTE_ARR_CTS(a),i)
562 #define indexIntArrayzh(r,a,i) indexIntOffAddrzh(r,BYTE_ARR_CTS(a),i)
563 #define indexWordArrayzh(r,a,i) indexWordOffAddrzh(r,BYTE_ARR_CTS(a),i)
564 #define indexAddrArrayzh(r,a,i) indexAddrOffAddrzh(r,BYTE_ARR_CTS(a),i)
565 #define indexFloatArrayzh(r,a,i) indexFloatOffAddrzh(r,BYTE_ARR_CTS(a),i)
566 #define indexDoubleArrayzh(r,a,i) indexDoubleOffAddrzh(r,BYTE_ARR_CTS(a),i)
567 #define indexStablePtrArrayzh(r,a,i) indexStablePtrOffAddrzh(r,BYTE_ARR_CTS(a),i)
568 #ifdef SUPPORT_LONG_LONGS
569 #define indexInt64Arrayzh(r,a,i) indexInt64OffAddrzh(r,BYTE_ARR_CTS(a),i)
570 #define indexWord64Arrayzh(r,a,i) indexWord64OffAddrzh(r,BYTE_ARR_CTS(a),i)
573 /* Freezing arrays-of-ptrs requires changing an info table, for the
574 benefit of the generational collector. It needs to scavenge mutable
575 objects, even if they are in old space. When they become immutable,
576 they can be removed from this scavenge list. */
578 #define unsafeFreezzeArrayzh(r,a) \
580 SET_INFO((StgClosure *)a,&MUT_ARR_PTRS_FROZEN_info); \
584 #define unsafeFreezzeByteArrayzh(r,a) r=(a)
586 EF_(unsafeThawArrayzh_fast);
588 #define sizzeofByteArrayzh(r,a) \
589 r = (((StgArrWords *)(a))->words * sizeof(W_))
590 #define sizzeofMutableByteArrayzh(r,a) \
591 r = (((StgArrWords *)(a))->words * sizeof(W_))
593 /* and the out-of-line ones... */
595 EF_(newCharArrayzh_fast);
596 EF_(newIntArrayzh_fast);
597 EF_(newWordArrayzh_fast);
598 EF_(newAddrArrayzh_fast);
599 EF_(newFloatArrayzh_fast);
600 EF_(newDoubleArrayzh_fast);
601 EF_(newStablePtrArrayzh_fast);
602 EF_(newArrayzh_fast);
604 /* encoding and decoding of floats/doubles. */
606 /* We only support IEEE floating point format */
607 #include "ieee-flpt.h"
609 /* The decode operations are out-of-line because they need to allocate
612 #ifdef FLOATS_AS_DOUBLES
613 #define decodeFloatzh_fast decodeDoublezh_fast
615 EF_(decodeFloatzh_fast);
618 EF_(decodeDoublezh_fast);
620 /* grimy low-level support functions defined in StgPrimFloat.c */
622 extern StgDouble __encodeDouble (I_ size, StgByteArray arr, I_ e);
623 extern StgDouble __int_encodeDouble (I_ j, I_ e);
624 #ifndef FLOATS_AS_DOUBLES
625 extern StgFloat __encodeFloat (I_ size, StgByteArray arr, I_ e);
626 extern StgFloat __int_encodeFloat (I_ j, I_ e);
628 extern void __decodeDouble (MP_INT *man, I_ *_exp, StgDouble dbl);
629 extern void __decodeFloat (MP_INT *man, I_ *_exp, StgFloat flt);
630 extern StgInt isDoubleNaN(StgDouble d);
631 extern StgInt isDoubleInfinite(StgDouble d);
632 extern StgInt isDoubleDenormalized(StgDouble d);
633 extern StgInt isDoubleNegativeZero(StgDouble d);
634 extern StgInt isFloatNaN(StgFloat f);
635 extern StgInt isFloatInfinite(StgFloat f);
636 extern StgInt isFloatDenormalized(StgFloat f);
637 extern StgInt isFloatNegativeZero(StgFloat f);
639 /* -----------------------------------------------------------------------------
642 newMutVar is out of line.
643 -------------------------------------------------------------------------- */
645 EF_(newMutVarzh_fast);
647 #define readMutVarzh(r,a) r=(P_)(((StgMutVar *)(a))->var)
648 #define writeMutVarzh(a,v) (P_)(((StgMutVar *)(a))->var)=(v)
649 #define sameMutVarzh(r,a,b) r=(I_)((a)==(b))
651 /* -----------------------------------------------------------------------------
654 All out of line, because they either allocate or may block.
655 -------------------------------------------------------------------------- */
656 #define sameMVarzh(r,a,b) r=(I_)((a)==(b))
658 /* Assume external decl of EMPTY_MVAR_info is in scope by now */
659 #define isEmptyMVarzh(r,a) r=(I_)((GET_INFO((StgMVar*)(a))) == &EMPTY_MVAR_info )
661 EF_(takeMVarzh_fast);
662 EF_(tryTakeMVarzh_fast);
666 /* -----------------------------------------------------------------------------
668 -------------------------------------------------------------------------- */
670 EF_(waitReadzh_fast);
671 EF_(waitWritezh_fast);
674 /* -----------------------------------------------------------------------------
675 Primitive I/O, error-handling PrimOps
676 -------------------------------------------------------------------------- */
681 extern void stg_exit(I_ n) __attribute__ ((noreturn));
683 /* -----------------------------------------------------------------------------
684 Stable Name / Stable Pointer PrimOps
685 -------------------------------------------------------------------------- */
689 EF_(makeStableNamezh_fast);
691 #define stableNameToIntzh(r,s) (r = ((StgStableName *)s)->sn)
693 #define eqStableNamezh(r,sn1,sn2) \
694 (r = (((StgStableName *)sn1)->sn == ((StgStableName *)sn2)->sn))
696 #define makeStablePtrzh(r,a) \
697 r = RET_STGCALL1(StgStablePtr,getStablePtr,a)
699 #define deRefStablePtrzh(r,sp) do { \
700 ASSERT(stable_ptr_table[stgCast(StgWord,sp) & ~STABLEPTR_WEIGHT_MASK].weight > 0); \
701 r = stable_ptr_table[stgCast(StgWord,sp) & ~STABLEPTR_WEIGHT_MASK].addr; \
704 #define eqStablePtrzh(r,sp1,sp2) \
705 (r = ((stgCast(StgWord,sp1) & ~STABLEPTR_WEIGHT_MASK) == (stgCast(StgWord,sp2) & ~STABLEPTR_WEIGHT_MASK)))
709 /* -----------------------------------------------------------------------------
710 Concurrency/Exception PrimOps.
711 -------------------------------------------------------------------------- */
715 EF_(killThreadzh_fast);
717 EF_(blockAsyncExceptionszh_fast);
718 EF_(unblockAsyncExceptionszh_fast);
720 #define myThreadIdzh(t) (t = CurrentTSO)
722 extern int cmp_thread(const StgTSO *tso1, const StgTSO *tso2);
724 /* ------------------------------------------------------------------------
727 A par in the Haskell code is ultimately translated to a parzh macro
728 (with a case wrapped around it to guarantee that the macro is actually
729 executed; see compiler/prelude/PrimOps.lhs)
730 In GUM and SMP we only add a pointer to the spark pool.
731 In GranSim we call an RTS fct, forwarding additional parameters which
732 supply info on granularity of the computation, size of the result value
733 and the degree of parallelism in the sparked expression.
734 ---------------------------------------------------------------------- */
738 #define parzh(r,node) PAR(r,node,1,0,0,0,0,0)
741 #define parAtzh(r,node,where,identifier,gran_info,size_info,par_info,rest) \
742 parAT(r,node,where,identifier,gran_info,size_info,par_info,rest,1)
745 #define parAtAbszh(r,node,proc,identifier,gran_info,size_info,par_info,rest) \
746 parAT(r,node,proc,identifier,gran_info,size_info,par_info,rest,2)
749 #define parAtRelzh(r,node,proc,identifier,gran_info,size_info,par_info,rest) \
750 parAT(r,node,proc,identifier,gran_info,size_info,par_info,rest,3)
752 //@cindex _parAtForNow_
753 #define parAtForNowzh(r,node,where,identifier,gran_info,size_info,par_info,rest) \
754 parAT(r,node,where,identifier,gran_info,size_info,par_info,rest,0)
756 #define parAT(r,node,where,identifier,gran_info,size_info,par_info,rest,local) \
758 if (closure_SHOULD_SPARK((StgClosure*)node)) { \
762 STGCALL6(newSpark, node,identifier,gran_info,size_info,par_info,local); \
764 case 2: p = where; /* parAtAbs means absolute PE no. expected */ \
766 case 3: p = CurrentProc+where; /* parAtRel means rel PE no. expected */\
768 default: p = where_is(where); /* parAt means closure expected */ \
771 /* update GranSim state according to this spark */ \
772 STGCALL3(GranSimSparkAtAbs, result, (I_)p, identifier); \
777 #define parLocalzh(r,node,identifier,gran_info,size_info,par_info,rest) \
778 PAR(r,node,rest,identifier,gran_info,size_info,par_info,1)
780 //@cindex _parGlobal_
781 #define parGlobalzh(r,node,identifier,gran_info,size_info,par_info,rest) \
782 PAR(r,node,rest,identifier,gran_info,size_info,par_info,0)
784 #define PAR(r,node,rest,identifier,gran_info,size_info,par_info,local) \
786 if (closure_SHOULD_SPARK((StgClosure*)node)) { \
788 result = RET_STGCALL6(rtsSpark*, newSpark, \
789 node,identifier,gran_info,size_info,par_info,local);\
790 STGCALL1(add_to_spark_queue,result); \
791 STGCALL2(GranSimSpark, local,(P_)node); \
795 #define copyablezh(r,node) \
796 /* copyable not yet implemented!! */
798 #define noFollowzh(r,node) \
799 /* noFollow not yet implemented!! */
801 #elif defined(SMP) || defined(PAR)
803 #define parzh(r,node) \
805 extern unsigned int context_switch; \
806 if (closure_SHOULD_SPARK((StgClosure *)node) && \
807 SparkTl < SparkLim) { \
808 *SparkTl++ = (StgClosure *)(node); \
810 r = context_switch = 1; \
812 #else /* !GRAN && !SMP && !PAR */
813 #define parzh(r,node) r = 1
816 /* -----------------------------------------------------------------------------
818 -------------------------------------------------------------------------- */
820 /* warning: extremely non-referentially transparent, need to hide in
821 an appropriate monad.
823 ToDo: follow indirections.
826 #define reallyUnsafePtrEqualityzh(r,a,b) r=((StgPtr)(a) == (StgPtr)(b))
828 /* -----------------------------------------------------------------------------
829 Weak Pointer PrimOps.
830 -------------------------------------------------------------------------- */
835 EF_(finalizzeWeakzh_fast);
837 #define deRefWeakzh(code,val,w) \
838 if (((StgWeak *)w)->header.info == &WEAK_info) { \
840 val = (P_)((StgWeak *)w)->value; \
846 #define sameWeakzh(w1,w2) ((w1)==(w2))
850 /* -----------------------------------------------------------------------------
851 Foreign Object PrimOps.
852 -------------------------------------------------------------------------- */
856 #define ForeignObj_CLOSURE_DATA(c) (((StgForeignObj *)c)->data)
858 EF_(mkForeignObjzh_fast);
860 #define writeForeignObjzh(res,datum) \
861 (ForeignObj_CLOSURE_DATA(res) = (P_)(datum))
863 #define eqForeignObj(f1,f2) ((f1)==(f2))
865 #define indexCharOffForeignObjzh(r,fo,i) indexCharOffAddrzh(r,ForeignObj_CLOSURE_DATA(fo),i)
866 #define indexIntOffForeignObjzh(r,fo,i) indexIntOffAddrzh(r,ForeignObj_CLOSURE_DATA(fo),i)
867 #define indexWordOffForeignObjzh(r,fo,i) indexWordOffAddrzh(r,ForeignObj_CLOSURE_DATA(fo),i)
868 #define indexAddrOffForeignObjzh(r,fo,i) indexAddrOffAddrzh(r,ForeignObj_CLOSURE_DATA(fo),i)
869 #define indexFloatOffForeignObjzh(r,fo,i) indexFloatOffAddrzh(r,ForeignObj_CLOSURE_DATA(fo),i)
870 #define indexDoubleOffForeignObjzh(r,fo,i) indexDoubleOffAddrzh(r,ForeignObj_CLOSURE_DATA(fo),i)
871 #define indexStablePtrOffForeignObjzh(r,fo,i) indexStablePtrOffAddrzh(r,ForeignObj_CLOSURE_DATA(fo),i)
872 #ifdef SUPPORT_LONG_LONGS
873 #define indexInt64OffForeignObjzh(r,fo,i) indexInt64OffAddrzh(r,ForeignObj_CLOSURE_DATA(fo),i)
874 #define indexWord64OffForeignObjzh(r,fo,i) indexWord64OffAddrzh(r,ForeignObj_CLOSURE_DATA(fo),i)
879 /* -----------------------------------------------------------------------------
881 -------------------------------------------------------------------------- */
883 #define dataToTagzh(r,a) r=(GET_TAG(((StgClosure *)a)->header.info))
884 /* tagToEnum# is handled directly by the code generator. */
886 /* -----------------------------------------------------------------------------
887 Signal processing. Not really primops, but called directly from
889 -------------------------------------------------------------------------- */
891 #define STG_SIG_DFL (-1)
892 #define STG_SIG_IGN (-2)
893 #define STG_SIG_ERR (-3)
894 #define STG_SIG_HAN (-4)
896 extern StgInt sig_install (StgInt, StgInt, StgStablePtr, sigset_t *);
897 #define stg_sig_default(sig,mask) sig_install(sig,STG_SIG_DFL,0,(sigset_t *)mask)
898 #define stg_sig_ignore(sig,mask) sig_install(sig,STG_SIG_IGN,0,(sigset_t *)mask)
899 #define stg_sig_catch(sig,ptr,mask) sig_install(sig,STG_SIG_HAN,ptr,(sigset_t *)mask)
901 #endif /* PRIMOPS_H */