1 /* -----------------------------------------------------------------------------
2 * $Id: PrimOps.h,v 1.19 1999/02/17 15:57:30 simonm 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 /* used by returning comparison primops, defined in Prims.hc. */
62 extern const StgClosure *PrelBase_Bool_closure_tbl[];
64 /* -----------------------------------------------------------------------------
66 -------------------------------------------------------------------------- */
68 #define ordzh(r,a) r=(I_)((W_) (a))
69 #define chrzh(r,a) r=(StgChar)((W_)(a))
71 /* -----------------------------------------------------------------------------
73 -------------------------------------------------------------------------- */
75 I_ stg_div (I_ a, I_ b);
77 #define zpzh(r,a,b) r=(a)+(b)
78 #define zmzh(r,a,b) r=(a)-(b)
79 #define ztzh(r,a,b) r=(a)*(b)
80 #define quotIntzh(r,a,b) r=(a)/(b)
81 #define zszh(r,a,b) r=ULTRASAFESTGCALL2(I_,(void *, I_, I_),stg_div,(a),(b))
82 #define remIntzh(r,a,b) r=(a)%(b)
83 #define negateIntzh(r,a) r=-(a)
85 /* -----------------------------------------------------------------------------
86 * Int operations with carry.
87 * -------------------------------------------------------------------------- */
89 /* With some bit-twiddling, we can define int{Add,Sub}Czh portably in
90 * C, and without needing any comparisons. This may not be the
91 * fastest way to do it - if you have better code, please send it! --SDM
93 * Return : r = a + b, c = 0 if no overflow, 1 on overflow.
95 * We currently don't make use of the r value if c is != 0 (i.e.
96 * overflow), we just convert to big integers and try again. This
97 * could be improved by making r and c the correct values for
98 * plugging into a new J#.
100 #define addIntCzh(r,c,a,b) \
102 c = ((StgWord)(~(a^b) & (a^r))) \
103 >> (BITS_PER_BYTE * sizeof(I_) - 1); \
107 #define subIntCzh(r,c,a,b) \
109 c = ((StgWord)((a^b) & (a^r))) \
110 >> (BITS_PER_BYTE * sizeof(I_) - 1); \
113 /* Multiply with overflow checking.
115 * This is slightly more tricky - the usual sign rules for add/subtract
118 * On x86 hardware we use a hand-crafted assembly fragment to do the job.
120 * On other 32-bit machines we use gcc's 'long long' types, finding
121 * overflow with some careful bit-twiddling.
123 * On 64-bit machines where gcc's 'long long' type is also 64-bits,
124 * we use a crude approximation, testing whether either operand is
125 * larger than 32-bits; if neither is, then we go ahead with the
131 #define mulIntCzh(r,c,a,b) \
133 __asm__("xor %1,%1\n\t \
138 : "=r" (r), "=r" (c) : "r" (a), "0" (b)); \
141 #elif SIZEOF_VOID_P == 4
143 #ifdef WORDS_BIGENDIAN
156 #define mulIntCzh(r,c,a,b) \
158 z.l = (StgInt64)a * (StgInt64)b; \
161 if (c == 0 || c == -1) { \
162 c = ((StgWord)((a^b) ^ r)) \
163 >> (BITS_PER_BYTE * sizeof(I_) - 1); \
166 /* Careful: the carry calculation above is extremely delicate. Make sure
167 * you test it thoroughly after changing it.
172 #define HALF_INT (1 << (BITS_PER_BYTE * sizeof(I_) / 2))
174 #define stg_abs(a) ((a) < 0 ? -(a) : (a))
176 #define mulIntCzh(r,c,a,b) \
178 if (stg_abs(a) >= HALF_INT \
179 stg_abs(b) >= HALF_INT) { \
188 /* -----------------------------------------------------------------------------
190 -------------------------------------------------------------------------- */
192 #define quotWordzh(r,a,b) r=((W_)a)/((W_)b)
193 #define remWordzh(r,a,b) r=((W_)a)%((W_)b)
195 #define andzh(r,a,b) r=(a)&(b)
196 #define orzh(r,a,b) r=(a)|(b)
197 #define xorzh(r,a,b) r=(a)^(b)
198 #define notzh(r,a) r=~(a)
200 #define shiftLzh(r,a,b) r=(a)<<(b)
201 #define shiftRLzh(r,a,b) r=(a)>>(b)
202 #define iShiftLzh(r,a,b) r=(a)<<(b)
203 /* Right shifting of signed quantities is not portable in C, so
204 the behaviour you'll get from using these primops depends
205 on the whatever your C compiler is doing. ToDo: fix/document. -- sof 8/98
207 #define iShiftRAzh(r,a,b) r=(a)>>(b)
208 #define iShiftRLzh(r,a,b) r=(a)>>(b)
210 #define int2Wordzh(r,a) r=(W_)(a)
211 #define word2Intzh(r,a) r=(I_)(a)
213 /* -----------------------------------------------------------------------------
215 -------------------------------------------------------------------------- */
217 #define int2Addrzh(r,a) r=(A_)(a)
218 #define addr2Intzh(r,a) r=(I_)(a)
220 #define indexCharOffAddrzh(r,a,i) r= ((C_ *)(a))[i]
221 #define indexIntOffAddrzh(r,a,i) r= ((I_ *)(a))[i]
222 #define indexAddrOffAddrzh(r,a,i) r= ((PP_)(a))[i]
223 #define indexFloatOffAddrzh(r,a,i) r= PK_FLT((P_) (((StgFloat *)(a)) + i))
224 #define indexDoubleOffAddrzh(r,a,i) r= PK_DBL((P_) (((StgDouble *)(a)) + i))
225 #define indexStablePtrOffAddrzh(r,a,i) r= ((StgStablePtr *)(a))[i]
226 #ifdef SUPPORT_LONG_LONGS
227 #define indexInt64OffAddrzh(r,a,i) r= ((LI_ *)(a))[i]
228 #define indexWord64OffAddrzh(r,a,i) r= ((LW_ *)(a))[i]
231 #define writeCharOffAddrzh(a,i,v) ((C_ *)(a))[i] = (v)
232 #define writeIntOffAddrzh(a,i,v) ((I_ *)(a))[i] = (v)
233 #define writeWordOffAddrzh(a,i,v) ((W_ *)(a))[i] = (v)
234 #define writeAddrOffAddrzh(a,i,v) ((PP_)(a))[i] = (v)
235 #define writeForeignObjOffAddrzh(a,i,v) ((PP_)(a))[i] = ForeignObj_CLOSURE_DATA(v)
236 #define writeFloatOffAddrzh(a,i,v) ASSIGN_FLT((P_) (((StgFloat *)(a)) + i),v)
237 #define writeDoubleOffAddrzh(a,i,v) ASSIGN_DBL((P_) (((StgDouble *)(a)) + i),v)
238 #define writeStablePtrOffAddrzh(a,i,v) ((StgStablePtr *)(a))[i] = (v)
239 #ifdef SUPPORT_LONG_LONGS
240 #define writeInt64OffAddrzh(a,i,v) ((LI_ *)(a))[i] = (v)
241 #define writeWord64OffAddrzh(a,i,v) ((LW_ *)(a))[i] = (v)
244 /* -----------------------------------------------------------------------------
246 -------------------------------------------------------------------------- */
248 #define plusFloatzh(r,a,b) r=(a)+(b)
249 #define minusFloatzh(r,a,b) r=(a)-(b)
250 #define timesFloatzh(r,a,b) r=(a)*(b)
251 #define divideFloatzh(r,a,b) r=(a)/(b)
252 #define negateFloatzh(r,a) r=-(a)
254 #define int2Floatzh(r,a) r=(StgFloat)(a)
255 #define float2Intzh(r,a) r=(I_)(a)
257 #define expFloatzh(r,a) r=(StgFloat) RET_PRIM_STGCALL1(StgDouble,exp,a)
258 #define logFloatzh(r,a) r=(StgFloat) RET_PRIM_STGCALL1(StgDouble,log,a)
259 #define sqrtFloatzh(r,a) r=(StgFloat) RET_PRIM_STGCALL1(StgDouble,sqrt,a)
260 #define sinFloatzh(r,a) r=(StgFloat) RET_PRIM_STGCALL1(StgDouble,sin,a)
261 #define cosFloatzh(r,a) r=(StgFloat) RET_PRIM_STGCALL1(StgDouble,cos,a)
262 #define tanFloatzh(r,a) r=(StgFloat) RET_PRIM_STGCALL1(StgDouble,tan,a)
263 #define asinFloatzh(r,a) r=(StgFloat) RET_PRIM_STGCALL1(StgDouble,asin,a)
264 #define acosFloatzh(r,a) r=(StgFloat) RET_PRIM_STGCALL1(StgDouble,acos,a)
265 #define atanFloatzh(r,a) r=(StgFloat) RET_PRIM_STGCALL1(StgDouble,atan,a)
266 #define sinhFloatzh(r,a) r=(StgFloat) RET_PRIM_STGCALL1(StgDouble,sinh,a)
267 #define coshFloatzh(r,a) r=(StgFloat) RET_PRIM_STGCALL1(StgDouble,cosh,a)
268 #define tanhFloatzh(r,a) r=(StgFloat) RET_PRIM_STGCALL1(StgDouble,tanh,a)
269 #define powerFloatzh(r,a,b) r=(StgFloat) RET_PRIM_STGCALL2(StgDouble,pow,a,b)
271 /* -----------------------------------------------------------------------------
273 -------------------------------------------------------------------------- */
275 #define zpzhzh(r,a,b) r=(a)+(b)
276 #define zmzhzh(r,a,b) r=(a)-(b)
277 #define ztzhzh(r,a,b) r=(a)*(b)
278 #define zszhzh(r,a,b) r=(a)/(b)
279 #define negateDoublezh(r,a) r=-(a)
281 #define int2Doublezh(r,a) r=(StgDouble)(a)
282 #define double2Intzh(r,a) r=(I_)(a)
284 #define float2Doublezh(r,a) r=(StgDouble)(a)
285 #define double2Floatzh(r,a) r=(StgFloat)(a)
287 #define expDoublezh(r,a) r=(StgDouble) RET_PRIM_STGCALL1(StgDouble,exp,a)
288 #define logDoublezh(r,a) r=(StgDouble) RET_PRIM_STGCALL1(StgDouble,log,a)
289 #define sqrtDoublezh(r,a) r=(StgDouble) RET_PRIM_STGCALL1(StgDouble,sqrt,a)
290 #define sinDoublezh(r,a) r=(StgDouble) RET_PRIM_STGCALL1(StgDouble,sin,a)
291 #define cosDoublezh(r,a) r=(StgDouble) RET_PRIM_STGCALL1(StgDouble,cos,a)
292 #define tanDoublezh(r,a) r=(StgDouble) RET_PRIM_STGCALL1(StgDouble,tan,a)
293 #define asinDoublezh(r,a) r=(StgDouble) RET_PRIM_STGCALL1(StgDouble,asin,a)
294 #define acosDoublezh(r,a) r=(StgDouble) RET_PRIM_STGCALL1(StgDouble,acos,a)
295 #define atanDoublezh(r,a) r=(StgDouble) RET_PRIM_STGCALL1(StgDouble,atan,a)
296 #define sinhDoublezh(r,a) r=(StgDouble) RET_PRIM_STGCALL1(StgDouble,sinh,a)
297 #define coshDoublezh(r,a) r=(StgDouble) RET_PRIM_STGCALL1(StgDouble,cosh,a)
298 #define tanhDoublezh(r,a) r=(StgDouble) RET_PRIM_STGCALL1(StgDouble,tanh,a)
300 #define ztztzhzh(r,a,b) r=(StgDouble) RET_PRIM_STGCALL2(StgDouble,pow,a,b)
302 /* -----------------------------------------------------------------------------
304 -------------------------------------------------------------------------- */
306 /* We can do integer2Int and cmpInteger inline, since they don't need
307 * to allocate any memory.
310 #define integer2Intzh(r, sa,da) \
313 arg._mp_size = (sa); \
314 arg._mp_alloc = ((StgArrWords *)da)->words; \
315 arg._mp_d = (unsigned long int *) (BYTE_ARR_CTS(da)); \
317 (r) = RET_PRIM_STGCALL1(I_,mpz_get_si,&arg); \
320 #define integer2Wordzh(r, sa,da) \
323 arg._mp_size = (sa); \
324 arg._mp_alloc = ((StgArrWords *)da)->words; \
325 arg._mp_d = (unsigned long int *) (BYTE_ARR_CTS(da)); \
327 (r) = RET_PRIM_STGCALL1(I_,mpz_get_ui,&arg); \
330 #define cmpIntegerzh(r, s1,d1, s2,d2) \
334 arg1._mp_size = (s1); \
335 arg1._mp_alloc= ((StgArrWords *)d1)->words; \
336 arg1._mp_d = (unsigned long int *) (BYTE_ARR_CTS(d1)); \
337 arg2._mp_size = (s2); \
338 arg2._mp_alloc= ((StgArrWords *)d2)->words; \
339 arg2._mp_d = (unsigned long int *) (BYTE_ARR_CTS(d2)); \
341 (r) = RET_PRIM_STGCALL2(I_,mpz_cmp,&arg1,&arg2); \
344 #define cmpIntegerIntzh(r, s,d, i) \
347 arg._mp_size = (s); \
348 arg._mp_alloc = ((StgArrWords *)d)->words; \
349 arg._mp_d = (unsigned long int *) (BYTE_ARR_CTS(d)); \
351 (r) = RET_PRIM_STGCALL2(I_,mpz_cmp_si,&arg,i); \
354 /* The rest are all out-of-line: -------- */
356 /* Integer arithmetic */
357 EF_(plusIntegerzh_fast);
358 EF_(minusIntegerzh_fast);
359 EF_(timesIntegerzh_fast);
360 EF_(gcdIntegerzh_fast);
361 EF_(quotRemIntegerzh_fast);
362 EF_(divModIntegerzh_fast);
365 EF_(int2Integerzh_fast);
366 EF_(word2Integerzh_fast);
367 EF_(addr2Integerzh_fast);
369 /* Floating-point decodings */
370 EF_(decodeFloatzh_fast);
371 EF_(decodeDoublezh_fast);
373 /* -----------------------------------------------------------------------------
375 -------------------------------------------------------------------------- */
377 #ifdef SUPPORT_LONG_LONGS
379 #define integerToWord64zh(r, sa,da) \
380 { unsigned long int* d; \
384 d = (unsigned long int *) (BYTE_ARR_CTS(da)); \
385 aa = ((StgArrWords *)da)->words; \
388 } else if ( (aa) == 1) { \
391 res = (LW_)d[0] + (LW_)d[1] * 0x100000000ULL; \
396 #define integerToInt64zh(r, sa,da) \
397 { unsigned long int* d; \
401 d = (unsigned long int *) (BYTE_ARR_CTS(da)); \
402 aa = ((StgArrWords *)da)->words; \
405 } else if ( (aa) == 1) { \
408 res = (LI_)d[0] + (LI_)d[1] * 0x100000000LL; \
417 EF_(int64ToIntegerzh_fast);
418 EF_(word64ToIntegerzh_fast);
420 /* The rest are (way!) out of line, implemented via C entry points.
422 I_ stg_gtWord64 (StgNat64, StgNat64);
423 I_ stg_geWord64 (StgNat64, StgNat64);
424 I_ stg_eqWord64 (StgNat64, StgNat64);
425 I_ stg_neWord64 (StgNat64, StgNat64);
426 I_ stg_ltWord64 (StgNat64, StgNat64);
427 I_ stg_leWord64 (StgNat64, StgNat64);
429 I_ stg_gtInt64 (StgInt64, StgInt64);
430 I_ stg_geInt64 (StgInt64, StgInt64);
431 I_ stg_eqInt64 (StgInt64, StgInt64);
432 I_ stg_neInt64 (StgInt64, StgInt64);
433 I_ stg_ltInt64 (StgInt64, StgInt64);
434 I_ stg_leInt64 (StgInt64, StgInt64);
436 LW_ stg_remWord64 (StgNat64, StgNat64);
437 LW_ stg_quotWord64 (StgNat64, StgNat64);
439 LI_ stg_remInt64 (StgInt64, StgInt64);
440 LI_ stg_quotInt64 (StgInt64, StgInt64);
441 LI_ stg_negateInt64 (StgInt64);
442 LI_ stg_plusInt64 (StgInt64, StgInt64);
443 LI_ stg_minusInt64 (StgInt64, StgInt64);
444 LI_ stg_timesInt64 (StgInt64, StgInt64);
446 LW_ stg_and64 (StgNat64, StgNat64);
447 LW_ stg_or64 (StgNat64, StgNat64);
448 LW_ stg_xor64 (StgNat64, StgNat64);
449 LW_ stg_not64 (StgNat64);
451 LW_ stg_shiftL64 (StgNat64, StgInt);
452 LW_ stg_shiftRL64 (StgNat64, StgInt);
453 LI_ stg_iShiftL64 (StgInt64, StgInt);
454 LI_ stg_iShiftRL64 (StgInt64, StgInt);
455 LI_ stg_iShiftRA64 (StgInt64, StgInt);
457 LI_ stg_intToInt64 (StgInt);
458 I_ stg_int64ToInt (StgInt64);
459 LW_ stg_int64ToWord64 (StgInt64);
461 LW_ stg_wordToWord64 (StgWord);
462 W_ stg_word64ToWord (StgNat64);
463 LI_ stg_word64ToInt64 (StgNat64);
466 /* -----------------------------------------------------------------------------
468 -------------------------------------------------------------------------- */
470 /* We cast to void* instead of StgChar* because this avoids a warning
471 * about increasing the alignment requirements.
473 #define REAL_BYTE_ARR_CTS(a) ((void *) (((StgArrWords *)(a))->payload))
474 #define REAL_PTRS_ARR_CTS(a) ((P_) (((StgMutArrPtrs *)(a))->payload))
477 #define BYTE_ARR_CTS(a) \
478 ({ ASSERT(GET_INFO(a) == &ARR_WORDS_info); \
479 REAL_BYTE_ARR_CTS(a); })
480 #define PTRS_ARR_CTS(a) \
481 ({ ASSERT((GET_INFO(a) == &ARR_PTRS_info) \
482 || (GET_INFO(a) == &MUT_ARR_PTRS_info)); \
483 REAL_PTRS_ARR_CTS(a); })
485 #define BYTE_ARR_CTS(a) REAL_BYTE_ARR_CTS(a)
486 #define PTRS_ARR_CTS(a) REAL_PTRS_ARR_CTS(a)
489 extern I_ genSymZh(void);
490 extern I_ resetGenSymZh(void);
492 /*--- everything except new*Array is done inline: */
494 #define sameMutableArrayzh(r,a,b) r=(I_)((a)==(b))
495 #define sameMutableByteArrayzh(r,a,b) r=(I_)((a)==(b))
497 #define readArrayzh(r,a,i) r=((PP_) PTRS_ARR_CTS(a))[(i)]
499 #define readCharArrayzh(r,a,i) indexCharOffAddrzh(r,BYTE_ARR_CTS(a),i)
500 #define readIntArrayzh(r,a,i) indexIntOffAddrzh(r,BYTE_ARR_CTS(a),i)
501 #define readWordArrayzh(r,a,i) indexWordOffAddrzh(r,BYTE_ARR_CTS(a),i)
502 #define readAddrArrayzh(r,a,i) indexAddrOffAddrzh(r,BYTE_ARR_CTS(a),i)
503 #define readFloatArrayzh(r,a,i) indexFloatOffAddrzh(r,BYTE_ARR_CTS(a),i)
504 #define readDoubleArrayzh(r,a,i) indexDoubleOffAddrzh(r,BYTE_ARR_CTS(a),i)
505 #define readStablePtrArrayzh(r,a,i) indexStablePtrOffAddrzh(r,BYTE_ARR_CTS(a),i)
506 #ifdef SUPPORT_LONG_LONGS
507 #define readInt64Arrayzh(r,a,i) indexInt64OffAddrzh(r,BYTE_ARR_CTS(a),i)
508 #define readWord64Arrayzh(r,a,i) indexWord64OffAddrzh(r,BYTE_ARR_CTS(a),i)
511 /* result ("r") arg ignored in write macros! */
512 #define writeArrayzh(a,i,v) ((PP_) PTRS_ARR_CTS(a))[(i)]=(v)
514 #define writeCharArrayzh(a,i,v) ((C_ *)(BYTE_ARR_CTS(a)))[i] = (v)
515 #define writeIntArrayzh(a,i,v) ((I_ *)(BYTE_ARR_CTS(a)))[i] = (v)
516 #define writeWordArrayzh(a,i,v) ((W_ *)(BYTE_ARR_CTS(a)))[i] = (v)
517 #define writeAddrArrayzh(a,i,v) ((PP_)(BYTE_ARR_CTS(a)))[i] = (v)
518 #define writeFloatArrayzh(a,i,v) \
519 ASSIGN_FLT((P_) (((StgFloat *)(BYTE_ARR_CTS(a))) + i),v)
520 #define writeDoubleArrayzh(a,i,v) \
521 ASSIGN_DBL((P_) (((StgDouble *)(BYTE_ARR_CTS(a))) + i),v)
522 #define writeStablePtrArrayzh(a,i,v) ((StgStablePtr *)(BYTE_ARR_CTS(a)))[i] = (v)
523 #ifdef SUPPORT_LONG_LONGS
524 #define writeInt64Arrayzh(a,i,v) ((LI_ *)(BYTE_ARR_CTS(a)))[i] = (v)
525 #define writeWord64Arrayzh(a,i,v) ((LW_ *)(BYTE_ARR_CTS(a)))[i] = (v)
528 #define indexArrayzh(r,a,i) r=((PP_) PTRS_ARR_CTS(a))[(i)]
530 #define indexCharArrayzh(r,a,i) indexCharOffAddrzh(r,BYTE_ARR_CTS(a),i)
531 #define indexIntArrayzh(r,a,i) indexIntOffAddrzh(r,BYTE_ARR_CTS(a),i)
532 #define indexWordArrayzh(r,a,i) indexWordOffAddrzh(r,BYTE_ARR_CTS(a),i)
533 #define indexAddrArrayzh(r,a,i) indexAddrOffAddrzh(r,BYTE_ARR_CTS(a),i)
534 #define indexFloatArrayzh(r,a,i) indexFloatOffAddrzh(r,BYTE_ARR_CTS(a),i)
535 #define indexDoubleArrayzh(r,a,i) indexDoubleOffAddrzh(r,BYTE_ARR_CTS(a),i)
536 #define indexStablePtrArrayzh(r,a,i) indexStablePtrOffAddrzh(r,BYTE_ARR_CTS(a),i)
537 #ifdef SUPPORT_LONG_LONGS
538 #define indexInt64Arrayzh(r,a,i) indexInt64OffAddrzh(r,BYTE_ARR_CTS(a),i)
539 #define indexWord64Arrayzh(r,a,i) indexWord64OffAddrzh(r,BYTE_ARR_CTS(a),i)
542 #define indexCharOffForeignObjzh(r,fo,i) indexCharOffAddrzh(r,ForeignObj_CLOSURE_DATA(fo),i)
543 #define indexIntOffForeignObjzh(r,fo,i) indexIntOffAddrzh(r,ForeignObj_CLOSURE_DATA(fo),i)
544 #define indexWordOffForeignObjzh(r,fo,i) indexWordOffAddrzh(r,ForeignObj_CLOSURE_DATA(fo),i)
545 #define indexAddrOffForeignObjzh(r,fo,i) indexAddrOffAddrzh(r,ForeignObj_CLOSURE_DATA(fo),i)
546 #define indexFloatOffForeignObjzh(r,fo,i) indexFloatOffAddrzh(r,ForeignObj_CLOSURE_DATA(fo),i)
547 #define indexDoubleOffForeignObjzh(r,fo,i) indexDoubleOffAddrzh(r,ForeignObj_CLOSURE_DATA(fo),i)
548 #define indexStablePtrOffForeignObjzh(r,fo,i) indexStablePtrOffAddrzh(r,ForeignObj_CLOSURE_DATA(fo),i)
549 #ifdef SUPPORT_LONG_LONGS
550 #define indexInt64OffForeignObjzh(r,fo,i) indexInt64OffAddrzh(r,ForeignObj_CLOSURE_DATA(fo),i)
551 #define indexWord64OffForeignObjzh(r,fo,i) indexWord64OffAddrzh(r,ForeignObj_CLOSURE_DATA(fo),i)
554 #define indexCharOffAddrzh(r,a,i) r= ((C_ *)(a))[i]
555 #define indexIntOffAddrzh(r,a,i) r= ((I_ *)(a))[i]
556 #define indexWordOffAddrzh(r,a,i) r= ((W_ *)(a))[i]
557 #define indexAddrOffAddrzh(r,a,i) r= ((PP_)(a))[i]
558 #define indexFloatOffAddrzh(r,a,i) r= PK_FLT((P_) (((StgFloat *)(a)) + i))
559 #define indexDoubleOffAddrzh(r,a,i) r= PK_DBL((P_) (((StgDouble *)(a)) + i))
560 #ifdef SUPPORT_LONG_LONGS
561 #define indexInt64OffAddrzh(r,a,i) r= ((LI_ *)(a))[i]
562 #define indexWord64OffAddrzh(r,a,i) r= ((LW_ *)(a))[i]
565 /* Freezing arrays-of-ptrs requires changing an info table, for the
566 benefit of the generational collector. It needs to scavenge mutable
567 objects, even if they are in old space. When they become immutable,
568 they can be removed from this scavenge list. */
570 #define unsafeFreezzeArrayzh(r,a) \
572 SET_INFO((StgClosure *)a,&MUT_ARR_PTRS_FROZEN_info); \
576 #define unsafeFreezzeByteArrayzh(r,a) r=(a)
578 #define sizzeofByteArrayzh(r,a) \
579 r = (((StgArrWords *)(a))->words * sizeof(W_))
580 #define sizzeofMutableByteArrayzh(r,a) \
581 r = (((StgArrWords *)(a))->words * sizeof(W_))
583 /* and the out-of-line ones... */
585 EF_(newCharArrayzh_fast);
586 EF_(newIntArrayzh_fast);
587 EF_(newWordArrayzh_fast);
588 EF_(newAddrArrayzh_fast);
589 EF_(newFloatArrayzh_fast);
590 EF_(newDoubleArrayzh_fast);
591 EF_(newStablePtrArrayzh_fast);
592 EF_(newArrayzh_fast);
594 /* encoding and decoding of floats/doubles. */
596 /* We only support IEEE floating point format */
597 #include "ieee-flpt.h"
599 #if FLOATS_AS_DOUBLES /* i.e. 64-bit machines */
600 #define encodeFloatzh(r, sa,da, expon) encodeDoublezh(r, sa,da, expon)
602 #define encodeFloatzh(r, sa,da, expon) \
604 /* Does not allocate memory */ \
607 arg._mp_alloc = ((StgArrWords *)da)->words; \
608 arg._mp_d = (unsigned long int *) (BYTE_ARR_CTS(da)); \
610 r = RET_PRIM_STGCALL2(StgFloat, __encodeFloat,&arg,(expon)); \
612 #endif /* FLOATS_AS_DOUBLES */
614 #define encodeDoublezh(r, sa,da, expon) \
616 /* Does not allocate memory */ \
619 arg._mp_alloc = ((StgArrWords *)da)->words; \
620 arg._mp_d = (unsigned long int *) (BYTE_ARR_CTS(da)); \
622 r = RET_PRIM_STGCALL2(StgDouble, __encodeDouble,&arg,(expon)); \
625 /* The decode operations are out-of-line because they need to allocate
629 #ifdef FLOATS_AS_DOUBLES
630 #define decodeFloatzh_fast decodeDoublezh_fast
632 EF_(decodeFloatzh_fast);
635 EF_(decodeDoublezh_fast);
637 /* grimy low-level support functions defined in StgPrimFloat.c */
639 extern StgDouble __encodeDouble (MP_INT *s, I_ e);
640 extern StgFloat __encodeFloat (MP_INT *s, I_ e);
641 extern void __decodeDouble (MP_INT *man, I_ *_exp, StgDouble dbl);
642 extern void __decodeFloat (MP_INT *man, I_ *_exp, StgFloat flt);
643 extern StgInt isDoubleNaN(StgDouble d);
644 extern StgInt isDoubleInfinite(StgDouble d);
645 extern StgInt isDoubleDenormalized(StgDouble d);
646 extern StgInt isDoubleNegativeZero(StgDouble d);
647 extern StgInt isFloatNaN(StgFloat f);
648 extern StgInt isFloatInfinite(StgFloat f);
649 extern StgInt isFloatDenormalized(StgFloat f);
650 extern StgInt isFloatNegativeZero(StgFloat f);
652 /* -----------------------------------------------------------------------------
655 newMutVar is out of line.
656 -------------------------------------------------------------------------- */
658 EF_(newMutVarzh_fast);
660 #define readMutVarzh(r,a) r=(P_)(((StgMutVar *)(a))->var)
661 #define writeMutVarzh(a,v) (P_)(((StgMutVar *)(a))->var)=(v)
662 #define sameMutVarzh(r,a,b) r=(I_)((a)==(b))
664 /* -----------------------------------------------------------------------------
667 All out of line, because they either allocate or may block.
668 -------------------------------------------------------------------------- */
669 #define sameMVarzh(r,a,b) r=(I_)((a)==(b))
671 /* Assume external decl of EMPTY_MVAR_info is in scope by now */
672 #define isEmptyMVarzh(r,a) r=(I_)((GET_INFO((StgMVar*)(a))) == &EMPTY_MVAR_info )
674 EF_(takeMVarzh_fast);
678 /* -----------------------------------------------------------------------------
680 -------------------------------------------------------------------------- */
682 /* Hmm, I'll think about these later. */
684 /* -----------------------------------------------------------------------------
685 Primitive I/O, error-handling PrimOps
686 -------------------------------------------------------------------------- */
691 extern void stg_exit(I_ n) __attribute__ ((noreturn));
693 /* -----------------------------------------------------------------------------
694 Stable Name / Stable Pointer PrimOps
695 -------------------------------------------------------------------------- */
699 EF_(makeStableNamezh_fast);
701 #define stableNameToIntzh(r,s) (r = ((StgStableName *)s)->sn)
703 #define eqStableNamezh(r,sn1,sn2) \
704 (r = (((StgStableName *)sn1)->sn == ((StgStableName *)sn2)->sn))
706 #define makeStablePtrzh(r,a) \
707 r = RET_STGCALL1(StgStablePtr,getStablePtr,a)
709 #define deRefStablePtrzh(r,sp) do { \
710 ASSERT(stable_ptr_table[sp & ~STABLEPTR_WEIGHT_MASK].weight > 0); \
711 r = stable_ptr_table[sp & ~STABLEPTR_WEIGHT_MASK].addr; \
714 #define eqStablePtrzh(r,sp1,sp2) \
715 (r = ((sp1 & ~STABLEPTR_WEIGHT_MASK) == (sp2 & ~STABLEPTR_WEIGHT_MASK)))
719 /* -----------------------------------------------------------------------------
721 -------------------------------------------------------------------------- */
724 EF_(killThreadzh_fast);
727 /* Hmm, I'll think about these later. */
728 /* -----------------------------------------------------------------------------
730 -------------------------------------------------------------------------- */
732 /* warning: extremely non-referentially transparent, need to hide in
733 an appropriate monad.
735 ToDo: follow indirections.
738 #define reallyUnsafePtrEqualityzh(r,a,b) r=((StgPtr)(a) == (StgPtr)(b))
740 /* -----------------------------------------------------------------------------
741 Weak Pointer PrimOps.
742 -------------------------------------------------------------------------- */
747 EF_(finalizzeWeakzh_fast);
749 #define deRefWeakzh(code,val,w) \
750 if (((StgWeak *)w)->header.info == &WEAK_info) { \
752 val = (P_)((StgWeak *)w)->value; \
758 #define sameWeakzh(w1,w2) ((w1)==(w2))
762 /* -----------------------------------------------------------------------------
763 Foreign Object PrimOps.
764 -------------------------------------------------------------------------- */
768 #define ForeignObj_CLOSURE_DATA(c) (((StgForeignObj *)c)->data)
770 EF_(makeForeignObjzh_fast);
772 #define writeForeignObjzh(res,datum) \
773 (ForeignObj_CLOSURE_DATA(res) = (P_)(datum))
775 #define eqForeignObj(f1,f2) ((f1)==(f2))
779 /* -----------------------------------------------------------------------------
780 Signal processing. Not really primops, but called directly from
782 -------------------------------------------------------------------------- */
784 #define STG_SIG_DFL (-1)
785 #define STG_SIG_IGN (-2)
786 #define STG_SIG_ERR (-3)
787 #define STG_SIG_HAN (-4)
789 extern StgInt sig_install (StgInt, StgInt, StgStablePtr, sigset_t *);
790 #define stg_sig_default(sig,mask) sig_install(sig,STG_SIG_DFL,0,(sigset_t *)mask)
791 #define stg_sig_ignore(sig,mask) sig_install(sig,STG_SIG_IGN,0,(sigset_t *)mask)
792 #define stg_sig_catch(sig,ptr,mask) sig_install(sig,STG_SIG_HAN,ptr,(sigset_t *)mask)