PrimOps.h 27.2 KB
Newer Older
1
/* -----------------------------------------------------------------------------
sof's avatar
sof committed
2
 * $Id: PrimOps.h,v 1.29 1999/05/10 09:26:41 sof Exp $
3
4
 *
 * (c) The GHC Team, 1998-1999
5
6
7
8
9
10
11
12
13
14
15
16
 *
 * Macros for primitive operations in STG-ish C code.
 *
 * ---------------------------------------------------------------------------*/

#ifndef PRIMOPS_H
#define PRIMOPS_H

/* -----------------------------------------------------------------------------
   Comparison PrimOps.
   -------------------------------------------------------------------------- */

17
18
19
20
21
22
#define gtCharzh(r,a,b)	r=(I_)((a)> (b))
#define geCharzh(r,a,b)	r=(I_)((a)>=(b))
#define eqCharzh(r,a,b)	r=(I_)((a)==(b))
#define neCharzh(r,a,b)	r=(I_)((a)!=(b))
#define ltCharzh(r,a,b)	r=(I_)((a)< (b))
#define leCharzh(r,a,b)	r=(I_)((a)<=(b))
23
24

/* Int comparisons: >#, >=# etc */
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
#define zgzh(r,a,b)	r=(I_)((I_)(a) >(I_)(b))
#define zgzezh(r,a,b)	r=(I_)((I_)(a)>=(I_)(b))
#define zezezh(r,a,b)	r=(I_)((I_)(a)==(I_)(b))
#define zszezh(r,a,b)	r=(I_)((I_)(a)!=(I_)(b))
#define zlzh(r,a,b)	r=(I_)((I_)(a) <(I_)(b))
#define zlzezh(r,a,b)	r=(I_)((I_)(a)<=(I_)(b))

#define gtWordzh(r,a,b)	r=(I_)((W_)(a) >(W_)(b))
#define geWordzh(r,a,b)	r=(I_)((W_)(a)>=(W_)(b))
#define eqWordzh(r,a,b)	r=(I_)((W_)(a)==(W_)(b))
#define neWordzh(r,a,b)	r=(I_)((W_)(a)!=(W_)(b))
#define ltWordzh(r,a,b)	r=(I_)((W_)(a) <(W_)(b))
#define leWordzh(r,a,b)	r=(I_)((W_)(a)<=(W_)(b))

#define gtAddrzh(r,a,b)	r=(I_)((a) >(b))
#define geAddrzh(r,a,b)	r=(I_)((a)>=(b))
#define eqAddrzh(r,a,b)	r=(I_)((a)==(b))
#define neAddrzh(r,a,b)	r=(I_)((a)!=(b))
#define ltAddrzh(r,a,b)	r=(I_)((a) <(b))
#define leAddrzh(r,a,b)	r=(I_)((a)<=(b))

#define gtFloatzh(r,a,b)  r=(I_)((a)> (b))
#define geFloatzh(r,a,b)  r=(I_)((a)>=(b))
#define eqFloatzh(r,a,b)  r=(I_)((a)==(b))
#define neFloatzh(r,a,b)  r=(I_)((a)!=(b))
#define ltFloatzh(r,a,b)  r=(I_)((a)< (b))
#define leFloatzh(r,a,b)  r=(I_)((a)<=(b))
52
53

/* Double comparisons: >##, >=#@ etc */
54
55
56
57
58
59
#define zgzhzh(r,a,b)	r=(I_)((a) >(b))
#define zgzezhzh(r,a,b)	r=(I_)((a)>=(b))
#define zezezhzh(r,a,b)	r=(I_)((a)==(b))
#define zszezhzh(r,a,b)	r=(I_)((a)!=(b))
#define zlzhzh(r,a,b)	r=(I_)((a) <(b))
#define zlzezhzh(r,a,b)	r=(I_)((a)<=(b))
60
61
62
63
64

/* -----------------------------------------------------------------------------
   Char# PrimOps.
   -------------------------------------------------------------------------- */

65
66
#define ordzh(r,a)	r=(I_)((W_) (a))
#define chrzh(r,a)	r=(StgChar)((W_)(a))
67
68
69
70
71
72
73

/* -----------------------------------------------------------------------------
   Int# PrimOps.
   -------------------------------------------------------------------------- */

I_ stg_div (I_ a, I_ b);

74
75
76
77
78
79
80
#define zpzh(r,a,b)		r=(a)+(b)
#define zmzh(r,a,b)		r=(a)-(b)
#define ztzh(r,a,b)		r=(a)*(b)
#define quotIntzh(r,a,b)	r=(a)/(b)
#define zszh(r,a,b)		r=ULTRASAFESTGCALL2(I_,(void *, I_, I_),stg_div,(a),(b))
#define remIntzh(r,a,b)		r=(a)%(b)
#define negateIntzh(r,a)	r=-(a)
81

82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
/* -----------------------------------------------------------------------------
 * Int operations with carry.
 * -------------------------------------------------------------------------- */

/* With some bit-twiddling, we can define int{Add,Sub}Czh portably in
 * C, and without needing any comparisons.  This may not be the
 * fastest way to do it - if you have better code, please send it! --SDM
 *
 * Return : r = a + b,  c = 0 if no overflow, 1 on overflow.
 *
 * We currently don't make use of the r value if c is != 0 (i.e. 
 * overflow), we just convert to big integers and try again.  This
 * could be improved by making r and c the correct values for
 * plugging into a new J#.  
 */
#define addIntCzh(r,c,a,b)			\
{ r = a + b;					\
  c = ((StgWord)(~(a^b) & (a^r)))		\
    >> (BITS_PER_BYTE * sizeof(I_) - 1);	\
}


#define subIntCzh(r,c,a,b)			\
{ r = a - b;					\
  c = ((StgWord)((a^b) & (a^r)))		\
    >> (BITS_PER_BYTE * sizeof(I_) - 1);	\
}

/* Multiply with overflow checking.
 *
 * This is slightly more tricky - the usual sign rules for add/subtract
 * don't apply.  
114
 *
115
116
117
118
119
120
121
122
123
 * On x86 hardware we use a hand-crafted assembly fragment to do the job.
 *
 * On other 32-bit machines we use gcc's 'long long' types, finding
 * overflow with some careful bit-twiddling.
 *
 * On 64-bit machines where gcc's 'long long' type is also 64-bits,
 * we use a crude approximation, testing whether either operand is
 * larger than 32-bits; if neither is, then we go ahead with the
 * multiplication.
124
125
 */

126
127
128
129
130
131
132
133
134
135
136
137
138
139
#if i386_TARGET_ARCH

#define mulIntCzh(r,c,a,b)				\
{							\
  __asm__("xor %1,%1\n\t				\
	   imull %2,%3\n\t				\
	   jno 1f\n\t					\
	   movl $1,%1\n\t				\
	   1:" 						\
	: "=r" (r), "=r" (c) : "r" (a), "0" (b));	\
}

#elif SIZEOF_VOID_P == 4

140
141
142
143
144
145
146
147
148
149
150
151
152
#ifdef WORDS_BIGENDIAN
#define C 0
#define R 1
#else
#define C 1
#define R 0
#endif

typedef union {
    StgInt64 l;
    StgInt32 i[2];
} long_long_u ;

153
154
155
156
157
158
159
160
161
162
#define mulIntCzh(r,c,a,b)			\
{						\
  long_long_u z;				\
  z.l = (StgInt64)a * (StgInt64)b;		\
  r = z.i[R];					\
  c = z.i[C];					\
  if (c == 0 || c == -1) {			\
    c = ((StgWord)((a^b) ^ r))			\
      >> (BITS_PER_BYTE * sizeof(I_) - 1);	\
  }						\
163
}
164
165
166
/* Careful: the carry calculation above is extremely delicate.  Make sure
 * you test it thoroughly after changing it.
 */
167

168
#else
169

170
171
172
#define HALF_INT  (1 << (BITS_PER_BYTE * sizeof(I_) / 2))

#define stg_abs(a) ((a) < 0 ? -(a) : (a))
173

174
175
176
177
178
179
180
181
182
#define mulIntCzh(r,c,a,b)			\
{						\
  if (stg_abs(a) >= HALF_INT			\
      stg_abs(b) >= HALF_INT) {			\
    c = 1;					\
  } else {					\
    r = a * b;					\
    c = 0;					\
  }						\
183
}
184
#endif
185
186
187
188
189

/* -----------------------------------------------------------------------------
   Word PrimOps.
   -------------------------------------------------------------------------- */

190
191
#define quotWordzh(r,a,b)	r=((W_)a)/((W_)b)
#define remWordzh(r,a,b)	r=((W_)a)%((W_)b)
192

193
194
195
196
#define andzh(r,a,b)		r=(a)&(b)
#define orzh(r,a,b)		r=(a)|(b)
#define xorzh(r,a,b)            r=(a)^(b)
#define notzh(r,a)		r=~(a)
197

198
199
200
#define shiftLzh(r,a,b)	  	r=(a)<<(b)
#define shiftRLzh(r,a,b)  	r=(a)>>(b)
#define iShiftLzh(r,a,b)  	r=(a)<<(b)
201
202
203
204
/* Right shifting of signed quantities is not portable in C, so
   the behaviour you'll get from using these primops depends
   on the whatever your C compiler is doing. ToDo: fix/document. -- sof 8/98
*/
205
206
#define iShiftRAzh(r,a,b) 	r=(a)>>(b)
#define iShiftRLzh(r,a,b) 	r=(a)>>(b)
207

208
209
#define int2Wordzh(r,a) 	r=(W_)(a)
#define word2Intzh(r,a) 	r=(I_)(a)
210
211
212
213
214

/* -----------------------------------------------------------------------------
   Addr PrimOps.
   -------------------------------------------------------------------------- */

215
216
#define int2Addrzh(r,a) 	r=(A_)(a)
#define addr2Intzh(r,a) 	r=(I_)(a)
217

218
219
220
221
222
223
#define indexCharOffAddrzh(r,a,i)   r= ((C_ *)(a))[i]
#define indexIntOffAddrzh(r,a,i)    r= ((I_ *)(a))[i]
#define indexAddrOffAddrzh(r,a,i)   r= ((PP_)(a))[i]
#define indexFloatOffAddrzh(r,a,i)  r= PK_FLT((P_) (((StgFloat *)(a)) + i))
#define indexDoubleOffAddrzh(r,a,i) r= PK_DBL((P_) (((StgDouble *)(a)) + i))
#define indexStablePtrOffAddrzh(r,a,i)    r= ((StgStablePtr *)(a))[i]
224
#ifdef SUPPORT_LONG_LONGS
225
226
#define indexInt64OffAddrzh(r,a,i)  r= ((LI_ *)(a))[i]
#define indexWord64OffAddrzh(r,a,i) r= ((LW_ *)(a))[i]
227
228
#endif

229
230
231
232
233
234
235
236
#define writeCharOffAddrzh(a,i,v)       ((C_ *)(a))[i] = (v)
#define writeIntOffAddrzh(a,i,v)        ((I_ *)(a))[i] = (v)
#define writeWordOffAddrzh(a,i,v)       ((W_ *)(a))[i] = (v)
#define writeAddrOffAddrzh(a,i,v)       ((PP_)(a))[i] = (v)
#define writeForeignObjOffAddrzh(a,i,v) ((PP_)(a))[i] = ForeignObj_CLOSURE_DATA(v)
#define writeFloatOffAddrzh(a,i,v)      ASSIGN_FLT((P_) (((StgFloat *)(a)) + i),v)
#define writeDoubleOffAddrzh(a,i,v)     ASSIGN_DBL((P_) (((StgDouble *)(a)) + i),v)
#define writeStablePtrOffAddrzh(a,i,v)  ((StgStablePtr *)(a))[i] = (v)
237
#ifdef SUPPORT_LONG_LONGS
238
239
#define writeInt64OffAddrzh(a,i,v)   ((LI_ *)(a))[i] = (v)
#define writeWord64OffAddrzh(a,i,v)  ((LW_ *)(a))[i] = (v)
240
241
242
243
244
245
#endif

/* -----------------------------------------------------------------------------
   Float PrimOps.
   -------------------------------------------------------------------------- */

246
247
248
249
250
#define plusFloatzh(r,a,b)   r=(a)+(b)
#define minusFloatzh(r,a,b)  r=(a)-(b)
#define timesFloatzh(r,a,b)  r=(a)*(b)
#define divideFloatzh(r,a,b) r=(a)/(b)
#define negateFloatzh(r,a)   r=-(a)
251
			     
252
253
#define int2Floatzh(r,a)     r=(StgFloat)(a)
#define float2Intzh(r,a)     r=(I_)(a)
254
			     
255
256
257
258
259
260
261
262
263
264
265
266
267
#define expFloatzh(r,a)	     r=(StgFloat) RET_PRIM_STGCALL1(StgDouble,exp,a)
#define logFloatzh(r,a)	     r=(StgFloat) RET_PRIM_STGCALL1(StgDouble,log,a)
#define sqrtFloatzh(r,a)     r=(StgFloat) RET_PRIM_STGCALL1(StgDouble,sqrt,a)
#define sinFloatzh(r,a)	     r=(StgFloat) RET_PRIM_STGCALL1(StgDouble,sin,a)
#define cosFloatzh(r,a)	     r=(StgFloat) RET_PRIM_STGCALL1(StgDouble,cos,a)
#define tanFloatzh(r,a)	     r=(StgFloat) RET_PRIM_STGCALL1(StgDouble,tan,a)
#define asinFloatzh(r,a)     r=(StgFloat) RET_PRIM_STGCALL1(StgDouble,asin,a)
#define acosFloatzh(r,a)     r=(StgFloat) RET_PRIM_STGCALL1(StgDouble,acos,a)
#define atanFloatzh(r,a)     r=(StgFloat) RET_PRIM_STGCALL1(StgDouble,atan,a)
#define sinhFloatzh(r,a)     r=(StgFloat) RET_PRIM_STGCALL1(StgDouble,sinh,a)
#define coshFloatzh(r,a)     r=(StgFloat) RET_PRIM_STGCALL1(StgDouble,cosh,a)
#define tanhFloatzh(r,a)     r=(StgFloat) RET_PRIM_STGCALL1(StgDouble,tanh,a)
#define powerFloatzh(r,a,b)  r=(StgFloat) RET_PRIM_STGCALL2(StgDouble,pow,a,b)
268
269
270
271
272

/* -----------------------------------------------------------------------------
   Double PrimOps.
   -------------------------------------------------------------------------- */

273
274
275
276
277
#define zpzhzh(r,a,b)	     r=(a)+(b)
#define zmzhzh(r,a,b)	     r=(a)-(b)
#define ztzhzh(r,a,b)	     r=(a)*(b)
#define zszhzh(r,a,b)	     r=(a)/(b)
#define negateDoublezh(r,a)  r=-(a)
278
			     
279
280
#define int2Doublezh(r,a)    r=(StgDouble)(a)
#define double2Intzh(r,a)    r=(I_)(a)
281
			     
282
283
#define float2Doublezh(r,a)  r=(StgDouble)(a)
#define double2Floatzh(r,a)  r=(StgFloat)(a)
284
			     
285
286
287
288
289
290
291
292
293
294
295
296
#define expDoublezh(r,a)     r=(StgDouble) RET_PRIM_STGCALL1(StgDouble,exp,a)
#define logDoublezh(r,a)     r=(StgDouble) RET_PRIM_STGCALL1(StgDouble,log,a)
#define sqrtDoublezh(r,a)    r=(StgDouble) RET_PRIM_STGCALL1(StgDouble,sqrt,a)
#define sinDoublezh(r,a)     r=(StgDouble) RET_PRIM_STGCALL1(StgDouble,sin,a)
#define cosDoublezh(r,a)     r=(StgDouble) RET_PRIM_STGCALL1(StgDouble,cos,a)
#define tanDoublezh(r,a)     r=(StgDouble) RET_PRIM_STGCALL1(StgDouble,tan,a)
#define asinDoublezh(r,a)    r=(StgDouble) RET_PRIM_STGCALL1(StgDouble,asin,a)
#define acosDoublezh(r,a)    r=(StgDouble) RET_PRIM_STGCALL1(StgDouble,acos,a)
#define atanDoublezh(r,a)    r=(StgDouble) RET_PRIM_STGCALL1(StgDouble,atan,a)
#define sinhDoublezh(r,a)    r=(StgDouble) RET_PRIM_STGCALL1(StgDouble,sinh,a)
#define coshDoublezh(r,a)    r=(StgDouble) RET_PRIM_STGCALL1(StgDouble,cosh,a)
#define tanhDoublezh(r,a)    r=(StgDouble) RET_PRIM_STGCALL1(StgDouble,tanh,a)
297
/* Power: **## */
298
#define ztztzhzh(r,a,b)	r=(StgDouble) RET_PRIM_STGCALL2(StgDouble,pow,a,b)
299
300
301
302
303
304
305

/* -----------------------------------------------------------------------------
   Integer PrimOps.
   -------------------------------------------------------------------------- */

/* We can do integer2Int and cmpInteger inline, since they don't need
 * to allocate any memory.
sof's avatar
sof committed
306
307
 *
 * integer2Int# is now modular.
308
309
 */

310
311
#define integer2Intzh(r, sa,da)					\
{ MP_INT arg;							\
sof's avatar
sof committed
312
  								\
313
314
315
316
  arg._mp_size	= (sa);						\
  arg._mp_alloc	= ((StgArrWords *)da)->words;			\
  arg._mp_d	= (unsigned long int *) (BYTE_ARR_CTS(da));	\
								\
sof's avatar
sof committed
317
318
319
  (r) =                                                         \
    ( arg._mp_size == 0 ) ?                                     \
       0 :                                                      \
sof's avatar
sof committed
320
321
322
       (( arg._mp_size < 0 && arg._mp_d[0] != 0x80000000 ) ?    \
          -(I_)arg._mp_d[0] :                                   \
	   (I_)arg._mp_d[0]);                                   \
323
324
}

325
326
327
328
329
330
331
332
#define integer2Wordzh(r, sa,da)				\
{ MP_INT arg;							\
								\
  arg._mp_size	= (sa);						\
  arg._mp_alloc	= ((StgArrWords *)da)->words;			\
  arg._mp_d	= (unsigned long int *) (BYTE_ARR_CTS(da));	\
								\
  (r) = RET_PRIM_STGCALL1(I_,mpz_get_ui,&arg);			\
333
334
}

335
336
337
338
339
340
341
342
343
344
345
346
#define cmpIntegerzh(r, s1,d1, s2,d2)				\
{ MP_INT arg1;							\
  MP_INT arg2;							\
								\
  arg1._mp_size	= (s1);						\
  arg1._mp_alloc= ((StgArrWords *)d1)->words;			\
  arg1._mp_d	= (unsigned long int *) (BYTE_ARR_CTS(d1));	\
  arg2._mp_size	= (s2);						\
  arg2._mp_alloc= ((StgArrWords *)d2)->words;			\
  arg2._mp_d	= (unsigned long int *) (BYTE_ARR_CTS(d2));	\
								\
  (r) = RET_PRIM_STGCALL2(I_,mpz_cmp,&arg1,&arg2);		\
347
348
}

349
350
351
352
353
354
355
356
#define cmpIntegerIntzh(r, s,d, i)				\
{ MP_INT arg;							\
								\
  arg._mp_size	= (s);						\
  arg._mp_alloc = ((StgArrWords *)d)->words;			\
  arg._mp_d	= (unsigned long int *) (BYTE_ARR_CTS(d));	\
								\
  (r) = RET_PRIM_STGCALL2(I_,mpz_cmp_si,&arg,i);		\
357
358
359
360
361
}

/* The rest are all out-of-line: -------- */

/* Integer arithmetic */
362
363
364
365
366
367
EF_(plusIntegerzh_fast);
EF_(minusIntegerzh_fast);
EF_(timesIntegerzh_fast);
EF_(gcdIntegerzh_fast);
EF_(quotRemIntegerzh_fast);
EF_(divModIntegerzh_fast);
368
369

/* Conversions */
370
371
372
EF_(int2Integerzh_fast);
EF_(word2Integerzh_fast);
EF_(addr2Integerzh_fast);
373

374
/* Floating-point decodings */
375
376
EF_(decodeFloatzh_fast);
EF_(decodeDoublezh_fast);
377
378
379
380
381
382
383

/* -----------------------------------------------------------------------------
   Word64 PrimOps.
   -------------------------------------------------------------------------- */

#ifdef SUPPORT_LONG_LONGS

384
385
386
#define integerToWord64zh(r, sa,da)				\
{ unsigned long int* d;						\
  I_ aa;							\
sof's avatar
sof committed
387
  StgWord64 res;						\
388
389
390
391
392
393
394
395
396
397
398
								\
  d		= (unsigned long int *) (BYTE_ARR_CTS(da));	\
  aa = ((StgArrWords *)da)->words;				\
  if ( (aa) == 0 ) {						\
     res = (LW_)0;						\
  } else if ( (aa) == 1) {					\
     res = (LW_)d[0];						\
  } else {							\
     res = (LW_)d[0] + (LW_)d[1] * 0x100000000ULL;		\
  }								\
  (r) = res;							\
399
400
}

401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
#define integerToInt64zh(r, sa,da)				\
{ unsigned long int* d;						\
  I_ aa;							\
  StgInt64 res;							\
								\
  d		= (unsigned long int *) (BYTE_ARR_CTS(da));	\
  aa = ((StgArrWords *)da)->words;				\
  if ( (aa) == 0 ) {						\
     res = (LI_)0;						\
  } else if ( (aa) == 1) {					\
     res = (LI_)d[0];						\
  } else {							\
     res = (LI_)d[0] + (LI_)d[1] * 0x100000000LL;		\
     if ( sa < 0 ) {						\
	   res = (LI_)-res;					\
     }								\
  }								\
  (r) = res;							\
419
420
421
}

/* Conversions */
422
423
EF_(int64ToIntegerzh_fast);
EF_(word64ToIntegerzh_fast);
424
425
426

/* The rest are (way!) out of line, implemented via C entry points.
 */
sof's avatar
sof committed
427
428
429
430
431
432
I_ stg_gtWord64 (StgWord64, StgWord64);
I_ stg_geWord64 (StgWord64, StgWord64);
I_ stg_eqWord64 (StgWord64, StgWord64);
I_ stg_neWord64 (StgWord64, StgWord64);
I_ stg_ltWord64 (StgWord64, StgWord64);
I_ stg_leWord64 (StgWord64, StgWord64);
433
434
435
436
437
438
439
440

I_ stg_gtInt64 (StgInt64, StgInt64);
I_ stg_geInt64 (StgInt64, StgInt64);
I_ stg_eqInt64 (StgInt64, StgInt64);
I_ stg_neInt64 (StgInt64, StgInt64);
I_ stg_ltInt64 (StgInt64, StgInt64);
I_ stg_leInt64 (StgInt64, StgInt64);

sof's avatar
sof committed
441
442
LW_ stg_remWord64  (StgWord64, StgWord64);
LW_ stg_quotWord64 (StgWord64, StgWord64);
443
444
445
446
447
448
449
450

LI_ stg_remInt64    (StgInt64, StgInt64);
LI_ stg_quotInt64   (StgInt64, StgInt64);
LI_ stg_negateInt64 (StgInt64);
LI_ stg_plusInt64   (StgInt64, StgInt64);
LI_ stg_minusInt64  (StgInt64, StgInt64);
LI_ stg_timesInt64  (StgInt64, StgInt64);

sof's avatar
sof committed
451
452
453
454
LW_ stg_and64  (StgWord64, StgWord64);
LW_ stg_or64   (StgWord64, StgWord64);
LW_ stg_xor64  (StgWord64, StgWord64);
LW_ stg_not64  (StgWord64);
455

sof's avatar
sof committed
456
457
LW_ stg_shiftL64   (StgWord64, StgInt);
LW_ stg_shiftRL64  (StgWord64, StgInt);
458
459
460
461
462
463
464
465
466
LI_ stg_iShiftL64  (StgInt64, StgInt);
LI_ stg_iShiftRL64 (StgInt64, StgInt);
LI_ stg_iShiftRA64 (StgInt64, StgInt);

LI_ stg_intToInt64    (StgInt);
I_ stg_int64ToInt     (StgInt64);
LW_ stg_int64ToWord64 (StgInt64);

LW_ stg_wordToWord64  (StgWord);
sof's avatar
sof committed
467
468
W_  stg_word64ToWord  (StgWord64);
LI_ stg_word64ToInt64 (StgWord64);
469
470
471
472
473
474
475
476
477
478
#endif

/* -----------------------------------------------------------------------------
   Array PrimOps.
   -------------------------------------------------------------------------- */

/* We cast to void* instead of StgChar* because this avoids a warning
 * about increasing the alignment requirements.
 */
#define REAL_BYTE_ARR_CTS(a)   ((void *) (((StgArrWords *)(a))->payload))
479
#define REAL_PTRS_ARR_CTS(a)   ((P_)   (((StgMutArrPtrs  *)(a))->payload))
480
481

#ifdef DEBUG
482
#define BYTE_ARR_CTS(a)				  \
483
 ({ ASSERT(GET_INFO(a) == &ARR_WORDS_info); 	  \
484
    REAL_BYTE_ARR_CTS(a); })
485
486
487
#define PTRS_ARR_CTS(a)				  \
 ({ ASSERT((GET_INFO(a) == &ARR_PTRS_info)	  \
	|| (GET_INFO(a) == &MUT_ARR_PTRS_info));  \
488
489
490
491
492
493
    REAL_PTRS_ARR_CTS(a); })
#else
#define BYTE_ARR_CTS(a)		REAL_BYTE_ARR_CTS(a)
#define PTRS_ARR_CTS(a)		REAL_PTRS_ARR_CTS(a)
#endif

494
495
extern I_ genSymZh(void);
extern I_ resetGenSymZh(void);
496
497
498

/*--- everything except new*Array is done inline: */

499
500
#define sameMutableArrayzh(r,a,b)	r=(I_)((a)==(b))
#define sameMutableByteArrayzh(r,a,b)	r=(I_)((a)==(b))
501

502
#define readArrayzh(r,a,i)	 r=((PP_) PTRS_ARR_CTS(a))[(i)]
503

504
505
506
507
508
509
510
#define readCharArrayzh(r,a,i)	 indexCharOffAddrzh(r,BYTE_ARR_CTS(a),i)
#define readIntArrayzh(r,a,i)	 indexIntOffAddrzh(r,BYTE_ARR_CTS(a),i)
#define readWordArrayzh(r,a,i)	 indexWordOffAddrzh(r,BYTE_ARR_CTS(a),i)
#define readAddrArrayzh(r,a,i)	 indexAddrOffAddrzh(r,BYTE_ARR_CTS(a),i)
#define readFloatArrayzh(r,a,i)	 indexFloatOffAddrzh(r,BYTE_ARR_CTS(a),i)
#define readDoubleArrayzh(r,a,i) indexDoubleOffAddrzh(r,BYTE_ARR_CTS(a),i)
#define readStablePtrArrayzh(r,a,i) indexStablePtrOffAddrzh(r,BYTE_ARR_CTS(a),i)
511
#ifdef SUPPORT_LONG_LONGS
512
513
#define readInt64Arrayzh(r,a,i)  indexInt64OffAddrzh(r,BYTE_ARR_CTS(a),i)
#define readWord64Arrayzh(r,a,i) indexWord64OffAddrzh(r,BYTE_ARR_CTS(a),i)
514
515
516
#endif

/* result ("r") arg ignored in write macros! */
517
#define writeArrayzh(a,i,v)	((PP_) PTRS_ARR_CTS(a))[(i)]=(v)
518

519
520
521
522
523
#define writeCharArrayzh(a,i,v)	  ((C_ *)(BYTE_ARR_CTS(a)))[i] = (v)
#define writeIntArrayzh(a,i,v)	  ((I_ *)(BYTE_ARR_CTS(a)))[i] = (v)
#define writeWordArrayzh(a,i,v)	  ((W_ *)(BYTE_ARR_CTS(a)))[i] = (v)
#define writeAddrArrayzh(a,i,v)	  ((PP_)(BYTE_ARR_CTS(a)))[i] = (v)
#define writeFloatArrayzh(a,i,v)  \
524
	ASSIGN_FLT((P_) (((StgFloat *)(BYTE_ARR_CTS(a))) + i),v)
525
#define writeDoubleArrayzh(a,i,v) \
526
	ASSIGN_DBL((P_) (((StgDouble *)(BYTE_ARR_CTS(a))) + i),v)
527
#define writeStablePtrArrayzh(a,i,v)	  ((StgStablePtr *)(BYTE_ARR_CTS(a)))[i] = (v)
528
#ifdef SUPPORT_LONG_LONGS
529
530
#define writeInt64Arrayzh(a,i,v)  ((LI_ *)(BYTE_ARR_CTS(a)))[i] = (v)
#define writeWord64Arrayzh(a,i,v) ((LW_ *)(BYTE_ARR_CTS(a)))[i] = (v)
531
532
#endif

533
#define indexArrayzh(r,a,i)	  r=((PP_) PTRS_ARR_CTS(a))[(i)]
534

535
536
537
538
539
540
541
#define indexCharArrayzh(r,a,i)	  indexCharOffAddrzh(r,BYTE_ARR_CTS(a),i)
#define indexIntArrayzh(r,a,i)	  indexIntOffAddrzh(r,BYTE_ARR_CTS(a),i)
#define indexWordArrayzh(r,a,i)	  indexWordOffAddrzh(r,BYTE_ARR_CTS(a),i)
#define indexAddrArrayzh(r,a,i)	  indexAddrOffAddrzh(r,BYTE_ARR_CTS(a),i)
#define indexFloatArrayzh(r,a,i)  indexFloatOffAddrzh(r,BYTE_ARR_CTS(a),i)
#define indexDoubleArrayzh(r,a,i) indexDoubleOffAddrzh(r,BYTE_ARR_CTS(a),i)
#define indexStablePtrArrayzh(r,a,i) indexStablePtrOffAddrzh(r,BYTE_ARR_CTS(a),i)
542
#ifdef SUPPORT_LONG_LONGS
543
544
#define indexInt64Arrayzh(r,a,i)  indexInt64OffAddrzh(r,BYTE_ARR_CTS(a),i)
#define indexWord64Arrayzh(r,a,i) indexWord64OffAddrzh(r,BYTE_ARR_CTS(a),i)
545
546
#endif

547
548
549
550
551
552
553
#define indexCharOffForeignObjzh(r,fo,i)   indexCharOffAddrzh(r,ForeignObj_CLOSURE_DATA(fo),i)
#define indexIntOffForeignObjzh(r,fo,i)    indexIntOffAddrzh(r,ForeignObj_CLOSURE_DATA(fo),i)
#define indexWordOffForeignObjzh(r,fo,i)   indexWordOffAddrzh(r,ForeignObj_CLOSURE_DATA(fo),i)
#define indexAddrOffForeignObjzh(r,fo,i)   indexAddrOffAddrzh(r,ForeignObj_CLOSURE_DATA(fo),i)
#define indexFloatOffForeignObjzh(r,fo,i)  indexFloatOffAddrzh(r,ForeignObj_CLOSURE_DATA(fo),i)
#define indexDoubleOffForeignObjzh(r,fo,i) indexDoubleOffAddrzh(r,ForeignObj_CLOSURE_DATA(fo),i)
#define indexStablePtrOffForeignObjzh(r,fo,i)  indexStablePtrOffAddrzh(r,ForeignObj_CLOSURE_DATA(fo),i)
554
#ifdef SUPPORT_LONG_LONGS
555
556
#define indexInt64OffForeignObjzh(r,fo,i)  indexInt64OffAddrzh(r,ForeignObj_CLOSURE_DATA(fo),i)
#define indexWord64OffForeignObjzh(r,fo,i) indexWord64OffAddrzh(r,ForeignObj_CLOSURE_DATA(fo),i)
557
558
#endif

559
560
561
562
563
564
#define indexCharOffAddrzh(r,a,i)   r= ((C_ *)(a))[i]
#define indexIntOffAddrzh(r,a,i)    r= ((I_ *)(a))[i]
#define indexWordOffAddrzh(r,a,i)   r= ((W_ *)(a))[i]
#define indexAddrOffAddrzh(r,a,i)   r= ((PP_)(a))[i]
#define indexFloatOffAddrzh(r,a,i)  r= PK_FLT((P_) (((StgFloat *)(a)) + i))
#define indexDoubleOffAddrzh(r,a,i) r= PK_DBL((P_) (((StgDouble *)(a)) + i))
565
#ifdef SUPPORT_LONG_LONGS
566
567
#define indexInt64OffAddrzh(r,a,i)  r= ((LI_ *)(a))[i]
#define indexWord64OffAddrzh(r,a,i) r= ((LW_ *)(a))[i]
568
569
570
571
572
573
574
#endif

/* Freezing arrays-of-ptrs requires changing an info table, for the
   benefit of the generational collector.  It needs to scavenge mutable
   objects, even if they are in old space.  When they become immutable,
   they can be removed from this scavenge list.	 */

575
#define unsafeFreezzeArrayzh(r,a)					\
576
577
578
579
580
	{								\
        SET_INFO((StgClosure *)a,&MUT_ARR_PTRS_FROZEN_info);            \
	r = a;								\
	}

581
#define unsafeFreezzeByteArrayzh(r,a)	r=(a)
sof's avatar
sof committed
582
583
584
#define unsafeThawByteArrayzh(r,a)	r=(a)

EF_(unsafeThawArrayzh_fast);
585

586
#define sizzeofByteArrayzh(r,a) \
587
     r = (((StgArrWords *)(a))->words * sizeof(W_))
588
#define sizzeofMutableByteArrayzh(r,a) \
589
590
591
592
     r = (((StgArrWords *)(a))->words * sizeof(W_))

/* and the out-of-line ones... */

593
594
595
596
597
598
599
600
EF_(newCharArrayzh_fast);
EF_(newIntArrayzh_fast);
EF_(newWordArrayzh_fast);
EF_(newAddrArrayzh_fast);
EF_(newFloatArrayzh_fast);
EF_(newDoubleArrayzh_fast);
EF_(newStablePtrArrayzh_fast);
EF_(newArrayzh_fast);
601
602
603
604
605
606
607
608
609
610

/* encoding and decoding of floats/doubles. */

/* We only support IEEE floating point format */
#include "ieee-flpt.h"

/* The decode operations are out-of-line because they need to allocate
 * a byte array.
 */
#ifdef FLOATS_AS_DOUBLES
611
#define decodeFloatzh_fast decodeDoublezh_fast
612
#else
613
EF_(decodeFloatzh_fast);
614
615
#endif

616
EF_(decodeDoublezh_fast);
617
618
619

/* grimy low-level support functions defined in StgPrimFloat.c */

620
621
622
623
624
625
extern StgDouble __encodeDouble (I_ size, StgByteArray arr, I_ e);
extern StgDouble __int_encodeDouble (I_ j, I_ e);
#ifndef FLOATS_AS_DOUBLES
extern StgFloat  __encodeFloat (I_ size, StgByteArray arr, I_ e);
extern StgFloat  __int_encodeFloat (I_ j, I_ e);
#endif
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
extern void      __decodeDouble (MP_INT *man, I_ *_exp, StgDouble dbl);
extern void      __decodeFloat  (MP_INT *man, I_ *_exp, StgFloat flt);
extern StgInt    isDoubleNaN(StgDouble d);
extern StgInt    isDoubleInfinite(StgDouble d);
extern StgInt    isDoubleDenormalized(StgDouble d);
extern StgInt    isDoubleNegativeZero(StgDouble d);
extern StgInt    isFloatNaN(StgFloat f);
extern StgInt    isFloatInfinite(StgFloat f);
extern StgInt    isFloatDenormalized(StgFloat f);
extern StgInt    isFloatNegativeZero(StgFloat f);

/* -----------------------------------------------------------------------------
   Mutable variables

   newMutVar is out of line.
   -------------------------------------------------------------------------- */

643
EF_(newMutVarzh_fast);
644

645
646
647
#define readMutVarzh(r,a)	 r=(P_)(((StgMutVar *)(a))->var)
#define writeMutVarzh(a,v)       (P_)(((StgMutVar *)(a))->var)=(v)
#define sameMutVarzh(r,a,b)      r=(I_)((a)==(b))
648
649
650
651
652
653

/* -----------------------------------------------------------------------------
   MVar PrimOps.

   All out of line, because they either allocate or may block.
   -------------------------------------------------------------------------- */
654
#define sameMVarzh(r,a,b)        r=(I_)((a)==(b))
sof's avatar
sof committed
655
656

/* Assume external decl of EMPTY_MVAR_info is in scope by now */
657
658
659
660
661
#define isEmptyMVarzh(r,a)       r=(I_)((GET_INFO((StgMVar*)(a))) == &EMPTY_MVAR_info )
EF_(newMVarzh_fast);
EF_(takeMVarzh_fast);
EF_(putMVarzh_fast);

662
663
664
665
666
667
668
669
670
671
672

/* -----------------------------------------------------------------------------
   Delay/Wait PrimOps
   -------------------------------------------------------------------------- */

/* Hmm, I'll think about these later. */

/* -----------------------------------------------------------------------------
   Primitive I/O, error-handling PrimOps
   -------------------------------------------------------------------------- */

673
674
EF_(catchzh_fast);
EF_(raisezh_fast);
675
676
677
678

extern void stg_exit(I_ n)  __attribute__ ((noreturn));

/* -----------------------------------------------------------------------------
679
   Stable Name / Stable Pointer  PrimOps
680
681
682
683
   -------------------------------------------------------------------------- */

#ifndef PAR

684
EF_(makeStableNamezh_fast);
685

686
#define stableNameToIntzh(r,s)   (r = ((StgStableName *)s)->sn)
687

688
#define eqStableNamezh(r,sn1,sn2)					\
689
690
    (r = (((StgStableName *)sn1)->sn == ((StgStableName *)sn2)->sn))

691
#define makeStablePtrzh(r,a) \
692
   r = RET_STGCALL1(StgStablePtr,getStablePtr,a)
693

694
#define deRefStablePtrzh(r,sp) do {		\
695
696
697
698
  ASSERT(stable_ptr_table[sp & ~STABLEPTR_WEIGHT_MASK].weight > 0);	\
  r = stable_ptr_table[sp & ~STABLEPTR_WEIGHT_MASK].addr; \
} while (0);

699
#define eqStablePtrzh(r,sp1,sp2) \
700
701
702
    (r = ((sp1 & ~STABLEPTR_WEIGHT_MASK) == (sp2 & ~STABLEPTR_WEIGHT_MASK)))

#endif
703
704
705
706
707

/* -----------------------------------------------------------------------------
   Parallel PrimOps.
   -------------------------------------------------------------------------- */

708
EF_(forkzh_fast);
709
EF_(yieldzh_fast);
710
711
EF_(killThreadzh_fast);
EF_(seqzh_fast);
712

713
714
#define myThreadIdzh(t) (t = CurrentTSO)

715
716
717
718
719
720
721
722
723
724
725
/* Hmm, I'll think about these later. */
/* -----------------------------------------------------------------------------
   Pointer equality
   -------------------------------------------------------------------------- */

/* warning: extremely non-referentially transparent, need to hide in
   an appropriate monad.

   ToDo: follow indirections.  
*/

726
#define reallyUnsafePtrEqualityzh(r,a,b) r=((StgPtr)(a) == (StgPtr)(b))
727
728
729
730
731
732
733

/* -----------------------------------------------------------------------------
   Weak Pointer PrimOps.
   -------------------------------------------------------------------------- */

#ifndef PAR

734
EF_(mkWeakzh_fast);
735
EF_(finalizzeWeakzh_fast);
736

737
#define deRefWeakzh(code,val,w)				\
738
739
  if (((StgWeak *)w)->header.info == &WEAK_info) {	\
	code = 1;					\
740
	val = (P_)((StgWeak *)w)->value;		\
741
742
  } else {						\
	code = 0;					\
743
	val = (P_)w;					\
744
745
  }

746
#define sameWeakzh(w1,w2)  ((w1)==(w2))
747
748
749
750
751
752
753
754
755
756
757

#endif

/* -----------------------------------------------------------------------------
   Foreign Object PrimOps.
   -------------------------------------------------------------------------- */

#ifndef PAR

#define ForeignObj_CLOSURE_DATA(c)  (((StgForeignObj *)c)->data)

758
EF_(makeForeignObjzh_fast);
759

760
#define writeForeignObjzh(res,datum) \
761
762
763
764
765
766
   (ForeignObj_CLOSURE_DATA(res) = (P_)(datum))

#define eqForeignObj(f1,f2)  ((f1)==(f2))

#endif

767
768
769
770
771
772
773
/* -----------------------------------------------------------------------------
   Constructor tags
   -------------------------------------------------------------------------- */

#define dataToTagzh(r,a)  r=(GET_TAG(((StgClosure *)a)->header.info))
/*  tagToEnum# is handled directly by the code generator. */

774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
/* -----------------------------------------------------------------------------
   Signal processing.  Not really primops, but called directly from
   Haskell. 
   -------------------------------------------------------------------------- */

#define STG_SIG_DFL  (-1)
#define STG_SIG_IGN  (-2)
#define STG_SIG_ERR  (-3)
#define STG_SIG_HAN  (-4)

extern StgInt sig_install (StgInt, StgInt, StgStablePtr, sigset_t *);
#define stg_sig_default(sig,mask) sig_install(sig,STG_SIG_DFL,0,(sigset_t *)mask)
#define stg_sig_ignore(sig,mask) sig_install(sig,STG_SIG_IGN,0,(sigset_t *)mask)
#define stg_sig_catch(sig,ptr,mask) sig_install(sig,STG_SIG_HAN,ptr,(sigset_t *)mask)

#endif PRIMOPS_H