ghc/includes/PrimOps.h

   1 /* -----------------------------------------------------------------------------
   2  * $Id: PrimOps.h,v 1.68 2000/12/04 12:31:20 simonmar Exp $
   3  *
   4  * (c) The GHC Team, 1998-2000
   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    Helpers for the metacircular interpreter.
  15    -------------------------------------------------------------------------- */
  16
  17 #ifdef GHCI
  18
  19 #define CHASE_INDIRECTIONS(lval)                                        \
  20    do {                                                                 \
  21         int again;                                                      \
  22         do {                                                            \
  23            again = 0;                                                   \
  24            if (get_itbl((StgClosure*)lval)->type == IND)                \
  25               { again = 1; lval = ((StgInd*)lval)->indirectee; }        \
  26            else                                                         \
  27            if (get_itbl((StgClosure*)lval)->type == IND_OLDGEN)         \
  28               { again = 1; lval = ((StgIndOldGen*)lval)->indirectee; }  \
  29         } while (again);                                                \
  30    } while (0)
  31
  32 #define indexWordOffClosurezh(r,a,i)            \
  33    do { StgClosure* tmp = (StgClosure*)(a);     \
  34         CHASE_INDIRECTIONS(tmp);                \
  35         r = ((P_)tmp)[i];                       \
  36    } while (0)
  37
  38 #define indexDoubleOffClosurezh(r,a,i)          \
  39    do { StgClosure* tmp = (StgClosure*)(a);     \
  40         CHASE_INDIRECTIONS(tmp);                \
  41         r = PK_DBL(((P_)tmp + i);               \
  42    } while (0)
  43
  44 #define indexPtrOffClosurezh(r,a,i)             \
  45    do { StgClosure* tmp = (StgClosure*)(a);     \
  46         CHASE_INDIRECTIONS(tmp);                \
  47         r = ((P_ *)tmp)[i];                     \
  48    } while (0)                                  \
  49
  50 #define setWordOffClosurezh(r,a,i,b)            \
  51    do { StgClosure* tmp = (StgClosure*)(a);     \
  52         CHASE_INDIRECTIONS(tmp);                \
  53         ((P_)tmp)[i] = b;                       \
  54         r = (P_)tmp;                            \
  55    } while (0)
  56
  57 #define setDoubleOffClosurezh(r,a,i,b)          \
  58    do { StgClosure* tmp = (StgClosure*)(a);     \
  59         CHASE_INDIRECTIONS(tmp);                \
  60         ASSIGN_DBL((P_)tmp + i, b);             \
  61         r = (P_)tmp;                            \
  62    } while (0)
  63
  64 #define setPtrOffClosurezh(r,a,i,b)             \
  65    do { StgClosure* tmp = (StgClosure*)(a);     \
  66         CHASE_INDIRECTIONS(tmp);                \
  67         ((P_ *)tmp)[i] = b;                     \
  68         r = (P_)tmp;                            \
  69    } while (0)
  70
  71 #else
  72
  73 #endif
  74
  75 /* -----------------------------------------------------------------------------
  76    Comparison PrimOps.
  77    -------------------------------------------------------------------------- */
  78
  79 #define gtCharzh(r,a,b) r=(I_)((a)> (b))
  80 #define geCharzh(r,a,b) r=(I_)((a)>=(b))
  81 #define eqCharzh(r,a,b) r=(I_)((a)==(b))
  82 #define neCharzh(r,a,b) r=(I_)((a)!=(b))
  83 #define ltCharzh(r,a,b) r=(I_)((a)< (b))
  84 #define leCharzh(r,a,b) r=(I_)((a)<=(b))
  85
  86 /* Int comparisons: >#, >=# etc */
  87 #define zgzh(r,a,b)     r=(I_)((I_)(a) >(I_)(b))
  88 #define zgzezh(r,a,b)   r=(I_)((I_)(a)>=(I_)(b))
  89 #define zezezh(r,a,b)   r=(I_)((I_)(a)==(I_)(b))
  90 #define zszezh(r,a,b)   r=(I_)((I_)(a)!=(I_)(b))
  91 #define zlzh(r,a,b)     r=(I_)((I_)(a) <(I_)(b))
  92 #define zlzezh(r,a,b)   r=(I_)((I_)(a)<=(I_)(b))
  93
  94 #define gtWordzh(r,a,b) r=(I_)((W_)(a) >(W_)(b))
  95 #define geWordzh(r,a,b) r=(I_)((W_)(a)>=(W_)(b))
  96 #define eqWordzh(r,a,b) r=(I_)((W_)(a)==(W_)(b))
  97 #define neWordzh(r,a,b) r=(I_)((W_)(a)!=(W_)(b))
  98 #define ltWordzh(r,a,b) r=(I_)((W_)(a) <(W_)(b))
  99 #define leWordzh(r,a,b) r=(I_)((W_)(a)<=(W_)(b))
 100
 101 #define gtAddrzh(r,a,b) r=(I_)((a) >(b))
 102 #define geAddrzh(r,a,b) r=(I_)((a)>=(b))
 103 #define eqAddrzh(r,a,b) r=(I_)((a)==(b))
 104 #define neAddrzh(r,a,b) r=(I_)((a)!=(b))
 105 #define ltAddrzh(r,a,b) r=(I_)((a) <(b))
 106 #define leAddrzh(r,a,b) r=(I_)((a)<=(b))
 107
 108 #define gtFloatzh(r,a,b)  r=(I_)((a)> (b))
 109 #define geFloatzh(r,a,b)  r=(I_)((a)>=(b))
 110 #define eqFloatzh(r,a,b)  r=(I_)((a)==(b))
 111 #define neFloatzh(r,a,b)  r=(I_)((a)!=(b))
 112 #define ltFloatzh(r,a,b)  r=(I_)((a)< (b))
 113 #define leFloatzh(r,a,b)  r=(I_)((a)<=(b))
 114
 115 /* Double comparisons: >##, >=#@ etc */
 116 #define zgzhzh(r,a,b)   r=(I_)((a) >(b))
 117 #define zgzezhzh(r,a,b) r=(I_)((a)>=(b))
 118 #define zezezhzh(r,a,b) r=(I_)((a)==(b))
 119 #define zszezhzh(r,a,b) r=(I_)((a)!=(b))
 120 #define zlzhzh(r,a,b)   r=(I_)((a) <(b))
 121 #define zlzezhzh(r,a,b) r=(I_)((a)<=(b))
 122
 123 /* -----------------------------------------------------------------------------
 124    Char# PrimOps.
 125    -------------------------------------------------------------------------- */
 126
 127 #define ordzh(r,a)      r=(I_)((W_) (a))
 128 #define chrzh(r,a)      r=(StgChar)((W_)(a))
 129
 130 /* -----------------------------------------------------------------------------
 131    Int# PrimOps.
 132    -------------------------------------------------------------------------- */
 133
 134 I_ stg_div (I_ a, I_ b);
 135
 136 #define zpzh(r,a,b)             r=(a)+(b)
 137 #define zmzh(r,a,b)             r=(a)-(b)
 138 #define ztzh(r,a,b)             r=(a)*(b)
 139 #define quotIntzh(r,a,b)        r=(a)/(b)
 140 #define zszh(r,a,b)             r=ULTRASAFESTGCALL2(I_,(void *, I_, I_),stg_div,(a),(b))
 141 #define remIntzh(r,a,b)         r=(a)%(b)
 142 #define negateIntzh(r,a)        r=-(a)
 143
 144 /* -----------------------------------------------------------------------------
 145  * Int operations with carry.
 146  * -------------------------------------------------------------------------- */
 147
 148 /* With some bit-twiddling, we can define int{Add,Sub}Czh portably in
 149  * C, and without needing any comparisons.  This may not be the
 150  * fastest way to do it - if you have better code, please send it! --SDM
 151  *
 152  * Return : r = a + b,  c = 0 if no overflow, 1 on overflow.
 153  *
 154  * We currently don't make use of the r value if c is != 0 (i.e.
 155  * overflow), we just convert to big integers and try again.  This
 156  * could be improved by making r and c the correct values for
 157  * plugging into a new J#.
 158  */
 159 #define addIntCzh(r,c,a,b)                      \
 160 { r = a + b;                                    \
 161   c = ((StgWord)(~(a^b) & (a^r)))               \
 162     >> (BITS_PER_BYTE * sizeof(I_) - 1);        \
 163 }
 164
 165
 166 #define subIntCzh(r,c,a,b)                      \
 167 { r = a - b;                                    \
 168   c = ((StgWord)((a^b) & (a^r)))                \
 169     >> (BITS_PER_BYTE * sizeof(I_) - 1);        \
 170 }
 171
 172 /* Multiply with overflow checking.
 173  *
 174  * This is slightly more tricky - the usual sign rules for add/subtract
 175  * don't apply.
 176  *
 177  * On x86 hardware we use a hand-crafted assembly fragment to do the job.
 178  *
 179  * On other 32-bit machines we use gcc's 'long long' types, finding
 180  * overflow with some careful bit-twiddling.
 181  *
 182  * On 64-bit machines where gcc's 'long long' type is also 64-bits,
 183  * we use a crude approximation, testing whether either operand is
 184  * larger than 32-bits; if neither is, then we go ahead with the
 185  * multiplication.
 186  */
 187
 188 #if i386_TARGET_ARCH
 189
 190 #define mulIntCzh(r,c,a,b)                              \
 191 {                                                       \
 192   __asm__("xorl %1,%1\n\t                               \
 193            imull %2,%3\n\t                              \
 194            jno 1f\n\t                                   \
 195            movl $1,%1\n\t                               \
 196            1:"                                          \
 197         : "=r" (r), "=&r" (c) : "r" (a), "0" (b));      \
 198 }
 199
 200 #elif SIZEOF_VOID_P == 4
 201
 202 #ifdef WORDS_BIGENDIAN
 203 #define C 0
 204 #define R 1
 205 #else
 206 #define C 1
 207 #define R 0
 208 #endif
 209
 210 typedef union {
 211     StgInt64 l;
 212     StgInt32 i[2];
 213 } long_long_u ;
 214
 215 #define mulIntCzh(r,c,a,b)                      \
 216 {                                               \
 217   long_long_u z;                                \
 218   z.l = (StgInt64)a * (StgInt64)b;              \
 219   r = z.i[R];                                   \
 220   c = z.i[C];                                   \
 221   if (c == 0 || c == -1) {                      \
 222     c = ((StgWord)((a^b) ^ r))                  \
 223       >> (BITS_PER_BYTE * sizeof(I_) - 1);      \
 224   }                                             \
 225 }
 226 /* Careful: the carry calculation above is extremely delicate.  Make sure
 227  * you test it thoroughly after changing it.
 228  */
 229
 230 #else
 231
 232 #define HALF_INT  (1 << (BITS_PER_BYTE * sizeof(I_) / 2))
 233
 234 #define stg_abs(a) ((a) < 0 ? -(a) : (a))
 235
 236 #define mulIntCzh(r,c,a,b)                      \
 237 {                                               \
 238   if (stg_abs(a) >= HALF_INT                    \
 239       stg_abs(b) >= HALF_INT) {                 \
 240     c = 1;                                      \
 241   } else {                                      \
 242     r = a * b;                                  \
 243     c = 0;                                      \
 244   }                                             \
 245 }
 246 #endif
 247
 248 /* -----------------------------------------------------------------------------
 249    Word PrimOps.
 250    -------------------------------------------------------------------------- */
 251
 252 #define quotWordzh(r,a,b)       r=((W_)a)/((W_)b)
 253 #define remWordzh(r,a,b)        r=((W_)a)%((W_)b)
 254
 255 #define andzh(r,a,b)            r=(a)&(b)
 256 #define orzh(r,a,b)             r=(a)|(b)
 257 #define xorzh(r,a,b)            r=(a)^(b)
 258 #define notzh(r,a)              r=~(a)
 259
 260 /* The extra tests below properly define the behaviour when shifting
 261  * by offsets larger than the width of the value being shifted.  Doing
 262  * so is undefined in C (and in fact gives different answers depending
 263  * on whether the operation is constant folded or not with gcc on x86!)
 264  */
 265
 266 #define shiftLzh(r,a,b)         r=((b) >= BITS_IN(W_)) ? 0 : (a)<<(b)
 267 #define shiftRLzh(r,a,b)        r=((b) >= BITS_IN(W_)) ? 0 : (a)>>(b)
 268 #define iShiftLzh(r,a,b)        r=((b) >= BITS_IN(W_)) ? 0 : (a)<<(b)
 269 /* Right shifting of signed quantities is not portable in C, so
 270    the behaviour you'll get from using these primops depends
 271    on the whatever your C compiler is doing. ToDo: fix/document. -- sof 8/98
 272 */
 273 #define iShiftRAzh(r,a,b)       r=((b) >= BITS_IN(I_)) ? (((a) < 0) ? -1 : 0) : (a)>>(b)
 274 #define iShiftRLzh(r,a,b)       r=((b) >= BITS_IN(I_)) ? 0 : ((W_)(a))>>(b)
 275
 276 #define int2Wordzh(r,a)         r=(W_)(a)
 277 #define word2Intzh(r,a)         r=(I_)(a)
 278
 279 /* -----------------------------------------------------------------------------
 280    Addr PrimOps.
 281    -------------------------------------------------------------------------- */
 282
 283 #define int2Addrzh(r,a)         r=(A_)(a)
 284 #define addr2Intzh(r,a)         r=(I_)(a)
 285
 286 #define readCharOffAddrzh(r,a,i)        r= ((unsigned char *)(a))[i]
 287 /* unsigned char is for compatibility: the index is still in bytes. */
 288 #define readIntOffAddrzh(r,a,i)         r= ((I_ *)(a))[i]
 289 #define readWordOffAddrzh(r,a,i)        r= ((W_ *)(a))[i]
 290 #define readAddrOffAddrzh(r,a,i)        r= ((PP_)(a))[i]
 291 #define readFloatOffAddrzh(r,a,i)       r= PK_FLT((P_) (((StgFloat *)(a)) + i))
 292 #define readDoubleOffAddrzh(r,a,i)      r= PK_DBL((P_) (((StgDouble *)(a)) + i))
 293 #define readStablePtrOffAddrzh(r,a,i)   r= ((StgStablePtr *)(a))[i]
 294 #ifdef SUPPORT_LONG_LONGS
 295 #define readInt64OffAddrzh(r,a,i)       r= ((LI_ *)(a))[i]
 296 #define readWord64OffAddrzh(r,a,i)      r= ((LW_ *)(a))[i]
 297 #endif
 298
 299 #define writeCharOffAddrzh(a,i,v)       ((unsigned char *)(a))[i] = (unsigned char)(v)
 300 /* unsigned char is for compatibility: the index is still in bytes. */
 301 #define writeIntOffAddrzh(a,i,v)        ((I_ *)(a))[i] = (v)
 302 #define writeWordOffAddrzh(a,i,v)       ((W_ *)(a))[i] = (v)
 303 #define writeAddrOffAddrzh(a,i,v)       ((PP_)(a))[i] = (v)
 304 #define writeForeignObjOffAddrzh(a,i,v) ((PP_)(a))[i] = ForeignObj_CLOSURE_DATA(v)
 305 #define writeFloatOffAddrzh(a,i,v)      ASSIGN_FLT((P_) (((StgFloat *)(a)) + i),v)
 306 #define writeDoubleOffAddrzh(a,i,v)     ASSIGN_DBL((P_) (((StgDouble *)(a)) + i),v)
 307 #define writeStablePtrOffAddrzh(a,i,v)  ((StgStablePtr *)(a))[i] = (v)
 308 #ifdef SUPPORT_LONG_LONGS
 309 #define writeInt64OffAddrzh(a,i,v)   ((LI_ *)(a))[i] = (v)
 310 #define writeWord64OffAddrzh(a,i,v)  ((LW_ *)(a))[i] = (v)
 311 #endif
 312
 313 #define indexCharOffAddrzh(r,a,i)       r= ((unsigned char *)(a))[i]
 314 /* unsigned char is for compatibility: the index is still in bytes. */
 315 #define indexIntOffAddrzh(r,a,i)        r= ((I_ *)(a))[i]
 316 #define indexWordOffAddrzh(r,a,i)       r= ((W_ *)(a))[i]
 317 #define indexAddrOffAddrzh(r,a,i)       r= ((PP_)(a))[i]
 318 #define indexFloatOffAddrzh(r,a,i)      r= PK_FLT((P_) (((StgFloat *)(a)) + i))
 319 #define indexDoubleOffAddrzh(r,a,i)     r= PK_DBL((P_) (((StgDouble *)(a)) + i))
 320 #define indexStablePtrOffAddrzh(r,a,i)  r= ((StgStablePtr *)(a))[i]
 321 #ifdef SUPPORT_LONG_LONGS
 322 #define indexInt64OffAddrzh(r,a,i)      r= ((LI_ *)(a))[i]
 323 #define indexWord64OffAddrzh(r,a,i)     r= ((LW_ *)(a))[i]
 324 #endif
 325
 326 /* -----------------------------------------------------------------------------
 327    Float PrimOps.
 328    -------------------------------------------------------------------------- */
 329
 330 #define plusFloatzh(r,a,b)   r=(a)+(b)
 331 #define minusFloatzh(r,a,b)  r=(a)-(b)
 332 #define timesFloatzh(r,a,b)  r=(a)*(b)
 333 #define divideFloatzh(r,a,b) r=(a)/(b)
 334 #define negateFloatzh(r,a)   r=-(a)
 335
 336 #define int2Floatzh(r,a)     r=(StgFloat)(a)
 337 #define float2Intzh(r,a)     r=(I_)(a)
 338
 339 #define expFloatzh(r,a)      r=(StgFloat) RET_PRIM_STGCALL1(StgDouble,exp,a)
 340 #define logFloatzh(r,a)      r=(StgFloat) RET_PRIM_STGCALL1(StgDouble,log,a)
 341 #define sqrtFloatzh(r,a)     r=(StgFloat) RET_PRIM_STGCALL1(StgDouble,sqrt,a)
 342 #define sinFloatzh(r,a)      r=(StgFloat) RET_PRIM_STGCALL1(StgDouble,sin,a)
 343 #define cosFloatzh(r,a)      r=(StgFloat) RET_PRIM_STGCALL1(StgDouble,cos,a)
 344 #define tanFloatzh(r,a)      r=(StgFloat) RET_PRIM_STGCALL1(StgDouble,tan,a)
 345 #define asinFloatzh(r,a)     r=(StgFloat) RET_PRIM_STGCALL1(StgDouble,asin,a)
 346 #define acosFloatzh(r,a)     r=(StgFloat) RET_PRIM_STGCALL1(StgDouble,acos,a)
 347 #define atanFloatzh(r,a)     r=(StgFloat) RET_PRIM_STGCALL1(StgDouble,atan,a)
 348 #define sinhFloatzh(r,a)     r=(StgFloat) RET_PRIM_STGCALL1(StgDouble,sinh,a)
 349 #define coshFloatzh(r,a)     r=(StgFloat) RET_PRIM_STGCALL1(StgDouble,cosh,a)
 350 #define tanhFloatzh(r,a)     r=(StgFloat) RET_PRIM_STGCALL1(StgDouble,tanh,a)
 351 #define powerFloatzh(r,a,b)  r=(StgFloat) RET_PRIM_STGCALL2(StgDouble,pow,a,b)
 352
 353 /* -----------------------------------------------------------------------------
 354    Double PrimOps.
 355    -------------------------------------------------------------------------- */
 356
 357 #define zpzhzh(r,a,b)        r=(a)+(b)
 358 #define zmzhzh(r,a,b)        r=(a)-(b)
 359 #define ztzhzh(r,a,b)        r=(a)*(b)
 360 #define zszhzh(r,a,b)        r=(a)/(b)
 361 #define negateDoublezh(r,a)  r=-(a)
 362
 363 #define int2Doublezh(r,a)    r=(StgDouble)(a)
 364 #define double2Intzh(r,a)    r=(I_)(a)
 365
 366 #define float2Doublezh(r,a)  r=(StgDouble)(a)
 367 #define double2Floatzh(r,a)  r=(StgFloat)(a)
 368
 369 #define expDoublezh(r,a)     r=(StgDouble) RET_PRIM_STGCALL1(StgDouble,exp,a)
 370 #define logDoublezh(r,a)     r=(StgDouble) RET_PRIM_STGCALL1(StgDouble,log,a)
 371 #define sqrtDoublezh(r,a)    r=(StgDouble) RET_PRIM_STGCALL1(StgDouble,sqrt,a)
 372 #define sinDoublezh(r,a)     r=(StgDouble) RET_PRIM_STGCALL1(StgDouble,sin,a)
 373 #define cosDoublezh(r,a)     r=(StgDouble) RET_PRIM_STGCALL1(StgDouble,cos,a)
 374 #define tanDoublezh(r,a)     r=(StgDouble) RET_PRIM_STGCALL1(StgDouble,tan,a)
 375 #define asinDoublezh(r,a)    r=(StgDouble) RET_PRIM_STGCALL1(StgDouble,asin,a)
 376 #define acosDoublezh(r,a)    r=(StgDouble) RET_PRIM_STGCALL1(StgDouble,acos,a)
 377 #define atanDoublezh(r,a)    r=(StgDouble) RET_PRIM_STGCALL1(StgDouble,atan,a)
 378 #define sinhDoublezh(r,a)    r=(StgDouble) RET_PRIM_STGCALL1(StgDouble,sinh,a)
 379 #define coshDoublezh(r,a)    r=(StgDouble) RET_PRIM_STGCALL1(StgDouble,cosh,a)
 380 #define tanhDoublezh(r,a)    r=(StgDouble) RET_PRIM_STGCALL1(StgDouble,tanh,a)
 381 /* Power: **## */
 382 #define ztztzhzh(r,a,b) r=(StgDouble) RET_PRIM_STGCALL2(StgDouble,pow,a,b)
 383
 384 /* -----------------------------------------------------------------------------
 385    Integer PrimOps.
 386    -------------------------------------------------------------------------- */
 387
 388 /* We can do integer2Int and cmpInteger inline, since they don't need
 389  * to allocate any memory.
 390  *
 391  * integer2Int# is now modular.
 392  */
 393
 394 #define integer2Intzh(r, sa,da)                         \
 395 { StgWord word0 = ((StgWord *)BYTE_ARR_CTS(da))[0];     \
 396   int size = sa;                                        \
 397                                                         \
 398   (r) =                                                 \
 399     ( size == 0 ) ?                                     \
 400        0 :                                              \
 401        ( size < 0 && word0 != 0x8000000 ) ?             \
 402          -(I_)word0 :                                   \
 403           (I_)word0;                                    \
 404 }
 405
 406 #define integer2Wordzh(r, sa,da)                        \
 407 { StgWord word0 = ((StgWord *)BYTE_ARR_CTS(da))[0];     \
 408   int size = sa;                                        \
 409   (r) = ( size == 0 ) ? 0 : word0 ;                     \
 410 }
 411
 412 #define cmpIntegerzh(r, s1,d1, s2,d2)                           \
 413 { MP_INT arg1;                                                  \
 414   MP_INT arg2;                                                  \
 415                                                                 \
 416   arg1._mp_size = (s1);                                         \
 417   arg1._mp_alloc= ((StgArrWords *)d1)->words;                   \
 418   arg1._mp_d    = (unsigned long int *) (BYTE_ARR_CTS(d1));     \
 419   arg2._mp_size = (s2);                                         \
 420   arg2._mp_alloc= ((StgArrWords *)d2)->words;                   \
 421   arg2._mp_d    = (unsigned long int *) (BYTE_ARR_CTS(d2));     \
 422                                                                 \
 423   (r) = RET_PRIM_STGCALL2(I_,mpz_cmp,&arg1,&arg2);              \
 424 }
 425
 426 #define cmpIntegerIntzh(r, s,d, i)                              \
 427 { MP_INT arg;                                                   \
 428                                                                 \
 429   arg._mp_size  = (s);                                          \
 430   arg._mp_alloc = ((StgArrWords *)d)->words;                    \
 431   arg._mp_d     = (unsigned long int *) (BYTE_ARR_CTS(d));      \
 432                                                                 \
 433   (r) = RET_PRIM_STGCALL2(I_,mpz_cmp_si,&arg,i);                \
 434 }
 435
 436 /* NOTE: gcdIntzh and gcdIntegerIntzh work only for positive inputs! */
 437
 438 /* mp_limb_t must be able to hold an StgInt for this to work properly */
 439 #define gcdIntzh(r,a,b) \
 440 { mp_limb_t aa = (mp_limb_t)(a); \
 441   r = RET_STGCALL3(StgInt, mpn_gcd_1, (mp_limb_t *)(&aa), 1, (mp_limb_t)(b)); \
 442 }
 443
 444 #define gcdIntegerIntzh(r,sa,a,b) \
 445   r = RET_STGCALL3(StgInt, mpn_gcd_1, (mp_limb_t *)(BYTE_ARR_CTS(a)), sa, b)
 446
 447 /* The rest are all out-of-line: -------- */
 448
 449 /* Integer arithmetic */
 450 EXTFUN_RTS(plusIntegerzh_fast);
 451 EXTFUN_RTS(minusIntegerzh_fast);
 452 EXTFUN_RTS(timesIntegerzh_fast);
 453 EXTFUN_RTS(gcdIntegerzh_fast);
 454 EXTFUN_RTS(quotRemIntegerzh_fast);
 455 EXTFUN_RTS(quotIntegerzh_fast);
 456 EXTFUN_RTS(remIntegerzh_fast);
 457 EXTFUN_RTS(divExactIntegerzh_fast);
 458 EXTFUN_RTS(divModIntegerzh_fast);
 459
 460 /* Conversions */
 461 EXTFUN_RTS(int2Integerzh_fast);
 462 EXTFUN_RTS(word2Integerzh_fast);
 463
 464 /* Floating-point decodings */
 465 EXTFUN_RTS(decodeFloatzh_fast);
 466 EXTFUN_RTS(decodeDoublezh_fast);
 467
 468 /* Bit operations */
 469 EXTFUN_RTS(andIntegerzh_fast);
 470 EXTFUN_RTS(orIntegerzh_fast);
 471 EXTFUN_RTS(xorIntegerzh_fast);
 472 EXTFUN_RTS(complementIntegerzh_fast);
 473
 474 /* -----------------------------------------------------------------------------
 475    Word64 PrimOps.
 476    -------------------------------------------------------------------------- */
 477
 478 #ifdef SUPPORT_LONG_LONGS
 479
 480 #define integerToWord64zh(r, sa,da)                     \
 481 { unsigned long int* d;                                 \
 482   I_ s;                                                 \
 483   StgWord64 res;                                        \
 484                                                         \
 485   d = (unsigned long int *) (BYTE_ARR_CTS(da));         \
 486   s = (sa);                                             \
 487   if ( s == 0 ) {                                       \
 488      res = (LW_)0;                                      \
 489   } else if ( s == 1) {                                 \
 490      res = (LW_)d[0];                                   \
 491   } else {                                              \
 492      res = (LW_)d[0] + (LW_)d[1] * 0x100000000ULL;      \
 493   }                                                     \
 494   (r) = res;                                            \
 495 }
 496
 497 #define integerToInt64zh(r, sa,da)                      \
 498 { unsigned long int* d;                                 \
 499   I_ s;                                                 \
 500   StgInt64 res;                                         \
 501                                                         \
 502   d = (unsigned long int *) (BYTE_ARR_CTS(da));         \
 503   s = (sa);                                             \
 504   if ( s == 0 ) {                                       \
 505      res = (LI_)0;                                      \
 506   } else if ( s == 1) {                                 \
 507      res = (LI_)d[0];                                   \
 508   } else {                                              \
 509      res = (LI_)d[0] + (LI_)d[1] * 0x100000000LL;       \
 510      if ( s < 0 ) {                                     \
 511            res = (LI_)-res;                             \
 512      }                                                  \
 513   }                                                     \
 514   (r) = res;                                            \
 515 }
 516
 517 /* Conversions */
 518 EXTFUN_RTS(int64ToIntegerzh_fast);
 519 EXTFUN_RTS(word64ToIntegerzh_fast);
 520
 521 /* The rest are (way!) out of line, implemented via C entry points.
 522  */
 523 I_ stg_gtWord64 (StgWord64, StgWord64);
 524 I_ stg_geWord64 (StgWord64, StgWord64);
 525 I_ stg_eqWord64 (StgWord64, StgWord64);
 526 I_ stg_neWord64 (StgWord64, StgWord64);
 527 I_ stg_ltWord64 (StgWord64, StgWord64);
 528 I_ stg_leWord64 (StgWord64, StgWord64);
 529
 530 I_ stg_gtInt64 (StgInt64, StgInt64);
 531 I_ stg_geInt64 (StgInt64, StgInt64);
 532 I_ stg_eqInt64 (StgInt64, StgInt64);
 533 I_ stg_neInt64 (StgInt64, StgInt64);
 534 I_ stg_ltInt64 (StgInt64, StgInt64);
 535 I_ stg_leInt64 (StgInt64, StgInt64);
 536
 537 LW_ stg_remWord64  (StgWord64, StgWord64);
 538 LW_ stg_quotWord64 (StgWord64, StgWord64);
 539
 540 LI_ stg_remInt64    (StgInt64, StgInt64);
 541 LI_ stg_quotInt64   (StgInt64, StgInt64);
 542 LI_ stg_negateInt64 (StgInt64);
 543 LI_ stg_plusInt64   (StgInt64, StgInt64);
 544 LI_ stg_minusInt64  (StgInt64, StgInt64);
 545 LI_ stg_timesInt64  (StgInt64, StgInt64);
 546
 547 LW_ stg_and64  (StgWord64, StgWord64);
 548 LW_ stg_or64   (StgWord64, StgWord64);
 549 LW_ stg_xor64  (StgWord64, StgWord64);
 550 LW_ stg_not64  (StgWord64);
 551
 552 LW_ stg_shiftL64   (StgWord64, StgInt);
 553 LW_ stg_shiftRL64  (StgWord64, StgInt);
 554 LI_ stg_iShiftL64  (StgInt64, StgInt);
 555 LI_ stg_iShiftRL64 (StgInt64, StgInt);
 556 LI_ stg_iShiftRA64 (StgInt64, StgInt);
 557
 558 LI_ stg_intToInt64    (StgInt);
 559 I_ stg_int64ToInt     (StgInt64);
 560 LW_ stg_int64ToWord64 (StgInt64);
 561
 562 LW_ stg_wordToWord64  (StgWord);
 563 W_  stg_word64ToWord  (StgWord64);
 564 LI_ stg_word64ToInt64 (StgWord64);
 565 #endif
 566
 567 /* -----------------------------------------------------------------------------
 568    Array PrimOps.
 569    -------------------------------------------------------------------------- */
 570
 571 /* We cast to void* instead of StgChar* because this avoids a warning
 572  * about increasing the alignment requirements.
 573  */
 574 #define REAL_BYTE_ARR_CTS(a)   ((void *) (((StgArrWords *)(a))->payload))
 575 #define REAL_PTRS_ARR_CTS(a)   ((P_)   (((StgMutArrPtrs  *)(a))->payload))
 576
 577 #ifdef DEBUG
 578 #define BYTE_ARR_CTS(a)                           \
 579  ({ ASSERT(GET_INFO((StgArrWords *)(a)) == &stg_ARR_WORDS_info);          \
 580     REAL_BYTE_ARR_CTS(a); })
 581 #define PTRS_ARR_CTS(a)                           \
 582  ({ ASSERT((GET_INFO((StgMutArrPtrs  *)(a)) == &stg_MUT_ARR_PTRS_FROZEN_info)     \
 583         || (GET_INFO((StgMutArrPtrs  *)(a)) == &stg_MUT_ARR_PTRS_info));  \
 584     REAL_PTRS_ARR_CTS(a); })
 585 #else
 586 #define BYTE_ARR_CTS(a)         REAL_BYTE_ARR_CTS(a)
 587 #define PTRS_ARR_CTS(a)         REAL_PTRS_ARR_CTS(a)
 588 #endif
 589
 590 extern I_ genSymZh(void);
 591 extern I_ resetGenSymZh(void);
 592
 593 /*--- everything except new*Array is done inline: */
 594
 595 #define sameMutableArrayzh(r,a,b)       r=(I_)((a)==(b))
 596 #define sameMutableByteArrayzh(r,a,b)   r=(I_)((a)==(b))
 597
 598 #define readArrayzh(r,a,i)       r=((PP_) PTRS_ARR_CTS(a))[(i)]
 599
 600 #define readCharArrayzh(r,a,i)   indexCharOffAddrzh(r,BYTE_ARR_CTS(a),i)
 601 #define readIntArrayzh(r,a,i)    indexIntOffAddrzh(r,BYTE_ARR_CTS(a),i)
 602 #define readWordArrayzh(r,a,i)   indexWordOffAddrzh(r,BYTE_ARR_CTS(a),i)
 603 #define readAddrArrayzh(r,a,i)   indexAddrOffAddrzh(r,BYTE_ARR_CTS(a),i)
 604 #define readFloatArrayzh(r,a,i)  indexFloatOffAddrzh(r,BYTE_ARR_CTS(a),i)
 605 #define readDoubleArrayzh(r,a,i) indexDoubleOffAddrzh(r,BYTE_ARR_CTS(a),i)
 606 #define readStablePtrArrayzh(r,a,i) indexStablePtrOffAddrzh(r,BYTE_ARR_CTS(a),i)
 607 #ifdef SUPPORT_LONG_LONGS
 608 #define readInt64Arrayzh(r,a,i)  indexInt64OffAddrzh(r,BYTE_ARR_CTS(a),i)
 609 #define readWord64Arrayzh(r,a,i) indexWord64OffAddrzh(r,BYTE_ARR_CTS(a),i)
 610 #endif
 611
 612 /* result ("r") arg ignored in write macros! */
 613 #define writeArrayzh(a,i,v)     ((PP_) PTRS_ARR_CTS(a))[(i)]=(v)
 614
 615 #define writeCharArrayzh(a,i,v)   ((unsigned char *)(BYTE_ARR_CTS(a)))[i] = (unsigned char)(v)
 616 /* unsigned char is for compatibility: the index is still in bytes. */
 617 #define writeIntArrayzh(a,i,v)    ((I_ *)(BYTE_ARR_CTS(a)))[i] = (v)
 618 #define writeWordArrayzh(a,i,v)   ((W_ *)(BYTE_ARR_CTS(a)))[i] = (v)
 619 #define writeAddrArrayzh(a,i,v)   ((PP_)(BYTE_ARR_CTS(a)))[i] = (v)
 620 #define writeFloatArrayzh(a,i,v)  \
 621         ASSIGN_FLT((P_) (((StgFloat *)(BYTE_ARR_CTS(a))) + i),v)
 622 #define writeDoubleArrayzh(a,i,v) \
 623         ASSIGN_DBL((P_) (((StgDouble *)(BYTE_ARR_CTS(a))) + i),v)
 624 #define writeStablePtrArrayzh(a,i,v)      ((StgStablePtr *)(BYTE_ARR_CTS(a)))[i] = (v)
 625 #ifdef SUPPORT_LONG_LONGS
 626 #define writeInt64Arrayzh(a,i,v)  ((LI_ *)(BYTE_ARR_CTS(a)))[i] = (v)
 627 #define writeWord64Arrayzh(a,i,v) ((LW_ *)(BYTE_ARR_CTS(a)))[i] = (v)
 628 #endif
 629
 630 #define indexArrayzh(r,a,i)       r=((PP_) PTRS_ARR_CTS(a))[(i)]
 631
 632 #define indexCharArrayzh(r,a,i)   indexCharOffAddrzh(r,BYTE_ARR_CTS(a),i)
 633 #define indexIntArrayzh(r,a,i)    indexIntOffAddrzh(r,BYTE_ARR_CTS(a),i)
 634 #define indexWordArrayzh(r,a,i)   indexWordOffAddrzh(r,BYTE_ARR_CTS(a),i)
 635 #define indexAddrArrayzh(r,a,i)   indexAddrOffAddrzh(r,BYTE_ARR_CTS(a),i)
 636 #define indexFloatArrayzh(r,a,i)  indexFloatOffAddrzh(r,BYTE_ARR_CTS(a),i)
 637 #define indexDoubleArrayzh(r,a,i) indexDoubleOffAddrzh(r,BYTE_ARR_CTS(a),i)
 638 #define indexStablePtrArrayzh(r,a,i) indexStablePtrOffAddrzh(r,BYTE_ARR_CTS(a),i)
 639 #ifdef SUPPORT_LONG_LONGS
 640 #define indexInt64Arrayzh(r,a,i)  indexInt64OffAddrzh(r,BYTE_ARR_CTS(a),i)
 641 #define indexWord64Arrayzh(r,a,i) indexWord64OffAddrzh(r,BYTE_ARR_CTS(a),i)
 642 #endif
 643
 644 /* Freezing arrays-of-ptrs requires changing an info table, for the
 645    benefit of the generational collector.  It needs to scavenge mutable
 646    objects, even if they are in old space.  When they become immutable,
 647    they can be removed from this scavenge list.  */
 648
 649 #define unsafeFreezzeArrayzh(r,a)                                       \
 650         {                                                               \
 651         SET_INFO((StgClosure *)a,&stg_MUT_ARR_PTRS_FROZEN_info);        \
 652         r = a;                                                          \
 653         }
 654
 655 #define unsafeFreezzeByteArrayzh(r,a)   r=(a)
 656
 657 EXTFUN_RTS(unsafeThawArrayzh_fast);
 658
 659 #define sizzeofByteArrayzh(r,a) \
 660      r = (((StgArrWords *)(a))->words * sizeof(W_))
 661 #define sizzeofMutableByteArrayzh(r,a) \
 662      r = (((StgArrWords *)(a))->words * sizeof(W_))
 663
 664 /* and the out-of-line ones... */
 665
 666 EXTFUN_RTS(newCharArrayzh_fast);
 667 EXTFUN_RTS(newIntArrayzh_fast);
 668 EXTFUN_RTS(newWordArrayzh_fast);
 669 EXTFUN_RTS(newAddrArrayzh_fast);
 670 EXTFUN_RTS(newFloatArrayzh_fast);
 671 EXTFUN_RTS(newDoubleArrayzh_fast);
 672 EXTFUN_RTS(newStablePtrArrayzh_fast);
 673 EXTFUN_RTS(newArrayzh_fast);
 674
 675 /* encoding and decoding of floats/doubles. */
 676
 677 /* We only support IEEE floating point format */
 678 #include "ieee-flpt.h"
 679
 680 /* The decode operations are out-of-line because they need to allocate
 681  * a byte array.
 682  */
 683 EXTFUN_RTS(decodeFloatzh_fast);
 684 EXTFUN_RTS(decodeDoublezh_fast);
 685
 686 /* grimy low-level support functions defined in StgPrimFloat.c */
 687
 688 extern StgDouble __encodeDouble (I_ size, StgByteArray arr, I_ e);
 689 extern StgDouble __int_encodeDouble (I_ j, I_ e);
 690 extern StgFloat  __encodeFloat (I_ size, StgByteArray arr, I_ e);
 691 extern StgFloat  __int_encodeFloat (I_ j, I_ e);
 692 extern void      __decodeDouble (MP_INT *man, I_ *_exp, StgDouble dbl);
 693 extern void      __decodeFloat  (MP_INT *man, I_ *_exp, StgFloat flt);
 694 extern StgInt    isDoubleNaN(StgDouble d);
 695 extern StgInt    isDoubleInfinite(StgDouble d);
 696 extern StgInt    isDoubleDenormalized(StgDouble d);
 697 extern StgInt    isDoubleNegativeZero(StgDouble d);
 698 extern StgInt    isFloatNaN(StgFloat f);
 699 extern StgInt    isFloatInfinite(StgFloat f);
 700 extern StgInt    isFloatDenormalized(StgFloat f);
 701 extern StgInt    isFloatNegativeZero(StgFloat f);
 702
 703 /* -----------------------------------------------------------------------------
 704    Mutable variables
 705
 706    newMutVar is out of line.
 707    -------------------------------------------------------------------------- */
 708
 709 EXTFUN_RTS(newMutVarzh_fast);
 710
 711 #define readMutVarzh(r,a)        r=(P_)(((StgMutVar *)(a))->var)
 712 #define writeMutVarzh(a,v)       (P_)(((StgMutVar *)(a))->var)=(v)
 713 #define sameMutVarzh(r,a,b)      r=(I_)((a)==(b))
 714
 715 /* -----------------------------------------------------------------------------
 716    MVar PrimOps.
 717
 718    All out of line, because they either allocate or may block.
 719    -------------------------------------------------------------------------- */
 720 #define sameMVarzh(r,a,b)        r=(I_)((a)==(b))
 721
 722 /* Assume external decl of EMPTY_MVAR_info is in scope by now */
 723 #define isEmptyMVarzh(r,a)       r=(I_)((GET_INFO((StgMVar*)(a))) == &stg_EMPTY_MVAR_info )
 724 EXTFUN_RTS(newMVarzh_fast);
 725 EXTFUN_RTS(takeMVarzh_fast);
 726 EXTFUN_RTS(tryTakeMVarzh_fast);
 727 EXTFUN_RTS(putMVarzh_fast);
 728
 729
 730 /* -----------------------------------------------------------------------------
 731    Delay/Wait PrimOps
 732    -------------------------------------------------------------------------- */
 733
 734 EXTFUN_RTS(waitReadzh_fast);
 735 EXTFUN_RTS(waitWritezh_fast);
 736 EXTFUN_RTS(delayzh_fast);
 737
 738 /* -----------------------------------------------------------------------------
 739    Primitive I/O, error-handling PrimOps
 740    -------------------------------------------------------------------------- */
 741
 742 EXTFUN_RTS(catchzh_fast);
 743 EXTFUN_RTS(raisezh_fast);
 744
 745 extern void stg_exit(I_ n)  __attribute__ ((noreturn));
 746
 747 /* -----------------------------------------------------------------------------
 748    Stable Name / Stable Pointer  PrimOps
 749    -------------------------------------------------------------------------- */
 750
 751 #ifndef PAR
 752
 753 EXTFUN_RTS(makeStableNamezh_fast);
 754
 755 #define stableNameToIntzh(r,s)   (r = ((StgStableName *)s)->sn)
 756
 757 #define eqStableNamezh(r,sn1,sn2)                                       \
 758     (r = (((StgStableName *)sn1)->sn == ((StgStableName *)sn2)->sn))
 759
 760 #define makeStablePtrzh(r,a) \
 761    r = RET_STGCALL1(StgStablePtr,getStablePtr,a)
 762
 763 #define deRefStablePtrzh(r,sp) do {             \
 764   ASSERT(stable_ptr_table[stgCast(StgWord,sp) & ~STABLEPTR_WEIGHT_MASK].weight > 0);    \
 765   r = stable_ptr_table[stgCast(StgWord,sp) & ~STABLEPTR_WEIGHT_MASK].addr; \
 766 } while (0);
 767
 768 #define eqStablePtrzh(r,sp1,sp2) \
 769     (r = ((stgCast(StgWord,sp1) & ~STABLEPTR_WEIGHT_MASK) == (stgCast(StgWord,sp2) & ~STABLEPTR_WEIGHT_MASK)))
 770
 771 #endif
 772
 773 /* -----------------------------------------------------------------------------
 774    Concurrency/Exception PrimOps.
 775    -------------------------------------------------------------------------- */
 776
 777 EXTFUN_RTS(forkzh_fast);
 778 EXTFUN_RTS(yieldzh_fast);
 779 EXTFUN_RTS(killThreadzh_fast);
 780 EXTFUN_RTS(seqzh_fast);
 781 EXTFUN_RTS(blockAsyncExceptionszh_fast);
 782 EXTFUN_RTS(unblockAsyncExceptionszh_fast);
 783
 784 #define myThreadIdzh(t) (t = CurrentTSO)
 785
 786 extern int cmp_thread(const StgTSO *tso1, const StgTSO *tso2);
 787
 788 /* ------------------------------------------------------------------------
 789    Parallel PrimOps
 790
 791    A par in the Haskell code is ultimately translated to a parzh macro
 792    (with a case wrapped around it to guarantee that the macro is actually
 793     executed; see compiler/prelude/PrimOps.lhs)
 794    In GUM and SMP we only add a pointer to the spark pool.
 795    In GranSim we call an RTS fct, forwarding additional parameters which
 796    supply info on granularity of the computation, size of the result value
 797    and the degree of parallelism in the sparked expression.
 798    ---------------------------------------------------------------------- */
 799
 800 #if defined(GRAN)
 801 //@cindex _par_
 802 #define parzh(r,node)             PAR(r,node,1,0,0,0,0,0)
 803
 804 //@cindex _parAt_
 805 #define parAtzh(r,node,where,identifier,gran_info,size_info,par_info,rest) \
 806         parAT(r,node,where,identifier,gran_info,size_info,par_info,rest,1)
 807
 808 //@cindex _parAtAbs_
 809 #define parAtAbszh(r,node,proc,identifier,gran_info,size_info,par_info,rest) \
 810         parAT(r,node,proc,identifier,gran_info,size_info,par_info,rest,2)
 811
 812 //@cindex _parAtRel_
 813 #define parAtRelzh(r,node,proc,identifier,gran_info,size_info,par_info,rest) \
 814         parAT(r,node,proc,identifier,gran_info,size_info,par_info,rest,3)
 815
 816 //@cindex _parAtForNow_
 817 #define parAtForNowzh(r,node,where,identifier,gran_info,size_info,par_info,rest)        \
 818         parAT(r,node,where,identifier,gran_info,size_info,par_info,rest,0)
 819
 820 #define parAT(r,node,where,identifier,gran_info,size_info,par_info,rest,local)  \
 821 {                                                               \
 822   if (closure_SHOULD_SPARK((StgClosure*)node)) {                \
 823     rtsSparkQ result;                                           \
 824     PEs p;                                                      \
 825                                                                 \
 826     STGCALL6(newSpark, node,identifier,gran_info,size_info,par_info,local); \
 827     switch (local) {                                                        \
 828       case 2: p = where;  /* parAtAbs means absolute PE no. expected */     \
 829               break;                                                        \
 830       case 3: p = CurrentProc+where; /* parAtRel means rel PE no. expected */\
 831               break;                                                        \
 832       default: p = where_is(where); /* parAt means closure expected */      \
 833               break;                                                        \
 834     }                                                                       \
 835     /* update GranSim state according to this spark */                      \
 836     STGCALL3(GranSimSparkAtAbs, result, (I_)p, identifier);                 \
 837   }                                                                         \
 838 }
 839
 840 //@cindex _parLocal_
 841 #define parLocalzh(r,node,identifier,gran_info,size_info,par_info,rest) \
 842         PAR(r,node,rest,identifier,gran_info,size_info,par_info,1)
 843
 844 //@cindex _parGlobal_
 845 #define parGlobalzh(r,node,identifier,gran_info,size_info,par_info,rest) \
 846         PAR(r,node,rest,identifier,gran_info,size_info,par_info,0)
 847
 848 #define PAR(r,node,rest,identifier,gran_info,size_info,par_info,local) \
 849 {                                                                        \
 850   if (closure_SHOULD_SPARK((StgClosure*)node)) {                         \
 851     rtsSpark *result;                                                    \
 852     result = RET_STGCALL6(rtsSpark*, newSpark,                           \
 853                           node,identifier,gran_info,size_info,par_info,local);\
 854     STGCALL1(add_to_spark_queue,result);                                \
 855     STGCALL2(GranSimSpark, local,(P_)node);                             \
 856   }                                                                     \
 857 }
 858
 859 #define copyablezh(r,node)                              \
 860   /* copyable not yet implemented!! */
 861
 862 #define noFollowzh(r,node)                              \
 863   /* noFollow not yet implemented!! */
 864
 865 #elif defined(SMP) || defined(PAR)
 866
 867 #define parzh(r,node)                                   \
 868 {                                                       \
 869   extern unsigned int context_switch;                   \
 870   if (closure_SHOULD_SPARK((StgClosure *)node) &&       \
 871       SparkTl < SparkLim) {                             \
 872     *SparkTl++ = (StgClosure *)(node);                  \
 873   }                                                     \
 874   r = context_switch = 1;                               \
 875 }
 876 #else /* !GRAN && !SMP && !PAR */
 877 #define parzh(r,node) r = 1
 878 #endif
 879
 880 /* -----------------------------------------------------------------------------
 881    Pointer equality
 882    -------------------------------------------------------------------------- */
 883
 884 /* warning: extremely non-referentially transparent, need to hide in
 885    an appropriate monad.
 886
 887    ToDo: follow indirections.
 888 */
 889
 890 #define reallyUnsafePtrEqualityzh(r,a,b) r=((StgPtr)(a) == (StgPtr)(b))
 891
 892 /* -----------------------------------------------------------------------------
 893    Weak Pointer PrimOps.
 894    -------------------------------------------------------------------------- */
 895
 896 #ifndef PAR
 897
 898 EXTFUN_RTS(mkWeakzh_fast);
 899 EXTFUN_RTS(finalizzeWeakzh_fast);
 900
 901 #define deRefWeakzh(code,val,w)                         \
 902   if (((StgWeak *)w)->header.info == &stg_WEAK_info) {  \
 903         code = 1;                                       \
 904         val = (P_)((StgWeak *)w)->value;                \
 905   } else {                                              \
 906         code = 0;                                       \
 907         val = (P_)w;                                    \
 908   }
 909
 910 #define sameWeakzh(w1,w2)  ((w1)==(w2))
 911
 912 #endif
 913
 914 /* -----------------------------------------------------------------------------
 915    Foreign Object PrimOps.
 916    -------------------------------------------------------------------------- */
 917
 918 #ifndef PAR
 919
 920 #define ForeignObj_CLOSURE_DATA(c)  (((StgForeignObj *)c)->data)
 921
 922 #define foreignObjToAddrzh(r,fo)    r=ForeignObj_CLOSURE_DATA(fo)
 923 #define touchzh(o)                  /* nothing */
 924
 925 EXTFUN_RTS(mkForeignObjzh_fast);
 926
 927 #define writeForeignObjzh(res,datum) \
 928    (ForeignObj_CLOSURE_DATA(res) = (P_)(datum))
 929
 930 #define eqForeignObj(f1,f2)  ((f1)==(f2))
 931
 932 #define indexCharOffForeignObjzh(r,fo,i)   indexCharOffAddrzh(r,ForeignObj_CLOSURE_DATA(fo),i)
 933 #define indexIntOffForeignObjzh(r,fo,i)    indexIntOffAddrzh(r,ForeignObj_CLOSURE_DATA(fo),i)
 934 #define indexWordOffForeignObjzh(r,fo,i)   indexWordOffAddrzh(r,ForeignObj_CLOSURE_DATA(fo),i)
 935 #define indexAddrOffForeignObjzh(r,fo,i)   indexAddrOffAddrzh(r,ForeignObj_CLOSURE_DATA(fo),i)
 936 #define indexFloatOffForeignObjzh(r,fo,i)  indexFloatOffAddrzh(r,ForeignObj_CLOSURE_DATA(fo),i)
 937 #define indexDoubleOffForeignObjzh(r,fo,i) indexDoubleOffAddrzh(r,ForeignObj_CLOSURE_DATA(fo),i)
 938 #define indexStablePtrOffForeignObjzh(r,fo,i)  indexStablePtrOffAddrzh(r,ForeignObj_CLOSURE_DATA(fo),i)
 939 #ifdef SUPPORT_LONG_LONGS
 940 #define indexInt64OffForeignObjzh(r,fo,i)  indexInt64OffAddrzh(r,ForeignObj_CLOSURE_DATA(fo),i)
 941 #define indexWord64OffForeignObjzh(r,fo,i) indexWord64OffAddrzh(r,ForeignObj_CLOSURE_DATA(fo),i)
 942 #endif
 943
 944 #endif
 945
 946
 947 /* -----------------------------------------------------------------------------
 948    Constructor tags
 949    -------------------------------------------------------------------------- */
 950
 951 #ifdef GHCI
 952 #define dataToTagzh(r,a)                                                \
 953    do { StgClosure* tmp = (StgClosure*)(a);                             \
 954         CHASE_INDIRECTIONS(tmp);                                        \
 955         r = (GET_TAG(((StgClosure *)tmp)->header.info));                \
 956    } while (0)
 957 #else
 958 /* Original version doesn't chase indirections. */
 959 #define dataToTagzh(r,a)  r=(GET_TAG(((StgClosure *)a)->header.info))
 960 #endif
 961
 962 /*  tagToEnum# is handled directly by the code generator. */
 963
 964 /* -----------------------------------------------------------------------------
 965    Signal processing.  Not really primops, but called directly from
 966    Haskell.
 967    -------------------------------------------------------------------------- */
 968
 969 #define STG_SIG_DFL  (-1)
 970 #define STG_SIG_IGN  (-2)
 971 #define STG_SIG_ERR  (-3)
 972 #define STG_SIG_HAN  (-4)
 973
 974 extern StgInt sig_install (StgInt, StgInt, StgStablePtr, sigset_t *);
 975 #define stg_sig_default(sig,mask) sig_install(sig,STG_SIG_DFL,0,(sigset_t *)mask)
 976 #define stg_sig_ignore(sig,mask) sig_install(sig,STG_SIG_IGN,0,(sigset_t *)mask)
 977 #define stg_sig_catch(sig,ptr,mask) sig_install(sig,STG_SIG_HAN,ptr,(sigset_t *)mask)
 978
 979 #endif /* PRIMOPS_H */