ghc/includes/PrimOps.h

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