ghc/includes/PrimOps.h

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