ghc/includes/PrimOps.h

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