ghc/includes/PrimOps.h

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