ghc/includes/PrimOps.h

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