[project @ 1999-02-23 17:20:34 by sof]
[ghc-hetmet.git] / ghc / includes / PrimOps.h
1 /* -----------------------------------------------------------------------------
2  * $Id: PrimOps.h,v 1.20 1999/02/18 12:26:11 simonm Exp $
3  *
4  * (c) The GHC Team, 1998-1999
5  *
6  * Macros for primitive operations in STG-ish C code.
7  *
8  * ---------------------------------------------------------------------------*/
9
10 #ifndef PRIMOPS_H
11 #define PRIMOPS_H
12
13 /* -----------------------------------------------------------------------------
14    Comparison PrimOps.
15    -------------------------------------------------------------------------- */
16
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))
23
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))
31
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))
38
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))
45
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))
52
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))
60
61 /*  used by returning comparison primops, defined in Prims.hc. */
62 extern const StgClosure *PrelBase_Bool_closure_tbl[];
63
64 /* -----------------------------------------------------------------------------
65    Char# PrimOps.
66    -------------------------------------------------------------------------- */
67
68 #define ordzh(r,a)      r=(I_)((W_) (a))
69 #define chrzh(r,a)      r=(StgChar)((W_)(a))
70
71 /* -----------------------------------------------------------------------------
72    Int# PrimOps.
73    -------------------------------------------------------------------------- */
74
75 I_ stg_div (I_ a, I_ b);
76
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)
84
85 /* -----------------------------------------------------------------------------
86  * Int operations with carry.
87  * -------------------------------------------------------------------------- */
88
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
92  *
93  * Return : r = a + b,  c = 0 if no overflow, 1 on overflow.
94  *
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#.  
99  */
100 #define addIntCzh(r,c,a,b)                      \
101 { r = a + b;                                    \
102   c = ((StgWord)(~(a^b) & (a^r)))               \
103     >> (BITS_PER_BYTE * sizeof(I_) - 1);        \
104 }
105
106
107 #define subIntCzh(r,c,a,b)                      \
108 { r = a - b;                                    \
109   c = ((StgWord)((a^b) & (a^r)))                \
110     >> (BITS_PER_BYTE * sizeof(I_) - 1);        \
111 }
112
113 /* Multiply with overflow checking.
114  *
115  * This is slightly more tricky - the usual sign rules for add/subtract
116  * don't apply.  
117  *
118  * On x86 hardware we use a hand-crafted assembly fragment to do the job.
119  *
120  * On other 32-bit machines we use gcc's 'long long' types, finding
121  * overflow with some careful bit-twiddling.
122  *
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
126  * multiplication.
127  */
128
129 #if i386_TARGET_ARCH
130
131 #define mulIntCzh(r,c,a,b)                              \
132 {                                                       \
133   __asm__("xor %1,%1\n\t                                \
134            imull %2,%3\n\t                              \
135            jno 1f\n\t                                   \
136            movl $1,%1\n\t                               \
137            1:"                                          \
138         : "=r" (r), "=r" (c) : "r" (a), "0" (b));       \
139 }
140
141 #elif SIZEOF_VOID_P == 4
142
143 #ifdef WORDS_BIGENDIAN
144 #define C 0
145 #define R 1
146 #else
147 #define C 1
148 #define R 0
149 #endif
150
151 typedef union {
152     StgInt64 l;
153     StgInt32 i[2];
154 } long_long_u ;
155
156 #define mulIntCzh(r,c,a,b)                                              \
157   long_long_u z;                                                        \
158   z.l = (StgInt64)a * (StgInt64)b;                                      \
159   r = z.i[R];                                                           \
160   c = z.i[C];                                                           \
161   if (c == 0 || c == -1) {                                              \
162     c = ((StgWord)((a^b) ^ r))                                          \
163       >> (BITS_PER_BYTE * sizeof(I_) - 1);                              \
164   }                                                                     \
165 }
166 /* Careful: the carry calculation above is extremely delicate.  Make sure
167  * you test it thoroughly after changing it.
168  */
169
170 #else
171
172 #define HALF_INT  (1 << (BITS_PER_BYTE * sizeof(I_) / 2))
173
174 #define stg_abs(a) ((a) < 0 ? -(a) : (a))
175
176 #define mulIntCzh(r,c,a,b)                      \
177 {                                               \
178   if (stg_abs(a) >= HALF_INT                    \
179       stg_abs(b) >= HALF_INT) {                 \
180     c = 1;                                      \
181   } else {                                      \
182     r = a * b;                                  \
183     c = 0;                                      \
184   }                                             \
185 }
186 #endif
187
188 /* -----------------------------------------------------------------------------
189    Word PrimOps.
190    -------------------------------------------------------------------------- */
191
192 #define quotWordzh(r,a,b)       r=((W_)a)/((W_)b)
193 #define remWordzh(r,a,b)        r=((W_)a)%((W_)b)
194
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)
199
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
206 */
207 #define iShiftRAzh(r,a,b)       r=(a)>>(b)
208 #define iShiftRLzh(r,a,b)       r=(a)>>(b)
209
210 #define int2Wordzh(r,a)         r=(W_)(a)
211 #define word2Intzh(r,a)         r=(I_)(a)
212
213 /* -----------------------------------------------------------------------------
214    Addr PrimOps.
215    -------------------------------------------------------------------------- */
216
217 #define int2Addrzh(r,a)         r=(A_)(a)
218 #define addr2Intzh(r,a)         r=(I_)(a)
219
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]
229 #endif
230
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)
242 #endif
243
244 /* -----------------------------------------------------------------------------
245    Float PrimOps.
246    -------------------------------------------------------------------------- */
247
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)
253                              
254 #define int2Floatzh(r,a)     r=(StgFloat)(a)
255 #define float2Intzh(r,a)     r=(I_)(a)
256                              
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)
270
271 /* -----------------------------------------------------------------------------
272    Double PrimOps.
273    -------------------------------------------------------------------------- */
274
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)
280                              
281 #define int2Doublezh(r,a)    r=(StgDouble)(a)
282 #define double2Intzh(r,a)    r=(I_)(a)
283                              
284 #define float2Doublezh(r,a)  r=(StgDouble)(a)
285 #define double2Floatzh(r,a)  r=(StgFloat)(a)
286                              
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)
299 /* Power: **## */
300 #define ztztzhzh(r,a,b) r=(StgDouble) RET_PRIM_STGCALL2(StgDouble,pow,a,b)
301
302 /* -----------------------------------------------------------------------------
303    Integer PrimOps.
304    -------------------------------------------------------------------------- */
305
306 /* We can do integer2Int and cmpInteger inline, since they don't need
307  * to allocate any memory.
308  */
309
310 #define integer2Intzh(r, sa,da)                                 \
311 { MP_INT arg;                                                   \
312                                                                 \
313   arg._mp_size  = (sa);                                         \
314   arg._mp_alloc = ((StgArrWords *)da)->words;                   \
315   arg._mp_d     = (unsigned long int *) (BYTE_ARR_CTS(da));     \
316                                                                 \
317   (r) = RET_PRIM_STGCALL1(I_,mpz_get_si,&arg);                  \
318 }
319
320 #define integer2Wordzh(r, sa,da)                                \
321 { MP_INT arg;                                                   \
322                                                                 \
323   arg._mp_size  = (sa);                                         \
324   arg._mp_alloc = ((StgArrWords *)da)->words;                   \
325   arg._mp_d     = (unsigned long int *) (BYTE_ARR_CTS(da));     \
326                                                                 \
327   (r) = RET_PRIM_STGCALL1(I_,mpz_get_ui,&arg);                  \
328 }
329
330 #define cmpIntegerzh(r, s1,d1, s2,d2)                           \
331 { MP_INT arg1;                                                  \
332   MP_INT arg2;                                                  \
333                                                                 \
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));     \
340                                                                 \
341   (r) = RET_PRIM_STGCALL2(I_,mpz_cmp,&arg1,&arg2);              \
342 }
343
344 #define cmpIntegerIntzh(r, s,d, i)                              \
345 { MP_INT arg;                                                   \
346                                                                 \
347   arg._mp_size  = (s);                                          \
348   arg._mp_alloc = ((StgArrWords *)d)->words;                    \
349   arg._mp_d     = (unsigned long int *) (BYTE_ARR_CTS(d));      \
350                                                                 \
351   (r) = RET_PRIM_STGCALL2(I_,mpz_cmp_si,&arg,i);                \
352 }
353
354 /* The rest are all out-of-line: -------- */
355
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);
363
364 /* Conversions */
365 EF_(int2Integerzh_fast);
366 EF_(word2Integerzh_fast);
367 EF_(addr2Integerzh_fast);
368
369 /* Floating-point decodings */
370 EF_(decodeFloatzh_fast);
371 EF_(decodeDoublezh_fast);
372
373 /* -----------------------------------------------------------------------------
374    Word64 PrimOps.
375    -------------------------------------------------------------------------- */
376
377 #ifdef SUPPORT_LONG_LONGS
378
379 #define integerToWord64zh(r, sa,da)                             \
380 { unsigned long int* d;                                         \
381   I_ aa;                                                        \
382   StgNat64 res;                                                 \
383                                                                 \
384   d             = (unsigned long int *) (BYTE_ARR_CTS(da));     \
385   aa = ((StgArrWords *)da)->words;                              \
386   if ( (aa) == 0 ) {                                            \
387      res = (LW_)0;                                              \
388   } else if ( (aa) == 1) {                                      \
389      res = (LW_)d[0];                                           \
390   } else {                                                      \
391      res = (LW_)d[0] + (LW_)d[1] * 0x100000000ULL;              \
392   }                                                             \
393   (r) = res;                                                    \
394 }
395
396 #define integerToInt64zh(r, sa,da)                              \
397 { unsigned long int* d;                                         \
398   I_ aa;                                                        \
399   StgInt64 res;                                                 \
400                                                                 \
401   d             = (unsigned long int *) (BYTE_ARR_CTS(da));     \
402   aa = ((StgArrWords *)da)->words;                              \
403   if ( (aa) == 0 ) {                                            \
404      res = (LI_)0;                                              \
405   } else if ( (aa) == 1) {                                      \
406      res = (LI_)d[0];                                           \
407   } else {                                                      \
408      res = (LI_)d[0] + (LI_)d[1] * 0x100000000LL;               \
409      if ( sa < 0 ) {                                            \
410            res = (LI_)-res;                                     \
411      }                                                          \
412   }                                                             \
413   (r) = res;                                                    \
414 }
415
416 /* Conversions */
417 EF_(int64ToIntegerzh_fast);
418 EF_(word64ToIntegerzh_fast);
419
420 /* The rest are (way!) out of line, implemented via C entry points.
421  */
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);
428
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);
435
436 LW_ stg_remWord64  (StgNat64, StgNat64);
437 LW_ stg_quotWord64 (StgNat64, StgNat64);
438
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);
445
446 LW_ stg_and64  (StgNat64, StgNat64);
447 LW_ stg_or64   (StgNat64, StgNat64);
448 LW_ stg_xor64  (StgNat64, StgNat64);
449 LW_ stg_not64  (StgNat64);
450
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);
456
457 LI_ stg_intToInt64    (StgInt);
458 I_ stg_int64ToInt     (StgInt64);
459 LW_ stg_int64ToWord64 (StgInt64);
460
461 LW_ stg_wordToWord64  (StgWord);
462 W_  stg_word64ToWord  (StgNat64);
463 LI_ stg_word64ToInt64 (StgNat64);
464 #endif
465
466 /* -----------------------------------------------------------------------------
467    Array PrimOps.
468    -------------------------------------------------------------------------- */
469
470 /* We cast to void* instead of StgChar* because this avoids a warning
471  * about increasing the alignment requirements.
472  */
473 #define REAL_BYTE_ARR_CTS(a)   ((void *) (((StgArrWords *)(a))->payload))
474 #define REAL_PTRS_ARR_CTS(a)   ((P_)   (((StgMutArrPtrs  *)(a))->payload))
475
476 #ifdef DEBUG
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); })
484 #else
485 #define BYTE_ARR_CTS(a)         REAL_BYTE_ARR_CTS(a)
486 #define PTRS_ARR_CTS(a)         REAL_PTRS_ARR_CTS(a)
487 #endif
488
489 extern I_ genSymZh(void);
490 extern I_ resetGenSymZh(void);
491
492 /*--- everything except new*Array is done inline: */
493
494 #define sameMutableArrayzh(r,a,b)       r=(I_)((a)==(b))
495 #define sameMutableByteArrayzh(r,a,b)   r=(I_)((a)==(b))
496
497 #define readArrayzh(r,a,i)       r=((PP_) PTRS_ARR_CTS(a))[(i)]
498
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)
509 #endif
510
511 /* result ("r") arg ignored in write macros! */
512 #define writeArrayzh(a,i,v)     ((PP_) PTRS_ARR_CTS(a))[(i)]=(v)
513
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)
526 #endif
527
528 #define indexArrayzh(r,a,i)       r=((PP_) PTRS_ARR_CTS(a))[(i)]
529
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)
540 #endif
541
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)
552 #endif
553
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]
563 #endif
564
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.  */
569
570 #define unsafeFreezzeArrayzh(r,a)                                       \
571         {                                                               \
572         SET_INFO((StgClosure *)a,&MUT_ARR_PTRS_FROZEN_info);            \
573         r = a;                                                          \
574         }
575
576 #define unsafeFreezzeByteArrayzh(r,a)   r=(a)
577
578 #define sizzeofByteArrayzh(r,a) \
579      r = (((StgArrWords *)(a))->words * sizeof(W_))
580 #define sizzeofMutableByteArrayzh(r,a) \
581      r = (((StgArrWords *)(a))->words * sizeof(W_))
582
583 /* and the out-of-line ones... */
584
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);
593
594 /* encoding and decoding of floats/doubles. */
595
596 /* We only support IEEE floating point format */
597 #include "ieee-flpt.h"
598
599 /* The decode operations are out-of-line because they need to allocate
600  * a byte array.
601  */
602 #ifdef FLOATS_AS_DOUBLES
603 #define decodeFloatzh_fast decodeDoublezh_fast
604 #else
605 EF_(decodeFloatzh_fast);
606 #endif
607
608 EF_(decodeDoublezh_fast);
609
610 /* grimy low-level support functions defined in StgPrimFloat.c */
611
612 extern StgDouble __encodeDouble (I_ size, StgByteArray arr, I_ e);
613 extern StgDouble __int_encodeDouble (I_ j, I_ e);
614 #ifndef FLOATS_AS_DOUBLES
615 extern StgFloat  __encodeFloat (I_ size, StgByteArray arr, I_ e);
616 extern StgFloat  __int_encodeFloat (I_ j, I_ e);
617 #endif
618 extern void      __decodeDouble (MP_INT *man, I_ *_exp, StgDouble dbl);
619 extern void      __decodeFloat  (MP_INT *man, I_ *_exp, StgFloat flt);
620 extern StgInt    isDoubleNaN(StgDouble d);
621 extern StgInt    isDoubleInfinite(StgDouble d);
622 extern StgInt    isDoubleDenormalized(StgDouble d);
623 extern StgInt    isDoubleNegativeZero(StgDouble d);
624 extern StgInt    isFloatNaN(StgFloat f);
625 extern StgInt    isFloatInfinite(StgFloat f);
626 extern StgInt    isFloatDenormalized(StgFloat f);
627 extern StgInt    isFloatNegativeZero(StgFloat f);
628
629 /* -----------------------------------------------------------------------------
630    Mutable variables
631
632    newMutVar is out of line.
633    -------------------------------------------------------------------------- */
634
635 EF_(newMutVarzh_fast);
636
637 #define readMutVarzh(r,a)        r=(P_)(((StgMutVar *)(a))->var)
638 #define writeMutVarzh(a,v)       (P_)(((StgMutVar *)(a))->var)=(v)
639 #define sameMutVarzh(r,a,b)      r=(I_)((a)==(b))
640
641 /* -----------------------------------------------------------------------------
642    MVar PrimOps.
643
644    All out of line, because they either allocate or may block.
645    -------------------------------------------------------------------------- */
646 #define sameMVarzh(r,a,b)        r=(I_)((a)==(b))
647
648 /* Assume external decl of EMPTY_MVAR_info is in scope by now */
649 #define isEmptyMVarzh(r,a)       r=(I_)((GET_INFO((StgMVar*)(a))) == &EMPTY_MVAR_info )
650 EF_(newMVarzh_fast);
651 EF_(takeMVarzh_fast);
652 EF_(putMVarzh_fast);
653
654
655 /* -----------------------------------------------------------------------------
656    Delay/Wait PrimOps
657    -------------------------------------------------------------------------- */
658
659 /* Hmm, I'll think about these later. */
660
661 /* -----------------------------------------------------------------------------
662    Primitive I/O, error-handling PrimOps
663    -------------------------------------------------------------------------- */
664
665 EF_(catchzh_fast);
666 EF_(raisezh_fast);
667
668 extern void stg_exit(I_ n)  __attribute__ ((noreturn));
669
670 /* -----------------------------------------------------------------------------
671    Stable Name / Stable Pointer  PrimOps
672    -------------------------------------------------------------------------- */
673
674 #ifndef PAR
675
676 EF_(makeStableNamezh_fast);
677
678 #define stableNameToIntzh(r,s)   (r = ((StgStableName *)s)->sn)
679
680 #define eqStableNamezh(r,sn1,sn2)                                       \
681     (r = (((StgStableName *)sn1)->sn == ((StgStableName *)sn2)->sn))
682
683 #define makeStablePtrzh(r,a) \
684    r = RET_STGCALL1(StgStablePtr,getStablePtr,a)
685
686 #define deRefStablePtrzh(r,sp) do {             \
687   ASSERT(stable_ptr_table[sp & ~STABLEPTR_WEIGHT_MASK].weight > 0);     \
688   r = stable_ptr_table[sp & ~STABLEPTR_WEIGHT_MASK].addr; \
689 } while (0);
690
691 #define eqStablePtrzh(r,sp1,sp2) \
692     (r = ((sp1 & ~STABLEPTR_WEIGHT_MASK) == (sp2 & ~STABLEPTR_WEIGHT_MASK)))
693
694 #endif
695
696 /* -----------------------------------------------------------------------------
697    Parallel PrimOps.
698    -------------------------------------------------------------------------- */
699
700 EF_(forkzh_fast);
701 EF_(killThreadzh_fast);
702 EF_(seqzh_fast);
703
704 /* Hmm, I'll think about these later. */
705 /* -----------------------------------------------------------------------------
706    Pointer equality
707    -------------------------------------------------------------------------- */
708
709 /* warning: extremely non-referentially transparent, need to hide in
710    an appropriate monad.
711
712    ToDo: follow indirections.  
713 */
714
715 #define reallyUnsafePtrEqualityzh(r,a,b) r=((StgPtr)(a) == (StgPtr)(b))
716
717 /* -----------------------------------------------------------------------------
718    Weak Pointer PrimOps.
719    -------------------------------------------------------------------------- */
720
721 #ifndef PAR
722
723 EF_(mkWeakzh_fast);
724 EF_(finalizzeWeakzh_fast);
725
726 #define deRefWeakzh(code,val,w)                         \
727   if (((StgWeak *)w)->header.info == &WEAK_info) {      \
728         code = 1;                                       \
729         val = (P_)((StgWeak *)w)->value;                \
730   } else {                                              \
731         code = 0;                                       \
732         val = (P_)w;                                    \
733   }
734
735 #define sameWeakzh(w1,w2)  ((w1)==(w2))
736
737 #endif
738
739 /* -----------------------------------------------------------------------------
740    Foreign Object PrimOps.
741    -------------------------------------------------------------------------- */
742
743 #ifndef PAR
744
745 #define ForeignObj_CLOSURE_DATA(c)  (((StgForeignObj *)c)->data)
746
747 EF_(makeForeignObjzh_fast);
748
749 #define writeForeignObjzh(res,datum) \
750    (ForeignObj_CLOSURE_DATA(res) = (P_)(datum))
751
752 #define eqForeignObj(f1,f2)  ((f1)==(f2))
753
754 #endif
755
756 /* -----------------------------------------------------------------------------
757    Signal processing.  Not really primops, but called directly from
758    Haskell. 
759    -------------------------------------------------------------------------- */
760
761 #define STG_SIG_DFL  (-1)
762 #define STG_SIG_IGN  (-2)
763 #define STG_SIG_ERR  (-3)
764 #define STG_SIG_HAN  (-4)
765
766 extern StgInt sig_install (StgInt, StgInt, StgStablePtr, sigset_t *);
767 #define stg_sig_default(sig,mask) sig_install(sig,STG_SIG_DFL,0,(sigset_t *)mask)
768 #define stg_sig_ignore(sig,mask) sig_install(sig,STG_SIG_IGN,0,(sigset_t *)mask)
769 #define stg_sig_catch(sig,ptr,mask) sig_install(sig,STG_SIG_HAN,ptr,(sigset_t *)mask)
770
771 #endif PRIMOPS_H