1 /* -----------------------------------------------------------------------------
2 * $Id: PrimOps.h,v 1.9 1999/01/23 17:48:23 sof Exp $
4 * Macros for primitive operations in STG-ish C code.
6 * ---------------------------------------------------------------------------*/
11 /* -----------------------------------------------------------------------------
13 -------------------------------------------------------------------------- */
15 #define gtCharZh(r,a,b) r=(I_)((a)> (b))
16 #define geCharZh(r,a,b) r=(I_)((a)>=(b))
17 #define eqCharZh(r,a,b) r=(I_)((a)==(b))
18 #define neCharZh(r,a,b) r=(I_)((a)!=(b))
19 #define ltCharZh(r,a,b) r=(I_)((a)< (b))
20 #define leCharZh(r,a,b) r=(I_)((a)<=(b))
22 /* Int comparisons: >#, >=# etc */
23 #define ZgZh(r,a,b) r=(I_)((I_)(a) >(I_)(b))
24 #define ZgZeZh(r,a,b) r=(I_)((I_)(a)>=(I_)(b))
25 #define ZeZeZh(r,a,b) r=(I_)((I_)(a)==(I_)(b))
26 #define ZdZeZh(r,a,b) r=(I_)((I_)(a)!=(I_)(b))
27 #define ZlZh(r,a,b) r=(I_)((I_)(a) <(I_)(b))
28 #define ZlZeZh(r,a,b) r=(I_)((I_)(a)<=(I_)(b))
30 #define gtWordZh(r,a,b) r=(I_)((W_)(a) >(W_)(b))
31 #define geWordZh(r,a,b) r=(I_)((W_)(a)>=(W_)(b))
32 #define eqWordZh(r,a,b) r=(I_)((W_)(a)==(W_)(b))
33 #define neWordZh(r,a,b) r=(I_)((W_)(a)!=(W_)(b))
34 #define ltWordZh(r,a,b) r=(I_)((W_)(a) <(W_)(b))
35 #define leWordZh(r,a,b) r=(I_)((W_)(a)<=(W_)(b))
37 #define gtAddrZh(r,a,b) r=(I_)((a) >(b))
38 #define geAddrZh(r,a,b) r=(I_)((a)>=(b))
39 #define eqAddrZh(r,a,b) r=(I_)((a)==(b))
40 #define neAddrZh(r,a,b) r=(I_)((a)!=(b))
41 #define ltAddrZh(r,a,b) r=(I_)((a) <(b))
42 #define leAddrZh(r,a,b) r=(I_)((a)<=(b))
44 #define gtFloatZh(r,a,b) r=(I_)((a)> (b))
45 #define geFloatZh(r,a,b) r=(I_)((a)>=(b))
46 #define eqFloatZh(r,a,b) r=(I_)((a)==(b))
47 #define neFloatZh(r,a,b) r=(I_)((a)!=(b))
48 #define ltFloatZh(r,a,b) r=(I_)((a)< (b))
49 #define leFloatZh(r,a,b) r=(I_)((a)<=(b))
51 /* Double comparisons: >##, >=#@ etc */
52 #define ZgZhZh(r,a,b) r=(I_)((a) >(b))
53 #define ZgZeZhZh(r,a,b) r=(I_)((a)>=(b))
54 #define ZeZeZhZh(r,a,b) r=(I_)((a)==(b))
55 #define ZdZeZhZh(r,a,b) r=(I_)((a)!=(b))
56 #define ZlZhZh(r,a,b) r=(I_)((a) <(b))
57 #define ZlZeZhZh(r,a,b) r=(I_)((a)<=(b))
59 /* used by returning comparison primops, defined in Prims.hc. */
60 extern const StgClosure *PrelBase_Bool_closure_tbl[];
62 /* -----------------------------------------------------------------------------
64 -------------------------------------------------------------------------- */
66 #define ordZh(r,a) r=(I_)((W_) (a))
67 #define chrZh(r,a) r=(StgChar)((W_)(a))
69 /* -----------------------------------------------------------------------------
71 -------------------------------------------------------------------------- */
73 I_ stg_div (I_ a, I_ b);
75 #define ZpZh(r,a,b) r=(a)+(b)
76 #define ZmZh(r,a,b) r=(a)-(b)
77 #define ZtZh(r,a,b) r=(a)*(b)
78 #define quotIntZh(r,a,b) r=(a)/(b)
79 #define ZdZh(r,a,b) r=ULTRASAFESTGCALL2(I_,(void *, I_, I_),stg_div,(a),(b))
80 #define remIntZh(r,a,b) r=(a)%(b)
81 #define negateIntZh(r,a) r=-(a)
83 /* The following operations are the standard add,subtract and multiply
84 * except that they return a carry if the operation overflows.
86 * They are all defined in terms of 32-bit integers and use the GCC
87 * 'long long' extension to get a 64-bit result. We'd like to use
88 * 64-bit integers on 64-bit architectures, but it seems that gcc's
89 * 'long long' type is set at 64-bits even on a 64-bit machine.
92 #ifdef WORDS_BIGENDIAN
105 #define addWithCarryZh(r,c,a,b) \
114 #define subWithCarryZh(r,c,a,b) \
121 #define mulWithCarryZh(r,c,a,b) \
128 /* -----------------------------------------------------------------------------
130 -------------------------------------------------------------------------- */
132 #define quotWordZh(r,a,b) r=((W_)a)/((W_)b)
133 #define remWordZh(r,a,b) r=((W_)a)%((W_)b)
135 #define andZh(r,a,b) r=(a)&(b)
136 #define orZh(r,a,b) r=(a)|(b)
137 #define xorZh(r,a,b) r=(a)^(b)
138 #define notZh(r,a) r=~(a)
140 #define shiftLZh(r,a,b) r=(a)<<(b)
141 #define shiftRLZh(r,a,b) r=(a)>>(b)
142 #define iShiftLZh(r,a,b) r=(a)<<(b)
143 /* Right shifting of signed quantities is not portable in C, so
144 the behaviour you'll get from using these primops depends
145 on the whatever your C compiler is doing. ToDo: fix/document. -- sof 8/98
147 #define iShiftRAZh(r,a,b) r=(a)>>(b)
148 #define iShiftRLZh(r,a,b) r=(a)>>(b)
150 #define int2WordZh(r,a) r=(W_)(a)
151 #define word2IntZh(r,a) r=(I_)(a)
153 /* -----------------------------------------------------------------------------
155 -------------------------------------------------------------------------- */
157 #define int2AddrZh(r,a) r=(A_)(a)
158 #define addr2IntZh(r,a) r=(I_)(a)
160 #define indexCharOffAddrZh(r,a,i) r= ((C_ *)(a))[i]
161 #define indexIntOffAddrZh(r,a,i) r= ((I_ *)(a))[i]
162 #define indexAddrOffAddrZh(r,a,i) r= ((PP_)(a))[i]
163 #define indexFloatOffAddrZh(r,a,i) r= PK_FLT((P_) (((StgFloat *)(a)) + i))
164 #define indexDoubleOffAddrZh(r,a,i) r= PK_DBL((P_) (((StgDouble *)(a)) + i))
165 #define indexStablePtrOffAddrZh(r,a,i) r= ((StgStablePtr *)(a))[i]
166 #ifdef SUPPORT_LONG_LONGS
167 #define indexInt64OffAddrZh(r,a,i) r= ((LI_ *)(a))[i]
168 #define indexWord64OffAddrZh(r,a,i) r= ((LW_ *)(a))[i]
171 #define writeCharOffAddrZh(a,i,v) ((C_ *)(a))[i] = (v)
172 #define writeIntOffAddrZh(a,i,v) ((I_ *)(a))[i] = (v)
173 #define writeWordOffAddrZh(a,i,v) ((W_ *)(a))[i] = (v)
174 #define writeAddrOffAddrZh(a,i,v) ((PP_)(a))[i] = (v)
175 #define writeForeignObjOffAddrZh(a,i,v) ((PP_)(a))[i] = ForeignObj_CLOSURE_DATA(v)
176 #define writeFloatOffAddrZh(a,i,v) ASSIGN_FLT((P_) (((StgFloat *)(a)) + i),v)
177 #define writeDoubleOffAddrZh(a,i,v) ASSIGN_DBL((P_) (((StgDouble *)(a)) + i),v)
178 #define writeStablePtrOffAddrZh(a,i,v) ((StgStablePtr *)(a))[i] = (v)
179 #ifdef SUPPORT_LONG_LONGS
180 #define writeInt64OffAddrZh(a,i,v) ((LI_ *)(a))[i] = (v)
181 #define writeWord64OffAddrZh(a,i,v) ((LW_ *)(a))[i] = (v)
184 /* -----------------------------------------------------------------------------
186 -------------------------------------------------------------------------- */
188 #define plusFloatZh(r,a,b) r=(a)+(b)
189 #define minusFloatZh(r,a,b) r=(a)-(b)
190 #define timesFloatZh(r,a,b) r=(a)*(b)
191 #define divideFloatZh(r,a,b) r=(a)/(b)
192 #define negateFloatZh(r,a) r=-(a)
194 #define int2FloatZh(r,a) r=(StgFloat)(a)
195 #define float2IntZh(r,a) r=(I_)(a)
197 #define expFloatZh(r,a) r=(StgFloat) RET_PRIM_STGCALL1(StgDouble,exp,a)
198 #define logFloatZh(r,a) r=(StgFloat) RET_PRIM_STGCALL1(StgDouble,log,a)
199 #define sqrtFloatZh(r,a) r=(StgFloat) RET_PRIM_STGCALL1(StgDouble,sqrt,a)
200 #define sinFloatZh(r,a) r=(StgFloat) RET_PRIM_STGCALL1(StgDouble,sin,a)
201 #define cosFloatZh(r,a) r=(StgFloat) RET_PRIM_STGCALL1(StgDouble,cos,a)
202 #define tanFloatZh(r,a) r=(StgFloat) RET_PRIM_STGCALL1(StgDouble,tan,a)
203 #define asinFloatZh(r,a) r=(StgFloat) RET_PRIM_STGCALL1(StgDouble,asin,a)
204 #define acosFloatZh(r,a) r=(StgFloat) RET_PRIM_STGCALL1(StgDouble,acos,a)
205 #define atanFloatZh(r,a) r=(StgFloat) RET_PRIM_STGCALL1(StgDouble,atan,a)
206 #define sinhFloatZh(r,a) r=(StgFloat) RET_PRIM_STGCALL1(StgDouble,sinh,a)
207 #define coshFloatZh(r,a) r=(StgFloat) RET_PRIM_STGCALL1(StgDouble,cosh,a)
208 #define tanhFloatZh(r,a) r=(StgFloat) RET_PRIM_STGCALL1(StgDouble,tanh,a)
209 #define powerFloatZh(r,a,b) r=(StgFloat) RET_PRIM_STGCALL2(StgDouble,pow,a,b)
211 /* -----------------------------------------------------------------------------
213 -------------------------------------------------------------------------- */
215 #define ZpZhZh(r,a,b) r=(a)+(b)
216 #define ZmZhZh(r,a,b) r=(a)-(b)
217 #define ZtZhZh(r,a,b) r=(a)*(b)
218 #define ZdZhZh(r,a,b) r=(a)/(b)
219 #define negateDoubleZh(r,a) r=-(a)
221 #define int2DoubleZh(r,a) r=(StgDouble)(a)
222 #define double2IntZh(r,a) r=(I_)(a)
224 #define float2DoubleZh(r,a) r=(StgDouble)(a)
225 #define double2FloatZh(r,a) r=(StgFloat)(a)
227 #define expDoubleZh(r,a) r=(StgDouble) RET_PRIM_STGCALL1(StgDouble,exp,a)
228 #define logDoubleZh(r,a) r=(StgDouble) RET_PRIM_STGCALL1(StgDouble,log,a)
229 #define sqrtDoubleZh(r,a) r=(StgDouble) RET_PRIM_STGCALL1(StgDouble,sqrt,a)
230 #define sinDoubleZh(r,a) r=(StgDouble) RET_PRIM_STGCALL1(StgDouble,sin,a)
231 #define cosDoubleZh(r,a) r=(StgDouble) RET_PRIM_STGCALL1(StgDouble,cos,a)
232 #define tanDoubleZh(r,a) r=(StgDouble) RET_PRIM_STGCALL1(StgDouble,tan,a)
233 #define asinDoubleZh(r,a) r=(StgDouble) RET_PRIM_STGCALL1(StgDouble,asin,a)
234 #define acosDoubleZh(r,a) r=(StgDouble) RET_PRIM_STGCALL1(StgDouble,acos,a)
235 #define atanDoubleZh(r,a) r=(StgDouble) RET_PRIM_STGCALL1(StgDouble,atan,a)
236 #define sinhDoubleZh(r,a) r=(StgDouble) RET_PRIM_STGCALL1(StgDouble,sinh,a)
237 #define coshDoubleZh(r,a) r=(StgDouble) RET_PRIM_STGCALL1(StgDouble,cosh,a)
238 #define tanhDoubleZh(r,a) r=(StgDouble) RET_PRIM_STGCALL1(StgDouble,tanh,a)
240 #define ZtZtZhZh(r,a,b) r=(StgDouble) RET_PRIM_STGCALL2(StgDouble,pow,a,b)
242 /* -----------------------------------------------------------------------------
244 -------------------------------------------------------------------------- */
246 /* We can do integer2Int and cmpInteger inline, since they don't need
247 * to allocate any memory.
250 #define integer2IntZh(r, aa,sa,da) \
253 arg._mp_alloc = (aa); \
254 arg._mp_size = (sa); \
255 arg._mp_d = (unsigned long int *) (BYTE_ARR_CTS(da)); \
257 (r) = RET_PRIM_STGCALL1(I_,mpz_get_si,&arg); \
260 #define integer2WordZh(r, aa,sa,da) \
263 arg._mp_alloc = (aa); \
264 arg._mp_size = (sa); \
265 arg._mp_d = (unsigned long int *) (BYTE_ARR_CTS(da)); \
267 (r) = RET_PRIM_STGCALL1(I_,mpz_get_ui,&arg); \
270 #define cmpIntegerZh(r, a1,s1,d1, a2,s2,d2) \
274 arg1._mp_alloc= (a1); \
275 arg1._mp_size = (s1); \
276 arg1._mp_d = (unsigned long int *) (BYTE_ARR_CTS(d1)); \
277 arg2._mp_alloc= (a2); \
278 arg2._mp_size = (s2); \
279 arg2._mp_d = (unsigned long int *) (BYTE_ARR_CTS(d2)); \
281 (r) = RET_PRIM_STGCALL2(I_,mpz_cmp,&arg1,&arg2); \
284 /* A glorious hack: calling mpz_neg would entail allocation and
285 * copying, but by looking at what mpz_neg actually does, we can
286 * derive a better version:
289 #define negateIntegerZh(ra, rs, rd, a, s, d) \
296 /* The rest are all out-of-line: -------- */
298 /* Integer arithmetic */
299 EF_(plusIntegerZh_fast);
300 EF_(minusIntegerZh_fast);
301 EF_(timesIntegerZh_fast);
302 EF_(gcdIntegerZh_fast);
303 EF_(quotRemIntegerZh_fast);
304 EF_(divModIntegerZh_fast);
307 EF_(int2IntegerZh_fast);
308 EF_(word2IntegerZh_fast);
309 EF_(addr2IntegerZh_fast);
311 /* Floating-point encodings/decodings */
312 EF_(encodeFloatZh_fast);
313 EF_(decodeFloatZh_fast);
315 EF_(encodeDoubleZh_fast);
316 EF_(decodeDoubleZh_fast);
318 /* -----------------------------------------------------------------------------
320 -------------------------------------------------------------------------- */
322 #ifdef SUPPORT_LONG_LONGS
324 #define integerToWord64Zh(r, aa,sa,da) \
325 { unsigned long int* d; \
328 d = (unsigned long int *) (BYTE_ARR_CTS(da)); \
331 } else if ( (aa) == 1) { \
334 res = (LW_)d[0] + (LW_)d[1] * 0x100000000ULL; \
339 #define integerToInt64Zh(r, aa,sa,da) \
340 { unsigned long int* d; \
343 d = (unsigned long int *) (BYTE_ARR_CTS(da)); \
346 } else if ( (aa) == 1) { \
349 res = (LI_)d[0] + (LI_)d[1] * 0x100000000LL; \
358 EF_(int64ToIntegerZh_fast);
359 EF_(word64ToIntegerZh_fast);
361 /* The rest are (way!) out of line, implemented via C entry points.
363 I_ stg_gtWord64 (StgNat64, StgNat64);
364 I_ stg_geWord64 (StgNat64, StgNat64);
365 I_ stg_eqWord64 (StgNat64, StgNat64);
366 I_ stg_neWord64 (StgNat64, StgNat64);
367 I_ stg_ltWord64 (StgNat64, StgNat64);
368 I_ stg_leWord64 (StgNat64, StgNat64);
370 I_ stg_gtInt64 (StgInt64, StgInt64);
371 I_ stg_geInt64 (StgInt64, StgInt64);
372 I_ stg_eqInt64 (StgInt64, StgInt64);
373 I_ stg_neInt64 (StgInt64, StgInt64);
374 I_ stg_ltInt64 (StgInt64, StgInt64);
375 I_ stg_leInt64 (StgInt64, StgInt64);
377 LW_ stg_remWord64 (StgNat64, StgNat64);
378 LW_ stg_quotWord64 (StgNat64, StgNat64);
380 LI_ stg_remInt64 (StgInt64, StgInt64);
381 LI_ stg_quotInt64 (StgInt64, StgInt64);
382 LI_ stg_negateInt64 (StgInt64);
383 LI_ stg_plusInt64 (StgInt64, StgInt64);
384 LI_ stg_minusInt64 (StgInt64, StgInt64);
385 LI_ stg_timesInt64 (StgInt64, StgInt64);
387 LW_ stg_and64 (StgNat64, StgNat64);
388 LW_ stg_or64 (StgNat64, StgNat64);
389 LW_ stg_xor64 (StgNat64, StgNat64);
390 LW_ stg_not64 (StgNat64);
392 LW_ stg_shiftL64 (StgNat64, StgInt);
393 LW_ stg_shiftRL64 (StgNat64, StgInt);
394 LI_ stg_iShiftL64 (StgInt64, StgInt);
395 LI_ stg_iShiftRL64 (StgInt64, StgInt);
396 LI_ stg_iShiftRA64 (StgInt64, StgInt);
398 LI_ stg_intToInt64 (StgInt);
399 I_ stg_int64ToInt (StgInt64);
400 LW_ stg_int64ToWord64 (StgInt64);
402 LW_ stg_wordToWord64 (StgWord);
403 W_ stg_word64ToWord (StgNat64);
404 LI_ stg_word64ToInt64 (StgNat64);
407 /* -----------------------------------------------------------------------------
409 -------------------------------------------------------------------------- */
411 /* We cast to void* instead of StgChar* because this avoids a warning
412 * about increasing the alignment requirements.
414 #define REAL_BYTE_ARR_CTS(a) ((void *) (((StgArrWords *)(a))->payload))
415 #define REAL_PTRS_ARR_CTS(a) ((P_) (((StgMutArrPtrs *)(a))->payload))
418 #define BYTE_ARR_CTS(a) \
419 ({ ASSERT((GET_INFO(a) == &ARR_WORDS_info) \
420 || (GET_INFO(a) == &MUT_ARR_WORDS_info)); \
421 REAL_BYTE_ARR_CTS(a); })
422 #define PTRS_ARR_CTS(a) \
423 ({ ASSERT((GET_INFO(a) == &ARR_PTRS_info) \
424 || (GET_INFO(a) == &MUT_ARR_PTRS_info)); \
425 REAL_PTRS_ARR_CTS(a); })
427 #define BYTE_ARR_CTS(a) REAL_BYTE_ARR_CTS(a)
428 #define PTRS_ARR_CTS(a) REAL_PTRS_ARR_CTS(a)
431 extern I_ genSymZh(void);
432 extern I_ resetGenSymZh(void);
434 /*--- everything except new*Array is done inline: */
436 #define sameMutableArrayZh(r,a,b) r=(I_)((a)==(b))
437 #define sameMutableByteArrayZh(r,a,b) r=(I_)((a)==(b))
439 #define readArrayZh(r,a,i) r=((PP_) PTRS_ARR_CTS(a))[(i)]
441 #define readCharArrayZh(r,a,i) indexCharOffAddrZh(r,BYTE_ARR_CTS(a),i)
442 #define readIntArrayZh(r,a,i) indexIntOffAddrZh(r,BYTE_ARR_CTS(a),i)
443 #define readWordArrayZh(r,a,i) indexWordOffAddrZh(r,BYTE_ARR_CTS(a),i)
444 #define readAddrArrayZh(r,a,i) indexAddrOffAddrZh(r,BYTE_ARR_CTS(a),i)
445 #define readFloatArrayZh(r,a,i) indexFloatOffAddrZh(r,BYTE_ARR_CTS(a),i)
446 #define readDoubleArrayZh(r,a,i) indexDoubleOffAddrZh(r,BYTE_ARR_CTS(a),i)
447 #define readStablePtrArrayZh(r,a,i) indexStablePtrOffAddrZh(r,BYTE_ARR_CTS(a),i)
448 #ifdef SUPPORT_LONG_LONGS
449 #define readInt64ArrayZh(r,a,i) indexInt64OffAddrZh(r,BYTE_ARR_CTS(a),i)
450 #define readWord64ArrayZh(r,a,i) indexWord64OffAddrZh(r,BYTE_ARR_CTS(a),i)
453 /* result ("r") arg ignored in write macros! */
454 #define writeArrayZh(a,i,v) ((PP_) PTRS_ARR_CTS(a))[(i)]=(v)
456 #define writeCharArrayZh(a,i,v) ((C_ *)(BYTE_ARR_CTS(a)))[i] = (v)
457 #define writeIntArrayZh(a,i,v) ((I_ *)(BYTE_ARR_CTS(a)))[i] = (v)
458 #define writeWordArrayZh(a,i,v) ((W_ *)(BYTE_ARR_CTS(a)))[i] = (v)
459 #define writeAddrArrayZh(a,i,v) ((PP_)(BYTE_ARR_CTS(a)))[i] = (v)
460 #define writeFloatArrayZh(a,i,v) \
461 ASSIGN_FLT((P_) (((StgFloat *)(BYTE_ARR_CTS(a))) + i),v)
462 #define writeDoubleArrayZh(a,i,v) \
463 ASSIGN_DBL((P_) (((StgDouble *)(BYTE_ARR_CTS(a))) + i),v)
464 #define writeStablePtrArrayZh(a,i,v) ((StgStablePtr *)(BYTE_ARR_CTS(a)))[i] = (v)
465 #ifdef SUPPORT_LONG_LONGS
466 #define writeInt64ArrayZh(a,i,v) ((LI_ *)(BYTE_ARR_CTS(a)))[i] = (v)
467 #define writeWord64ArrayZh(a,i,v) ((LW_ *)(BYTE_ARR_CTS(a)))[i] = (v)
470 #define indexArrayZh(r,a,i) r=((PP_) PTRS_ARR_CTS(a))[(i)]
472 #define indexCharArrayZh(r,a,i) indexCharOffAddrZh(r,BYTE_ARR_CTS(a),i)
473 #define indexIntArrayZh(r,a,i) indexIntOffAddrZh(r,BYTE_ARR_CTS(a),i)
474 #define indexWordArrayZh(r,a,i) indexWordOffAddrZh(r,BYTE_ARR_CTS(a),i)
475 #define indexAddrArrayZh(r,a,i) indexAddrOffAddrZh(r,BYTE_ARR_CTS(a),i)
476 #define indexFloatArrayZh(r,a,i) indexFloatOffAddrZh(r,BYTE_ARR_CTS(a),i)
477 #define indexDoubleArrayZh(r,a,i) indexDoubleOffAddrZh(r,BYTE_ARR_CTS(a),i)
478 #define indexStablePtrArrayZh(r,a,i) indexStablePtrOffAddrZh(r,BYTE_ARR_CTS(a),i)
479 #ifdef SUPPORT_LONG_LONGS
480 #define indexInt64ArrayZh(r,a,i) indexInt64OffAddrZh(r,BYTE_ARR_CTS(a),i)
481 #define indexWord64ArrayZh(r,a,i) indexWord64OffAddrZh(r,BYTE_ARR_CTS(a),i)
484 #define indexCharOffForeignObjZh(r,fo,i) indexCharOffAddrZh(r,ForeignObj_CLOSURE_DATA(fo),i)
485 #define indexIntOffForeignObjZh(r,fo,i) indexIntOffAddrZh(r,ForeignObj_CLOSURE_DATA(fo),i)
486 #define indexWordOffForeignObjZh(r,fo,i) indexWordOffAddrZh(r,ForeignObj_CLOSURE_DATA(fo),i)
487 #define indexAddrOffForeignObjZh(r,fo,i) indexAddrOffAddrZh(r,ForeignObj_CLOSURE_DATA(fo),i)
488 #define indexFloatOffForeignObjZh(r,fo,i) indexFloatOffAddrZh(r,ForeignObj_CLOSURE_DATA(fo),i)
489 #define indexDoubleOffForeignObjZh(r,fo,i) indexDoubleOffAddrZh(r,ForeignObj_CLOSURE_DATA(fo),i)
490 #define indexStablePtrOffForeignObjZh(r,fo,i) indexStablePtrOffAddrZh(r,ForeignObj_CLOSURE_DATA(fo),i)
491 #ifdef SUPPORT_LONG_LONGS
492 #define indexInt64OffForeignObjZh(r,fo,i) indexInt64OffAddrZh(r,ForeignObj_CLOSURE_DATA(fo),i)
493 #define indexWord64OffForeignObjZh(r,fo,i) indexWord64OffAddrZh(r,ForeignObj_CLOSURE_DATA(fo),i)
496 #define indexCharOffAddrZh(r,a,i) r= ((C_ *)(a))[i]
497 #define indexIntOffAddrZh(r,a,i) r= ((I_ *)(a))[i]
498 #define indexWordOffAddrZh(r,a,i) r= ((W_ *)(a))[i]
499 #define indexAddrOffAddrZh(r,a,i) r= ((PP_)(a))[i]
500 #define indexFloatOffAddrZh(r,a,i) r= PK_FLT((P_) (((StgFloat *)(a)) + i))
501 #define indexDoubleOffAddrZh(r,a,i) r= PK_DBL((P_) (((StgDouble *)(a)) + i))
502 #ifdef SUPPORT_LONG_LONGS
503 #define indexInt64OffAddrZh(r,a,i) r= ((LI_ *)(a))[i]
504 #define indexWord64OffAddrZh(r,a,i) r= ((LW_ *)(a))[i]
507 /* Freezing arrays-of-ptrs requires changing an info table, for the
508 benefit of the generational collector. It needs to scavenge mutable
509 objects, even if they are in old space. When they become immutable,
510 they can be removed from this scavenge list. */
512 #define unsafeFreezeArrayZh(r,a) \
514 SET_INFO((StgClosure *)a,&MUT_ARR_PTRS_FROZEN_info); \
518 #define unsafeFreezeByteArrayZh(r,a) r=(a)
520 #define sizeofByteArrayZh(r,a) \
521 r = (((StgArrWords *)(a))->words * sizeof(W_))
522 #define sizeofMutableByteArrayZh(r,a) \
523 r = (((StgArrWords *)(a))->words * sizeof(W_))
525 /* and the out-of-line ones... */
527 EF_(newCharArrayZh_fast);
528 EF_(newIntArrayZh_fast);
529 EF_(newWordArrayZh_fast);
530 EF_(newAddrArrayZh_fast);
531 EF_(newFloatArrayZh_fast);
532 EF_(newDoubleArrayZh_fast);
533 EF_(newStablePtrArrayZh_fast);
534 EF_(newArrayZh_fast);
536 /* encoding and decoding of floats/doubles. */
538 /* We only support IEEE floating point format */
539 #include "ieee-flpt.h"
541 #if FLOATS_AS_DOUBLES /* i.e. 64-bit machines */
542 #define encodeFloatZh(r, aa,sa,da, expon) encodeDoubleZh(r, aa,sa,da, expon)
544 #define encodeFloatZh(r, aa,sa,da, expon) \
546 /* Does not allocate memory */ \
548 arg._mp_alloc = aa; \
550 arg._mp_d = (unsigned long int *) (BYTE_ARR_CTS(da)); \
552 r = RET_PRIM_STGCALL2(StgFloat, __encodeFloat,&arg,(expon));\
554 #endif /* FLOATS_AS_DOUBLES */
556 #define encodeDoubleZh(r, aa,sa,da, expon) \
558 /* Does not allocate memory */ \
560 arg._mp_alloc = aa; \
562 arg._mp_d = (unsigned long int *) (BYTE_ARR_CTS(da)); \
564 r = RET_PRIM_STGCALL2(StgDouble, __encodeDouble,&arg,(expon));\
567 /* The decode operations are out-of-line because they need to allocate
571 #ifdef FLOATS_AS_DOUBLES
572 #define decodeFloatZh_fast decodeDoubleZh_fast
574 EF_(decodeFloatZh_fast);
577 EF_(decodeDoubleZh_fast);
579 /* grimy low-level support functions defined in StgPrimFloat.c */
581 extern StgDouble __encodeDouble (MP_INT *s, I_ e);
582 extern StgFloat __encodeFloat (MP_INT *s, I_ e);
583 extern void __decodeDouble (MP_INT *man, I_ *_exp, StgDouble dbl);
584 extern void __decodeFloat (MP_INT *man, I_ *_exp, StgFloat flt);
585 extern StgInt isDoubleNaN(StgDouble d);
586 extern StgInt isDoubleInfinite(StgDouble d);
587 extern StgInt isDoubleDenormalized(StgDouble d);
588 extern StgInt isDoubleNegativeZero(StgDouble d);
589 extern StgInt isFloatNaN(StgFloat f);
590 extern StgInt isFloatInfinite(StgFloat f);
591 extern StgInt isFloatDenormalized(StgFloat f);
592 extern StgInt isFloatNegativeZero(StgFloat f);
594 /* -----------------------------------------------------------------------------
597 newMutVar is out of line.
598 -------------------------------------------------------------------------- */
600 EF_(newMutVarZh_fast);
602 #define readMutVarZh(r,a) r=(P_)(((StgMutVar *)(a))->var)
603 #define writeMutVarZh(a,v) (P_)(((StgMutVar *)(a))->var)=(v)
604 #define sameMutVarZh(r,a,b) r=(I_)((a)==(b))
606 /* -----------------------------------------------------------------------------
609 All out of line, because they either allocate or may block.
610 -------------------------------------------------------------------------- */
612 #define sameMVarZh(r,a,b) r=(I_)((a)==(b))
614 /* Assume external decl of EMPTY_MVAR_info is in scope by now */
615 #define isEmptyMVarZh(r,a) r=(I_)((GET_INFO((StgMVar*)(a))) == &EMPTY_MVAR_info )
617 EF_(takeMVarZh_fast);
620 /* -----------------------------------------------------------------------------
622 -------------------------------------------------------------------------- */
624 /* Hmm, I'll think about these later. */
626 /* -----------------------------------------------------------------------------
627 Primitive I/O, error-handling PrimOps
628 -------------------------------------------------------------------------- */
633 extern void stg_exit(I_ n) __attribute__ ((noreturn));
635 /* -----------------------------------------------------------------------------
636 Stable Pointer PrimOps.
637 -------------------------------------------------------------------------- */
641 extern StgPtr *stable_ptr_table;
642 extern StgPtr *stable_ptr_free;
643 #define deRefStablePtrZh(r,sp) (r=stable_ptr_table[(sp)])
644 #define eqStablePtrZh(r,sp1,sp2) (r=(sp1==sp2))
646 #define freeStablePointer(stable_ptr) \
648 stable_ptr_table[stable_ptr] = (P_)stable_ptr_free; \
649 stable_ptr_free = &stable_ptr_table[stable_ptr]; \
652 EF_(makeStablePtrZh_fast);
655 #define deRefStablePtrZh(ri,sp) \
658 fprintf(stderr, "deRefStablePtr#: no stable pointer support.\n");\
659 stg_exit(EXIT_FAILURE); \
662 #define eqStablePtrZh(ri,sp1,sp2) \
665 fprintf(stderr, "eqStablePtr#: no stable pointer support.\n"); \
666 stg_exit(EXIT_FAILURE); \
669 #define makeStablePtrZh(stablePtr,liveness,unstablePtr) \
672 fprintf(stderr, "makeStablePtr#: no stable pointer support.\n");\
673 EXIT(EXIT_FAILURE); \
676 #define freeStablePtrZh(stablePtr,liveness,unstablePtr) \
679 fprintf(stderr, "makeStablePtr#: no stable pointer support.\n");\
680 EXIT(EXIT_FAILURE); \
685 /* -----------------------------------------------------------------------------
687 -------------------------------------------------------------------------- */
690 EF_(killThreadZh_fast);
693 /* Hmm, I'll think about these later. */
694 /* -----------------------------------------------------------------------------
696 -------------------------------------------------------------------------- */
698 /* warning: extremely non-referentially transparent, need to hide in
699 an appropriate monad.
701 ToDo: follow indirections.
704 #define reallyUnsafePtrEqualityZh(r,a,b) r=((StgPtr)(a) == (StgPtr)(b))
706 /* -----------------------------------------------------------------------------
707 Weak Pointer PrimOps.
708 -------------------------------------------------------------------------- */
713 EF_(deRefWeakZh_fast);
714 #define sameWeakZh(w1,w2) ((w1)==(w2))
718 /* -----------------------------------------------------------------------------
719 Foreign Object PrimOps.
720 -------------------------------------------------------------------------- */
724 #define ForeignObj_CLOSURE_DATA(c) (((StgForeignObj *)c)->data)
726 EF_(makeForeignObjZh_fast);
728 #define writeForeignObjZh(res,datum) \
729 (ForeignObj_CLOSURE_DATA(res) = (P_)(datum))
731 #define eqForeignObj(f1,f2) ((f1)==(f2))
735 /* -----------------------------------------------------------------------------
736 Signal processing. Not really primops, but called directly from
738 -------------------------------------------------------------------------- */
740 #define STG_SIG_DFL (-1)
741 #define STG_SIG_IGN (-2)
742 #define STG_SIG_ERR (-3)
743 #define STG_SIG_HAN (-4)
745 extern StgInt sig_install (StgInt, StgInt, StgStablePtr, sigset_t *);
746 #define stg_sig_default(sig,mask) sig_install(sig,STG_SIG_DFL,0,(sigset_t *)mask)
747 #define stg_sig_ignore(sig,mask) sig_install(sig,STG_SIG_IGN,0,(sigset_t *)mask)
748 #define stg_sig_catch(sig,ptr,mask) sig_install(sig,STG_SIG_HAN,ptr,(sigset_t *)mask)