ghc/includes/PrimOps.h

   1 /* -----------------------------------------------------------------------------
   2  * $Id: PrimOps.h,v 1.80 2001/08/08 10:50:37 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 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 = (I_)a + (I_)b;                            \
 103   c = ((StgWord)(~((I_)a^(I_)b) & ((I_)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  (1LL << (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(newPinnedByteArrayzh_fast);
 668 EXTFUN_RTS(newArrayzh_fast);
 669
 670 // Highly unsafe, for use with a pinned ByteArray
 671 // being kept alive with touch#
 672 #define byteArrayContentszh(r,a) r = BYTE_ARR_CTS(a)
 673
 674 /* encoding and decoding of floats/doubles. */
 675
 676 /* We only support IEEE floating point format */
 677 #include "ieee-flpt.h"
 678
 679 /* The decode operations are out-of-line because they need to allocate
 680  * a byte array.
 681  */
 682 EXTFUN_RTS(decodeFloatzh_fast);
 683 EXTFUN_RTS(decodeDoublezh_fast);
 684
 685 /* grimy low-level support functions defined in StgPrimFloat.c */
 686
 687 extern StgDouble __encodeDouble (I_ size, StgByteArray arr, I_ e);
 688 extern StgDouble __int_encodeDouble (I_ j, I_ e);
 689 extern StgFloat  __encodeFloat (I_ size, StgByteArray arr, I_ e);
 690 extern StgFloat  __int_encodeFloat (I_ j, I_ e);
 691 extern void      __decodeDouble (MP_INT *man, I_ *_exp, StgDouble dbl);
 692 extern void      __decodeFloat  (MP_INT *man, I_ *_exp, StgFloat flt);
 693 extern StgInt    isDoubleNaN(StgDouble d);
 694 extern StgInt    isDoubleInfinite(StgDouble d);
 695 extern StgInt    isDoubleDenormalized(StgDouble d);
 696 extern StgInt    isDoubleNegativeZero(StgDouble d);
 697 extern StgInt    isFloatNaN(StgFloat f);
 698 extern StgInt    isFloatInfinite(StgFloat f);
 699 extern StgInt    isFloatDenormalized(StgFloat f);
 700 extern StgInt    isFloatNegativeZero(StgFloat f);
 701
 702 /* -----------------------------------------------------------------------------
 703    Mutable variables
 704
 705    newMutVar is out of line.
 706    -------------------------------------------------------------------------- */
 707
 708 EXTFUN_RTS(newMutVarzh_fast);
 709
 710 #define readMutVarzh(r,a)        r=(P_)(((StgMutVar *)(a))->var)
 711 #define writeMutVarzh(a,v)       (P_)(((StgMutVar *)(a))->var)=(v)
 712 #define sameMutVarzh(r,a,b)      r=(I_)((a)==(b))
 713
 714 /* -----------------------------------------------------------------------------
 715    MVar PrimOps.
 716
 717    All out of line, because they either allocate or may block.
 718    -------------------------------------------------------------------------- */
 719 #define sameMVarzh(r,a,b)        r=(I_)((a)==(b))
 720
 721 /* Assume external decl of EMPTY_MVAR_info is in scope by now */
 722 #define isEmptyMVarzh(r,a)       r=(I_)((GET_INFO((StgMVar*)(a))) == &stg_EMPTY_MVAR_info )
 723 EXTFUN_RTS(newMVarzh_fast);
 724 EXTFUN_RTS(takeMVarzh_fast);
 725 EXTFUN_RTS(putMVarzh_fast);
 726 EXTFUN_RTS(tryTakeMVarzh_fast);
 727 EXTFUN_RTS(tryPutMVarzh_fast);
 728
 729 /* -----------------------------------------------------------------------------
 730    Delay/Wait PrimOps
 731    -------------------------------------------------------------------------- */
 732
 733 EXTFUN_RTS(waitReadzh_fast);
 734 EXTFUN_RTS(waitWritezh_fast);
 735 EXTFUN_RTS(delayzh_fast);
 736
 737 /* -----------------------------------------------------------------------------
 738    Primitive I/O, error-handling PrimOps
 739    -------------------------------------------------------------------------- */
 740
 741 EXTFUN_RTS(catchzh_fast);
 742 EXTFUN_RTS(raisezh_fast);
 743
 744 extern void stg_exit(I_ n)  __attribute__ ((noreturn));
 745
 746 /* -----------------------------------------------------------------------------
 747    Stable Name / Stable Pointer  PrimOps
 748    -------------------------------------------------------------------------- */
 749
 750 EXTFUN_RTS(makeStableNamezh_fast);
 751
 752 #define stableNameToIntzh(r,s)   (r = ((StgStableName *)s)->sn)
 753
 754 #define eqStableNamezh(r,sn1,sn2)                                       \
 755     (r = (((StgStableName *)sn1)->sn == ((StgStableName *)sn2)->sn))
 756
 757 #define makeStablePtrzh(r,a) \
 758    r = RET_STGCALL1(StgStablePtr,getStablePtr,a)
 759
 760 #define deRefStablePtrzh(r,sp) do {             \
 761   ASSERT(stable_ptr_table[stgCast(StgWord,sp) & ~STABLEPTR_WEIGHT_MASK].weight > 0);    \
 762   r = stable_ptr_table[stgCast(StgWord,sp) & ~STABLEPTR_WEIGHT_MASK].addr; \
 763 } while (0);
 764
 765 #define eqStablePtrzh(r,sp1,sp2) \
 766     (r = ((stgCast(StgWord,sp1) & ~STABLEPTR_WEIGHT_MASK) == (stgCast(StgWord,sp2) & ~STABLEPTR_WEIGHT_MASK)))
 767
 768 /* -----------------------------------------------------------------------------
 769    Concurrency/Exception PrimOps.
 770    -------------------------------------------------------------------------- */
 771
 772 EXTFUN_RTS(forkzh_fast);
 773 EXTFUN_RTS(yieldzh_fast);
 774 EXTFUN_RTS(killThreadzh_fast);
 775 EXTFUN_RTS(seqzh_fast);
 776 EXTFUN_RTS(blockAsyncExceptionszh_fast);
 777 EXTFUN_RTS(unblockAsyncExceptionszh_fast);
 778
 779 #define myThreadIdzh(t) (t = CurrentTSO)
 780
 781 extern int cmp_thread(const StgTSO *tso1, const StgTSO *tso2);
 782
 783 /* ------------------------------------------------------------------------
 784    Parallel PrimOps
 785
 786    A par in the Haskell code is ultimately translated to a parzh macro
 787    (with a case wrapped around it to guarantee that the macro is actually
 788     executed; see compiler/prelude/PrimOps.lhs)
 789    In GUM and SMP we only add a pointer to the spark pool.
 790    In GranSim we call an RTS fct, forwarding additional parameters which
 791    supply info on granularity of the computation, size of the result value
 792    and the degree of parallelism in the sparked expression.
 793    ---------------------------------------------------------------------- */
 794
 795 #if defined(GRAN)
 796 //@cindex _par_
 797 #define parzh(r,node)             parAny(r,node,1,0,0,0,0,0)
 798
 799 //@cindex _parAt_
 800 #define parAtzh(r,node,where,identifier,gran_info,size_info,par_info,rest) \
 801         parAT(r,node,where,identifier,gran_info,size_info,par_info,rest,1)
 802
 803 //@cindex _parAtAbs_
 804 #define parAtAbszh(r,node,proc,identifier,gran_info,size_info,par_info,rest) \
 805         parAT(r,node,proc,identifier,gran_info,size_info,par_info,rest,2)
 806
 807 //@cindex _parAtRel_
 808 #define parAtRelzh(r,node,proc,identifier,gran_info,size_info,par_info,rest) \
 809         parAT(r,node,proc,identifier,gran_info,size_info,par_info,rest,3)
 810
 811 //@cindex _parAtForNow_
 812 #define parAtForNowzh(r,node,where,identifier,gran_info,size_info,par_info,rest)        \
 813         parAT(r,node,where,identifier,gran_info,size_info,par_info,rest,0)
 814
 815 #define parAT(r,node,where,identifier,gran_info,size_info,par_info,rest,local)  \
 816 {                                                               \
 817   if (closure_SHOULD_SPARK((StgClosure*)node)) {                \
 818     rtsSparkQ result;                                           \
 819     PEs p;                                                      \
 820                                                                 \
 821     STGCALL6(newSpark, node,identifier,gran_info,size_info,par_info,local); \
 822     switch (local) {                                                        \
 823       case 2: p = where;  /* parAtAbs means absolute PE no. expected */     \
 824               break;                                                        \
 825       case 3: p = CurrentProc+where; /* parAtRel means rel PE no. expected */\
 826               break;                                                        \
 827       default: p = where_is(where); /* parAt means closure expected */      \
 828               break;                                                        \
 829     }                                                                       \
 830     /* update GranSim state according to this spark */                      \
 831     STGCALL3(GranSimSparkAtAbs, result, (I_)p, identifier);                 \
 832   }                                                                         \
 833 }
 834
 835 //@cindex _parLocal_
 836 #define parLocalzh(r,node,identifier,gran_info,size_info,par_info,rest) \
 837         parAny(r,node,rest,identifier,gran_info,size_info,par_info,1)
 838
 839 //@cindex _parGlobal_
 840 #define parGlobalzh(r,node,identifier,gran_info,size_info,par_info,rest) \
 841         parAny(r,node,rest,identifier,gran_info,size_info,par_info,0)
 842
 843 #define parAny(r,node,rest,identifier,gran_info,size_info,par_info,local) \
 844 {                                                                        \
 845   if (closure_SHOULD_SPARK((StgClosure*)node)) {                         \
 846     rtsSpark *result;                                                    \
 847     result = RET_STGCALL6(rtsSpark*, newSpark,                           \
 848                           node,identifier,gran_info,size_info,par_info,local);\
 849     STGCALL1(add_to_spark_queue,result);                                \
 850     STGCALL2(GranSimSpark, local,(P_)node);                             \
 851   }                                                                     \
 852 }
 853
 854 #define copyablezh(r,node)                              \
 855   /* copyable not yet implemented!! */
 856
 857 #define noFollowzh(r,node)                              \
 858   /* noFollow not yet implemented!! */
 859
 860 #elif defined(SMP) || defined(PAR)
 861
 862 #define parzh(r,node)                                   \
 863 {                                                       \
 864   extern unsigned int context_switch;                   \
 865   if (closure_SHOULD_SPARK((StgClosure *)node) &&       \
 866       SparkTl < SparkLim) {                             \
 867     *SparkTl++ = (StgClosure *)(node);                  \
 868   }                                                     \
 869   r = context_switch = 1;                               \
 870 }
 871 #else /* !GRAN && !SMP && !PAR */
 872 #define parzh(r,node) r = 1
 873 #endif
 874
 875 /* -----------------------------------------------------------------------------
 876    Pointer equality
 877    -------------------------------------------------------------------------- */
 878
 879 /* warning: extremely non-referentially transparent, need to hide in
 880    an appropriate monad.
 881
 882    ToDo: follow indirections.
 883 */
 884
 885 #define reallyUnsafePtrEqualityzh(r,a,b) r=((StgPtr)(a) == (StgPtr)(b))
 886
 887 /* -----------------------------------------------------------------------------
 888    Weak Pointer PrimOps.
 889    -------------------------------------------------------------------------- */
 890
 891 EXTFUN_RTS(mkWeakzh_fast);
 892 EXTFUN_RTS(finalizzeWeakzh_fast);
 893
 894 #define deRefWeakzh(code,val,w)                         \
 895   if (((StgWeak *)w)->header.info == &stg_WEAK_info) {  \
 896         code = 1;                                       \
 897         val = (P_)((StgWeak *)w)->value;                \
 898   } else {                                              \
 899         code = 0;                                       \
 900         val = (P_)w;                                    \
 901   }
 902
 903 #define sameWeakzh(w1,w2)  ((w1)==(w2))
 904
 905
 906 /* -----------------------------------------------------------------------------
 907    Foreign Object PrimOps.
 908    -------------------------------------------------------------------------- */
 909
 910 #define ForeignObj_CLOSURE_DATA(c)  (((StgForeignObj *)c)->data)
 911
 912 #define foreignObjToAddrzh(r,fo)    r=ForeignObj_CLOSURE_DATA(fo)
 913 #define touchzh(o)                  /* nothing */
 914
 915 EXTFUN_RTS(mkForeignObjzh_fast);
 916
 917 #define writeForeignObjzh(res,datum) \
 918    (ForeignObj_CLOSURE_DATA(res) = (P_)(datum))
 919
 920 #define eqForeignObjzh(r,f1,f2)                 r=(f1)==(f2)
 921 #define indexCharOffForeignObjzh(r,fo,i)        indexCharOffAddrzh(r,ForeignObj_CLOSURE_DATA(fo),i)
 922 #define indexWideCharOffForeignObjzh(r,fo,i)    indexWideCharOffAddrzh(r,ForeignObj_CLOSURE_DATA(fo),i)
 923 #define indexIntOffForeignObjzh(r,fo,i)         indexIntOffAddrzh(r,ForeignObj_CLOSURE_DATA(fo),i)
 924 #define indexWordOffForeignObjzh(r,fo,i)        indexWordOffAddrzh(r,ForeignObj_CLOSURE_DATA(fo),i)
 925 #define indexAddrOffForeignObjzh(r,fo,i)        indexAddrOffAddrzh(r,ForeignObj_CLOSURE_DATA(fo),i)
 926 #define indexFloatOffForeignObjzh(r,fo,i)       indexFloatOffAddrzh(r,ForeignObj_CLOSURE_DATA(fo),i)
 927 #define indexDoubleOffForeignObjzh(r,fo,i)      indexDoubleOffAddrzh(r,ForeignObj_CLOSURE_DATA(fo),i)
 928 #define indexStablePtrOffForeignObjzh(r,fo,i)   indexStablePtrOffAddrzh(r,ForeignObj_CLOSURE_DATA(fo),i)
 929 #define indexInt8OffForeignObjzh(r,fo,i)        indexInt8OffAddrzh(r,ForeignObj_CLOSURE_DATA(fo),i)
 930 #define indexInt16OffForeignObjzh(r,fo,i)       indexInt16OffAddrzh(r,ForeignObj_CLOSURE_DATA(fo),i)
 931 #define indexInt32OffForeignObjzh(r,fo,i)       indexInt32OffAddrzh(r,ForeignObj_CLOSURE_DATA(fo),i)
 932 #define indexWord8OffForeignObjzh(r,fo,i)       indexWord8OffAddrzh(r,ForeignObj_CLOSURE_DATA(fo),i)
 933 #define indexWord16OffForeignObjzh(r,fo,i)      indexWord16OffAddrzh(r,ForeignObj_CLOSURE_DATA(fo),i)
 934 #define indexWord32OffForeignObjzh(r,fo,i)      indexWord32OffAddrzh(r,ForeignObj_CLOSURE_DATA(fo),i)
 935 #ifdef SUPPORT_LONG_LONGS
 936 #define indexInt64OffForeignObjzh(r,fo,i)       indexInt64OffAddrzh(r,ForeignObj_CLOSURE_DATA(fo),i)
 937 #define indexWord64OffForeignObjzh(r,fo,i)      indexWord64OffAddrzh(r,ForeignObj_CLOSURE_DATA(fo),i)
 938 #endif
 939
 940 /* -----------------------------------------------------------------------------
 941    Constructor tags
 942    -------------------------------------------------------------------------- */
 943
 944 #define dataToTagzh(r,a)  r=(GET_TAG(((StgClosure *)a)->header.info))
 945
 946 /*  tagToEnum# is handled directly by the code generator. */
 947
 948 /* -----------------------------------------------------------------------------
 949    BCOs and BCO linkery
 950    -------------------------------------------------------------------------- */
 951
 952 EXTFUN_RTS(newBCOzh_fast);
 953 EXTFUN_RTS(mkApUpd0zh_fast);
 954
 955 /* -----------------------------------------------------------------------------
 956    Signal processing.  Not really primops, but called directly from
 957    Haskell.
 958    -------------------------------------------------------------------------- */
 959
 960 #define STG_SIG_DFL  (-1)
 961 #define STG_SIG_IGN  (-2)
 962 #define STG_SIG_ERR  (-3)
 963 #define STG_SIG_HAN  (-4)
 964
 965 extern StgInt stg_sig_install (StgInt, StgInt, StgStablePtr, sigset_t *);
 966 #define stg_sig_default(sig,mask) stg_sig_install(sig,STG_SIG_DFL,0,(sigset_t *)mask)
 967 #define stg_sig_ignore(sig,mask) stg_sig_install(sig,STG_SIG_IGN,0,(sigset_t *)mask)
 968 #define stg_sig_catch(sig,ptr,mask) stg_sig_install(sig,STG_SIG_HAN,ptr,(sigset_t *)mask)
 969
 970 #endif /* PRIMOPS_H */