ghc/includes/PrimOps.h

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