ghc/includes/PrimOps.h

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