ghc/includes/PrimOps.h

   1 /* -----------------------------------------------------------------------------
   2  * $Id: PrimOps.h,v 1.45 2000/01/18 12:37:33 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    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 indexCharOffAddrzh(r,a,i)   r= ((C_ *)(a))[i]
 225 #define indexIntOffAddrzh(r,a,i)    r= ((I_ *)(a))[i]
 226 #define indexAddrOffAddrzh(r,a,i)   r= ((PP_)(a))[i]
 227 #define indexFloatOffAddrzh(r,a,i)  r= PK_FLT((P_) (((StgFloat *)(a)) + i))
 228 #define indexDoubleOffAddrzh(r,a,i) r= PK_DBL((P_) (((StgDouble *)(a)) + i))
 229 #define indexStablePtrOffAddrzh(r,a,i)    r= ((StgStablePtr *)(a))[i]
 230 #ifdef SUPPORT_LONG_LONGS
 231 #define indexInt64OffAddrzh(r,a,i)  r= ((LI_ *)(a))[i]
 232 #define indexWord64OffAddrzh(r,a,i) r= ((LW_ *)(a))[i]
 233 #endif
 234
 235 #define writeCharOffAddrzh(a,i,v)       ((C_ *)(a))[i] = (v)
 236 #define writeIntOffAddrzh(a,i,v)        ((I_ *)(a))[i] = (v)
 237 #define writeWordOffAddrzh(a,i,v)       ((W_ *)(a))[i] = (v)
 238 #define writeAddrOffAddrzh(a,i,v)       ((PP_)(a))[i] = (v)
 239 #define writeForeignObjOffAddrzh(a,i,v) ((PP_)(a))[i] = ForeignObj_CLOSURE_DATA(v)
 240 #define writeFloatOffAddrzh(a,i,v)      ASSIGN_FLT((P_) (((StgFloat *)(a)) + i),v)
 241 #define writeDoubleOffAddrzh(a,i,v)     ASSIGN_DBL((P_) (((StgDouble *)(a)) + i),v)
 242 #define writeStablePtrOffAddrzh(a,i,v)  ((StgStablePtr *)(a))[i] = (v)
 243 #ifdef SUPPORT_LONG_LONGS
 244 #define writeInt64OffAddrzh(a,i,v)   ((LI_ *)(a))[i] = (v)
 245 #define writeWord64OffAddrzh(a,i,v)  ((LW_ *)(a))[i] = (v)
 246 #endif
 247
 248 /* -----------------------------------------------------------------------------
 249    Float PrimOps.
 250    -------------------------------------------------------------------------- */
 251
 252 #define plusFloatzh(r,a,b)   r=(a)+(b)
 253 #define minusFloatzh(r,a,b)  r=(a)-(b)
 254 #define timesFloatzh(r,a,b)  r=(a)*(b)
 255 #define divideFloatzh(r,a,b) r=(a)/(b)
 256 #define negateFloatzh(r,a)   r=-(a)
 257
 258 #define int2Floatzh(r,a)     r=(StgFloat)(a)
 259 #define float2Intzh(r,a)     r=(I_)(a)
 260
 261 #define expFloatzh(r,a)      r=(StgFloat) RET_PRIM_STGCALL1(StgDouble,exp,a)
 262 #define logFloatzh(r,a)      r=(StgFloat) RET_PRIM_STGCALL1(StgDouble,log,a)
 263 #define sqrtFloatzh(r,a)     r=(StgFloat) RET_PRIM_STGCALL1(StgDouble,sqrt,a)
 264 #define sinFloatzh(r,a)      r=(StgFloat) RET_PRIM_STGCALL1(StgDouble,sin,a)
 265 #define cosFloatzh(r,a)      r=(StgFloat) RET_PRIM_STGCALL1(StgDouble,cos,a)
 266 #define tanFloatzh(r,a)      r=(StgFloat) RET_PRIM_STGCALL1(StgDouble,tan,a)
 267 #define asinFloatzh(r,a)     r=(StgFloat) RET_PRIM_STGCALL1(StgDouble,asin,a)
 268 #define acosFloatzh(r,a)     r=(StgFloat) RET_PRIM_STGCALL1(StgDouble,acos,a)
 269 #define atanFloatzh(r,a)     r=(StgFloat) RET_PRIM_STGCALL1(StgDouble,atan,a)
 270 #define sinhFloatzh(r,a)     r=(StgFloat) RET_PRIM_STGCALL1(StgDouble,sinh,a)
 271 #define coshFloatzh(r,a)     r=(StgFloat) RET_PRIM_STGCALL1(StgDouble,cosh,a)
 272 #define tanhFloatzh(r,a)     r=(StgFloat) RET_PRIM_STGCALL1(StgDouble,tanh,a)
 273 #define powerFloatzh(r,a,b)  r=(StgFloat) RET_PRIM_STGCALL2(StgDouble,pow,a,b)
 274
 275 /* -----------------------------------------------------------------------------
 276    Double PrimOps.
 277    -------------------------------------------------------------------------- */
 278
 279 #define zpzhzh(r,a,b)        r=(a)+(b)
 280 #define zmzhzh(r,a,b)        r=(a)-(b)
 281 #define ztzhzh(r,a,b)        r=(a)*(b)
 282 #define zszhzh(r,a,b)        r=(a)/(b)
 283 #define negateDoublezh(r,a)  r=-(a)
 284
 285 #define int2Doublezh(r,a)    r=(StgDouble)(a)
 286 #define double2Intzh(r,a)    r=(I_)(a)
 287
 288 #define float2Doublezh(r,a)  r=(StgDouble)(a)
 289 #define double2Floatzh(r,a)  r=(StgFloat)(a)
 290
 291 #define expDoublezh(r,a)     r=(StgDouble) RET_PRIM_STGCALL1(StgDouble,exp,a)
 292 #define logDoublezh(r,a)     r=(StgDouble) RET_PRIM_STGCALL1(StgDouble,log,a)
 293 #define sqrtDoublezh(r,a)    r=(StgDouble) RET_PRIM_STGCALL1(StgDouble,sqrt,a)
 294 #define sinDoublezh(r,a)     r=(StgDouble) RET_PRIM_STGCALL1(StgDouble,sin,a)
 295 #define cosDoublezh(r,a)     r=(StgDouble) RET_PRIM_STGCALL1(StgDouble,cos,a)
 296 #define tanDoublezh(r,a)     r=(StgDouble) RET_PRIM_STGCALL1(StgDouble,tan,a)
 297 #define asinDoublezh(r,a)    r=(StgDouble) RET_PRIM_STGCALL1(StgDouble,asin,a)
 298 #define acosDoublezh(r,a)    r=(StgDouble) RET_PRIM_STGCALL1(StgDouble,acos,a)
 299 #define atanDoublezh(r,a)    r=(StgDouble) RET_PRIM_STGCALL1(StgDouble,atan,a)
 300 #define sinhDoublezh(r,a)    r=(StgDouble) RET_PRIM_STGCALL1(StgDouble,sinh,a)
 301 #define coshDoublezh(r,a)    r=(StgDouble) RET_PRIM_STGCALL1(StgDouble,cosh,a)
 302 #define tanhDoublezh(r,a)    r=(StgDouble) RET_PRIM_STGCALL1(StgDouble,tanh,a)
 303 /* Power: **## */
 304 #define ztztzhzh(r,a,b) r=(StgDouble) RET_PRIM_STGCALL2(StgDouble,pow,a,b)
 305
 306 /* -----------------------------------------------------------------------------
 307    Integer PrimOps.
 308    -------------------------------------------------------------------------- */
 309
 310 /* We can do integer2Int and cmpInteger inline, since they don't need
 311  * to allocate any memory.
 312  *
 313  * integer2Int# is now modular.
 314  */
 315
 316 #define integer2Intzh(r, sa,da)                         \
 317 { StgWord word0 = ((StgWord *)BYTE_ARR_CTS(da))[0];     \
 318   int size = sa;                                        \
 319                                                         \
 320   (r) =                                                 \
 321     ( size == 0 ) ?                                     \
 322        0 :                                              \
 323        ( size < 0 && word0 != 0x8000000 ) ?             \
 324          -(I_)word0 :                                   \
 325           (I_)word0;                                    \
 326 }
 327
 328 #define integer2Wordzh(r, sa,da)                        \
 329 { StgWord word0 = ((StgWord *)BYTE_ARR_CTS(da))[0];     \
 330   int size = sa;                                        \
 331   (r) = ( size == 0 ) ? 0 : word0 ;                     \
 332 }
 333
 334 #define cmpIntegerzh(r, s1,d1, s2,d2)                           \
 335 { MP_INT arg1;                                                  \
 336   MP_INT arg2;                                                  \
 337                                                                 \
 338   arg1._mp_size = (s1);                                         \
 339   arg1._mp_alloc= ((StgArrWords *)d1)->words;                   \
 340   arg1._mp_d    = (unsigned long int *) (BYTE_ARR_CTS(d1));     \
 341   arg2._mp_size = (s2);                                         \
 342   arg2._mp_alloc= ((StgArrWords *)d2)->words;                   \
 343   arg2._mp_d    = (unsigned long int *) (BYTE_ARR_CTS(d2));     \
 344                                                                 \
 345   (r) = RET_PRIM_STGCALL2(I_,mpz_cmp,&arg1,&arg2);              \
 346 }
 347
 348 #define cmpIntegerIntzh(r, s,d, i)                              \
 349 { MP_INT arg;                                                   \
 350                                                                 \
 351   arg._mp_size  = (s);                                          \
 352   arg._mp_alloc = ((StgArrWords *)d)->words;                    \
 353   arg._mp_d     = (unsigned long int *) (BYTE_ARR_CTS(d));      \
 354                                                                 \
 355   (r) = RET_PRIM_STGCALL2(I_,mpz_cmp_si,&arg,i);                \
 356 }
 357
 358 /* I think mp_limb_t must be the same size as StgInt for this to work
 359  * properly --SDM
 360  */
 361 #define gcdIntzh(r,a,b) \
 362 { StgInt aa = a; \
 363   r = (aa) ? (b) ? \
 364         RET_STGCALL3(StgInt, mpn_gcd_1, (mp_limb_t *)(&aa), 1, (mp_limb_t)(b)) \
 365         : abs(aa) \
 366       : abs(b); \
 367 }
 368
 369 #define gcdIntegerIntzh(r,a,sb,b) \
 370   RET_STGCALL3(StgInt, mpn_gcd_1, (unsigned long int *) b, sb, (mp_limb_t)(a))
 371
 372 /* The rest are all out-of-line: -------- */
 373
 374 /* Integer arithmetic */
 375 EF_(plusIntegerzh_fast);
 376 EF_(minusIntegerzh_fast);
 377 EF_(timesIntegerzh_fast);
 378 EF_(gcdIntegerzh_fast);
 379 EF_(quotRemIntegerzh_fast);
 380 EF_(quotIntegerzh_fast);
 381 EF_(remIntegerzh_fast);
 382 EF_(divExactIntegerzh_fast);
 383 EF_(divModIntegerzh_fast);
 384
 385 /* Conversions */
 386 EF_(int2Integerzh_fast);
 387 EF_(word2Integerzh_fast);
 388 EF_(addr2Integerzh_fast);
 389
 390 /* Floating-point decodings */
 391 EF_(decodeFloatzh_fast);
 392 EF_(decodeDoublezh_fast);
 393
 394 /* -----------------------------------------------------------------------------
 395    Word64 PrimOps.
 396    -------------------------------------------------------------------------- */
 397
 398 #ifdef SUPPORT_LONG_LONGS
 399
 400 #define integerToWord64zh(r, sa,da)                             \
 401 { unsigned long int* d;                                         \
 402   I_ aa;                                                        \
 403   StgWord64 res;                                                \
 404                                                                 \
 405   d             = (unsigned long int *) (BYTE_ARR_CTS(da));     \
 406   aa = ((StgArrWords *)da)->words;                              \
 407   if ( (aa) == 0 ) {                                            \
 408      res = (LW_)0;                                              \
 409   } else if ( (aa) == 1) {                                      \
 410      res = (LW_)d[0];                                           \
 411   } else {                                                      \
 412      res = (LW_)d[0] + (LW_)d[1] * 0x100000000ULL;              \
 413   }                                                             \
 414   (r) = res;                                                    \
 415 }
 416
 417 #define integerToInt64zh(r, sa,da)                              \
 418 { unsigned long int* d;                                         \
 419   I_ aa;                                                        \
 420   StgInt64 res;                                                 \
 421                                                                 \
 422   d             = (unsigned long int *) (BYTE_ARR_CTS(da));     \
 423   aa = ((StgArrWords *)da)->words;                              \
 424   if ( (aa) == 0 ) {                                            \
 425      res = (LI_)0;                                              \
 426   } else if ( (aa) == 1) {                                      \
 427      res = (LI_)d[0];                                           \
 428   } else {                                                      \
 429      res = (LI_)d[0] + (LI_)d[1] * 0x100000000LL;               \
 430      if ( sa < 0 ) {                                            \
 431            res = (LI_)-res;                                     \
 432      }                                                          \
 433   }                                                             \
 434   (r) = res;                                                    \
 435 }
 436
 437 /* Conversions */
 438 EF_(int64ToIntegerzh_fast);
 439 EF_(word64ToIntegerzh_fast);
 440
 441 /* The rest are (way!) out of line, implemented via C entry points.
 442  */
 443 I_ stg_gtWord64 (StgWord64, StgWord64);
 444 I_ stg_geWord64 (StgWord64, StgWord64);
 445 I_ stg_eqWord64 (StgWord64, StgWord64);
 446 I_ stg_neWord64 (StgWord64, StgWord64);
 447 I_ stg_ltWord64 (StgWord64, StgWord64);
 448 I_ stg_leWord64 (StgWord64, StgWord64);
 449
 450 I_ stg_gtInt64 (StgInt64, StgInt64);
 451 I_ stg_geInt64 (StgInt64, StgInt64);
 452 I_ stg_eqInt64 (StgInt64, StgInt64);
 453 I_ stg_neInt64 (StgInt64, StgInt64);
 454 I_ stg_ltInt64 (StgInt64, StgInt64);
 455 I_ stg_leInt64 (StgInt64, StgInt64);
 456
 457 LW_ stg_remWord64  (StgWord64, StgWord64);
 458 LW_ stg_quotWord64 (StgWord64, StgWord64);
 459
 460 LI_ stg_remInt64    (StgInt64, StgInt64);
 461 LI_ stg_quotInt64   (StgInt64, StgInt64);
 462 LI_ stg_negateInt64 (StgInt64);
 463 LI_ stg_plusInt64   (StgInt64, StgInt64);
 464 LI_ stg_minusInt64  (StgInt64, StgInt64);
 465 LI_ stg_timesInt64  (StgInt64, StgInt64);
 466
 467 LW_ stg_and64  (StgWord64, StgWord64);
 468 LW_ stg_or64   (StgWord64, StgWord64);
 469 LW_ stg_xor64  (StgWord64, StgWord64);
 470 LW_ stg_not64  (StgWord64);
 471
 472 LW_ stg_shiftL64   (StgWord64, StgInt);
 473 LW_ stg_shiftRL64  (StgWord64, StgInt);
 474 LI_ stg_iShiftL64  (StgInt64, StgInt);
 475 LI_ stg_iShiftRL64 (StgInt64, StgInt);
 476 LI_ stg_iShiftRA64 (StgInt64, StgInt);
 477
 478 LI_ stg_intToInt64    (StgInt);
 479 I_ stg_int64ToInt     (StgInt64);
 480 LW_ stg_int64ToWord64 (StgInt64);
 481
 482 LW_ stg_wordToWord64  (StgWord);
 483 W_  stg_word64ToWord  (StgWord64);
 484 LI_ stg_word64ToInt64 (StgWord64);
 485 #endif
 486
 487 /* -----------------------------------------------------------------------------
 488    Array PrimOps.
 489    -------------------------------------------------------------------------- */
 490
 491 /* We cast to void* instead of StgChar* because this avoids a warning
 492  * about increasing the alignment requirements.
 493  */
 494 #define REAL_BYTE_ARR_CTS(a)   ((void *) (((StgArrWords *)(a))->payload))
 495 #define REAL_PTRS_ARR_CTS(a)   ((P_)   (((StgMutArrPtrs  *)(a))->payload))
 496
 497 #ifdef DEBUG
 498 #define BYTE_ARR_CTS(a)                           \
 499  ({ ASSERT(GET_INFO((StgArrWords *)(a)) == &ARR_WORDS_info);      \
 500     REAL_BYTE_ARR_CTS(a); })
 501 #define PTRS_ARR_CTS(a)                           \
 502  ({ ASSERT((GET_INFO((StgMutArrPtrs  *)(a)) == &MUT_ARR_PTRS_FROZEN_info)         \
 503         || (GET_INFO((StgMutArrPtrs  *)(a)) == &MUT_ARR_PTRS_info));  \
 504     REAL_PTRS_ARR_CTS(a); })
 505 #else
 506 #define BYTE_ARR_CTS(a)         REAL_BYTE_ARR_CTS(a)
 507 #define PTRS_ARR_CTS(a)         REAL_PTRS_ARR_CTS(a)
 508 #endif
 509
 510 extern I_ genSymZh(void);
 511 extern I_ resetGenSymZh(void);
 512
 513 /*--- everything except new*Array is done inline: */
 514
 515 #define sameMutableArrayzh(r,a,b)       r=(I_)((a)==(b))
 516 #define sameMutableByteArrayzh(r,a,b)   r=(I_)((a)==(b))
 517
 518 #define readArrayzh(r,a,i)       r=((PP_) PTRS_ARR_CTS(a))[(i)]
 519
 520 #define readCharArrayzh(r,a,i)   indexCharOffAddrzh(r,BYTE_ARR_CTS(a),i)
 521 #define readIntArrayzh(r,a,i)    indexIntOffAddrzh(r,BYTE_ARR_CTS(a),i)
 522 #define readWordArrayzh(r,a,i)   indexWordOffAddrzh(r,BYTE_ARR_CTS(a),i)
 523 #define readAddrArrayzh(r,a,i)   indexAddrOffAddrzh(r,BYTE_ARR_CTS(a),i)
 524 #define readFloatArrayzh(r,a,i)  indexFloatOffAddrzh(r,BYTE_ARR_CTS(a),i)
 525 #define readDoubleArrayzh(r,a,i) indexDoubleOffAddrzh(r,BYTE_ARR_CTS(a),i)
 526 #define readStablePtrArrayzh(r,a,i) indexStablePtrOffAddrzh(r,BYTE_ARR_CTS(a),i)
 527 #ifdef SUPPORT_LONG_LONGS
 528 #define readInt64Arrayzh(r,a,i)  indexInt64OffAddrzh(r,BYTE_ARR_CTS(a),i)
 529 #define readWord64Arrayzh(r,a,i) indexWord64OffAddrzh(r,BYTE_ARR_CTS(a),i)
 530 #endif
 531
 532 /* result ("r") arg ignored in write macros! */
 533 #define writeArrayzh(a,i,v)     ((PP_) PTRS_ARR_CTS(a))[(i)]=(v)
 534
 535 #define writeCharArrayzh(a,i,v)   ((C_ *)(BYTE_ARR_CTS(a)))[i] = (v)
 536 #define writeIntArrayzh(a,i,v)    ((I_ *)(BYTE_ARR_CTS(a)))[i] = (v)
 537 #define writeWordArrayzh(a,i,v)   ((W_ *)(BYTE_ARR_CTS(a)))[i] = (v)
 538 #define writeAddrArrayzh(a,i,v)   ((PP_)(BYTE_ARR_CTS(a)))[i] = (v)
 539 #define writeFloatArrayzh(a,i,v)  \
 540         ASSIGN_FLT((P_) (((StgFloat *)(BYTE_ARR_CTS(a))) + i),v)
 541 #define writeDoubleArrayzh(a,i,v) \
 542         ASSIGN_DBL((P_) (((StgDouble *)(BYTE_ARR_CTS(a))) + i),v)
 543 #define writeStablePtrArrayzh(a,i,v)      ((StgStablePtr *)(BYTE_ARR_CTS(a)))[i] = (v)
 544 #ifdef SUPPORT_LONG_LONGS
 545 #define writeInt64Arrayzh(a,i,v)  ((LI_ *)(BYTE_ARR_CTS(a)))[i] = (v)
 546 #define writeWord64Arrayzh(a,i,v) ((LW_ *)(BYTE_ARR_CTS(a)))[i] = (v)
 547 #endif
 548
 549 #define indexArrayzh(r,a,i)       r=((PP_) PTRS_ARR_CTS(a))[(i)]
 550
 551 #define indexCharArrayzh(r,a,i)   indexCharOffAddrzh(r,BYTE_ARR_CTS(a),i)
 552 #define indexIntArrayzh(r,a,i)    indexIntOffAddrzh(r,BYTE_ARR_CTS(a),i)
 553 #define indexWordArrayzh(r,a,i)   indexWordOffAddrzh(r,BYTE_ARR_CTS(a),i)
 554 #define indexAddrArrayzh(r,a,i)   indexAddrOffAddrzh(r,BYTE_ARR_CTS(a),i)
 555 #define indexFloatArrayzh(r,a,i)  indexFloatOffAddrzh(r,BYTE_ARR_CTS(a),i)
 556 #define indexDoubleArrayzh(r,a,i) indexDoubleOffAddrzh(r,BYTE_ARR_CTS(a),i)
 557 #define indexStablePtrArrayzh(r,a,i) indexStablePtrOffAddrzh(r,BYTE_ARR_CTS(a),i)
 558 #ifdef SUPPORT_LONG_LONGS
 559 #define indexInt64Arrayzh(r,a,i)  indexInt64OffAddrzh(r,BYTE_ARR_CTS(a),i)
 560 #define indexWord64Arrayzh(r,a,i) indexWord64OffAddrzh(r,BYTE_ARR_CTS(a),i)
 561 #endif
 562
 563 #define indexCharOffForeignObjzh(r,fo,i)   indexCharOffAddrzh(r,ForeignObj_CLOSURE_DATA(fo),i)
 564 #define indexIntOffForeignObjzh(r,fo,i)    indexIntOffAddrzh(r,ForeignObj_CLOSURE_DATA(fo),i)
 565 #define indexWordOffForeignObjzh(r,fo,i)   indexWordOffAddrzh(r,ForeignObj_CLOSURE_DATA(fo),i)
 566 #define indexAddrOffForeignObjzh(r,fo,i)   indexAddrOffAddrzh(r,ForeignObj_CLOSURE_DATA(fo),i)
 567 #define indexFloatOffForeignObjzh(r,fo,i)  indexFloatOffAddrzh(r,ForeignObj_CLOSURE_DATA(fo),i)
 568 #define indexDoubleOffForeignObjzh(r,fo,i) indexDoubleOffAddrzh(r,ForeignObj_CLOSURE_DATA(fo),i)
 569 #define indexStablePtrOffForeignObjzh(r,fo,i)  indexStablePtrOffAddrzh(r,ForeignObj_CLOSURE_DATA(fo),i)
 570 #ifdef SUPPORT_LONG_LONGS
 571 #define indexInt64OffForeignObjzh(r,fo,i)  indexInt64OffAddrzh(r,ForeignObj_CLOSURE_DATA(fo),i)
 572 #define indexWord64OffForeignObjzh(r,fo,i) indexWord64OffAddrzh(r,ForeignObj_CLOSURE_DATA(fo),i)
 573 #endif
 574
 575 #define indexCharOffAddrzh(r,a,i)   r= ((C_ *)(a))[i]
 576 #define indexIntOffAddrzh(r,a,i)    r= ((I_ *)(a))[i]
 577 #define indexWordOffAddrzh(r,a,i)   r= ((W_ *)(a))[i]
 578 #define indexAddrOffAddrzh(r,a,i)   r= ((PP_)(a))[i]
 579 #define indexFloatOffAddrzh(r,a,i)  r= PK_FLT((P_) (((StgFloat *)(a)) + i))
 580 #define indexDoubleOffAddrzh(r,a,i) r= PK_DBL((P_) (((StgDouble *)(a)) + i))
 581 #ifdef SUPPORT_LONG_LONGS
 582 #define indexInt64OffAddrzh(r,a,i)  r= ((LI_ *)(a))[i]
 583 #define indexWord64OffAddrzh(r,a,i) r= ((LW_ *)(a))[i]
 584 #endif
 585
 586 /* Freezing arrays-of-ptrs requires changing an info table, for the
 587    benefit of the generational collector.  It needs to scavenge mutable
 588    objects, even if they are in old space.  When they become immutable,
 589    they can be removed from this scavenge list.  */
 590
 591 #define unsafeFreezzeArrayzh(r,a)                                       \
 592         {                                                               \
 593         SET_INFO((StgClosure *)a,&MUT_ARR_PTRS_FROZEN_info);            \
 594         r = a;                                                          \
 595         }
 596
 597 #define unsafeFreezzeByteArrayzh(r,a)   r=(a)
 598 #define unsafeThawByteArrayzh(r,a)      r=(a)
 599
 600 EF_(unsafeThawArrayzh_fast);
 601
 602 #define sizzeofByteArrayzh(r,a) \
 603      r = (((StgArrWords *)(a))->words * sizeof(W_))
 604 #define sizzeofMutableByteArrayzh(r,a) \
 605      r = (((StgArrWords *)(a))->words * sizeof(W_))
 606
 607 /* and the out-of-line ones... */
 608
 609 EF_(newCharArrayzh_fast);
 610 EF_(newIntArrayzh_fast);
 611 EF_(newWordArrayzh_fast);
 612 EF_(newAddrArrayzh_fast);
 613 EF_(newFloatArrayzh_fast);
 614 EF_(newDoubleArrayzh_fast);
 615 EF_(newStablePtrArrayzh_fast);
 616 EF_(newArrayzh_fast);
 617
 618 /* encoding and decoding of floats/doubles. */
 619
 620 /* We only support IEEE floating point format */
 621 #include "ieee-flpt.h"
 622
 623 /* The decode operations are out-of-line because they need to allocate
 624  * a byte array.
 625  */
 626 #ifdef FLOATS_AS_DOUBLES
 627 #define decodeFloatzh_fast decodeDoublezh_fast
 628 #else
 629 EF_(decodeFloatzh_fast);
 630 #endif
 631
 632 EF_(decodeDoublezh_fast);
 633
 634 /* grimy low-level support functions defined in StgPrimFloat.c */
 635
 636 extern StgDouble __encodeDouble (I_ size, StgByteArray arr, I_ e);
 637 extern StgDouble __int_encodeDouble (I_ j, I_ e);
 638 #ifndef FLOATS_AS_DOUBLES
 639 extern StgFloat  __encodeFloat (I_ size, StgByteArray arr, I_ e);
 640 extern StgFloat  __int_encodeFloat (I_ j, I_ e);
 641 #endif
 642 extern void      __decodeDouble (MP_INT *man, I_ *_exp, StgDouble dbl);
 643 extern void      __decodeFloat  (MP_INT *man, I_ *_exp, StgFloat flt);
 644 extern StgInt    isDoubleNaN(StgDouble d);
 645 extern StgInt    isDoubleInfinite(StgDouble d);
 646 extern StgInt    isDoubleDenormalized(StgDouble d);
 647 extern StgInt    isDoubleNegativeZero(StgDouble d);
 648 extern StgInt    isFloatNaN(StgFloat f);
 649 extern StgInt    isFloatInfinite(StgFloat f);
 650 extern StgInt    isFloatDenormalized(StgFloat f);
 651 extern StgInt    isFloatNegativeZero(StgFloat f);
 652
 653 /* -----------------------------------------------------------------------------
 654    Mutable variables
 655
 656    newMutVar is out of line.
 657    -------------------------------------------------------------------------- */
 658
 659 EF_(newMutVarzh_fast);
 660
 661 #define readMutVarzh(r,a)        r=(P_)(((StgMutVar *)(a))->var)
 662 #define writeMutVarzh(a,v)       (P_)(((StgMutVar *)(a))->var)=(v)
 663 #define sameMutVarzh(r,a,b)      r=(I_)((a)==(b))
 664
 665 /* -----------------------------------------------------------------------------
 666    MVar PrimOps.
 667
 668    All out of line, because they either allocate or may block.
 669    -------------------------------------------------------------------------- */
 670 #define sameMVarzh(r,a,b)        r=(I_)((a)==(b))
 671
 672 /* Assume external decl of EMPTY_MVAR_info is in scope by now */
 673 #define isEmptyMVarzh(r,a)       r=(I_)((GET_INFO((StgMVar*)(a))) == &EMPTY_MVAR_info )
 674 EF_(newMVarzh_fast);
 675 EF_(takeMVarzh_fast);
 676 EF_(putMVarzh_fast);
 677
 678
 679 /* -----------------------------------------------------------------------------
 680    Delay/Wait PrimOps
 681    -------------------------------------------------------------------------- */
 682
 683 EF_(waitReadzh_fast);
 684 EF_(waitWritezh_fast);
 685 EF_(delayzh_fast);
 686
 687 /* -----------------------------------------------------------------------------
 688    Primitive I/O, error-handling PrimOps
 689    -------------------------------------------------------------------------- */
 690
 691 EF_(catchzh_fast);
 692 EF_(raisezh_fast);
 693
 694 extern void stg_exit(I_ n)  __attribute__ ((noreturn));
 695
 696 /* -----------------------------------------------------------------------------
 697    Stable Name / Stable Pointer  PrimOps
 698    -------------------------------------------------------------------------- */
 699
 700 #ifndef PAR
 701
 702 EF_(makeStableNamezh_fast);
 703
 704 #define stableNameToIntzh(r,s)   (r = ((StgStableName *)s)->sn)
 705
 706 #define eqStableNamezh(r,sn1,sn2)                                       \
 707     (r = (((StgStableName *)sn1)->sn == ((StgStableName *)sn2)->sn))
 708
 709 #define makeStablePtrzh(r,a) \
 710    r = RET_STGCALL1(StgStablePtr,getStablePtr,a)
 711
 712 #define deRefStablePtrzh(r,sp) do {             \
 713   ASSERT(stable_ptr_table[sp & ~STABLEPTR_WEIGHT_MASK].weight > 0);     \
 714   r = stable_ptr_table[sp & ~STABLEPTR_WEIGHT_MASK].addr; \
 715 } while (0);
 716
 717 #define eqStablePtrzh(r,sp1,sp2) \
 718     (r = ((sp1 & ~STABLEPTR_WEIGHT_MASK) == (sp2 & ~STABLEPTR_WEIGHT_MASK)))
 719
 720 #endif
 721
 722 /* -----------------------------------------------------------------------------
 723    Concurrency/Exception PrimOps.
 724    -------------------------------------------------------------------------- */
 725
 726 EF_(forkzh_fast);
 727 EF_(yieldzh_fast);
 728 EF_(killThreadzh_fast);
 729 EF_(seqzh_fast);
 730 EF_(blockAsyncExceptionszh_fast);
 731 EF_(unblockAsyncExceptionszh_fast);
 732
 733 #define myThreadIdzh(t) (t = CurrentTSO)
 734
 735 extern int cmp_thread(const StgTSO *tso1, const StgTSO *tso2);
 736
 737 /* ------------------------------------------------------------------------
 738    Parallel PrimOps
 739
 740    A par in the Haskell code is ultimately translated to a parzh macro
 741    (with a case wrapped around it to guarantee that the macro is actually
 742     executed; see compiler/prelude/PrimOps.lhs)
 743    ---------------------------------------------------------------------- */
 744
 745 #if defined(GRAN)
 746 // hash coding changed from 2.10 to 4.00
 747 #define parzh(r,node)             parZh(r,node)
 748
 749 #define parZh(r,node)                           \
 750         PARZh(r,node,1,0,0,0,0,0)
 751
 752 #define parAtzh(r,node,where,identifier,gran_info,size_info,par_info,rest) \
 753         parATZh(r,node,where,identifier,gran_info,size_info,par_info,rest,1)
 754
 755 #define parAtAbszh(r,node,proc,identifier,gran_info,size_info,par_info,rest) \
 756         parATZh(r,node,proc,identifier,gran_info,size_info,par_info,rest,2)
 757
 758 #define parAtRelzh(r,node,proc,identifier,gran_info,size_info,par_info,rest) \
 759         parATZh(r,node,proc,identifier,gran_info,size_info,par_info,rest,3)
 760
 761 #define parAtForNowzh(r,node,where,identifier,gran_info,size_info,par_info,rest)        \
 762         parATZh(r,node,where,identifier,gran_info,size_info,par_info,rest,0)
 763
 764 #define parATZh(r,node,where,identifier,gran_info,size_info,par_info,rest,local)        \
 765 {                                                       \
 766   rtsSparkQ result;                                             \
 767   if (closure_SHOULD_SPARK((StgClosure*)node)) {                                \
 768     rtsSparkQ result;                                           \
 769     STGCALL6(newSpark, node,identifier,gran_info,size_info,par_info,local);     \
 770     if (local==2) {         /* special case for parAtAbs */   \
 771       STGCALL3(GranSimSparkAtAbs, result,(I_)where,identifier);\
 772     } else if (local==3) {  /* special case for parAtRel */   \
 773       STGCALL3(GranSimSparkAtAbs, result,(I_)(CurrentProc+where),identifier);   \
 774     } else {       \
 775       STGCALL3(GranSimSparkAt, result,where,identifier);        \
 776     }        \
 777   }                                                     \
 778 }
 779
 780 #define parLocalzh(r,node,identifier,gran_info,size_info,par_info,rest) \
 781         PARZh(r,node,rest,identifier,gran_info,size_info,par_info,1)
 782
 783 #define parGlobalzh(r,node,identifier,gran_info,size_info,par_info,rest) \
 784         PARZh(r,node,rest,identifier,gran_info,size_info,par_info,0)
 785
 786 #define PARZh(r,node,rest,identifier,gran_info,size_info,par_info,local) \
 787 {                                                                        \
 788   if (closure_SHOULD_SPARK((StgClosure*)node)) {                         \
 789     rtsSpark *result;                                                    \
 790     result = RET_STGCALL6(rtsSpark*, newSpark,                           \
 791                           node,identifier,gran_info,size_info,par_info,local);\
 792     STGCALL1(add_to_spark_queue,result);                                \
 793     STGCALL2(GranSimSpark, local,(P_)node);                             \
 794   }                                                                     \
 795 }
 796
 797 #define copyablezh(r,node)                              \
 798   /* copyable not yet implemented!! */
 799
 800 #define noFollowzh(r,node)                              \
 801   /* noFollow not yet implemented!! */
 802
 803 #endif  /* GRAN */
 804
 805 #if defined(SMP) || defined(PAR)
 806 #define parzh(r,node)                                   \
 807 {                                                       \
 808   extern unsigned int context_switch;                   \
 809   if (closure_SHOULD_SPARK((StgClosure *)node) &&       \
 810       SparkTl < SparkLim) {                             \
 811     *SparkTl++ = (StgClosure *)(node);                  \
 812   }                                                     \
 813   r = context_switch = 1;                               \
 814 }
 815 #else
 816 #define parzh(r,node) r = 1
 817 #endif
 818
 819 /* -----------------------------------------------------------------------------
 820    Pointer equality
 821    -------------------------------------------------------------------------- */
 822
 823 /* warning: extremely non-referentially transparent, need to hide in
 824    an appropriate monad.
 825
 826    ToDo: follow indirections.
 827 */
 828
 829 #define reallyUnsafePtrEqualityzh(r,a,b) r=((StgPtr)(a) == (StgPtr)(b))
 830
 831 /* -----------------------------------------------------------------------------
 832    Weak Pointer PrimOps.
 833    -------------------------------------------------------------------------- */
 834
 835 #ifndef PAR
 836
 837 EF_(mkWeakzh_fast);
 838 EF_(finalizzeWeakzh_fast);
 839
 840 #define deRefWeakzh(code,val,w)                         \
 841   if (((StgWeak *)w)->header.info == &WEAK_info) {      \
 842         code = 1;                                       \
 843         val = (P_)((StgWeak *)w)->value;                \
 844   } else {                                              \
 845         code = 0;                                       \
 846         val = (P_)w;                                    \
 847   }
 848
 849 #define sameWeakzh(w1,w2)  ((w1)==(w2))
 850
 851 #endif
 852
 853 /* -----------------------------------------------------------------------------
 854    Foreign Object PrimOps.
 855    -------------------------------------------------------------------------- */
 856
 857 #ifndef PAR
 858
 859 #define ForeignObj_CLOSURE_DATA(c)  (((StgForeignObj *)c)->data)
 860
 861 EF_(makeForeignObjzh_fast);
 862
 863 #define writeForeignObjzh(res,datum) \
 864    (ForeignObj_CLOSURE_DATA(res) = (P_)(datum))
 865
 866 #define eqForeignObj(f1,f2)  ((f1)==(f2))
 867
 868 #endif
 869
 870 /* -----------------------------------------------------------------------------
 871    Constructor tags
 872    -------------------------------------------------------------------------- */
 873
 874 #define dataToTagzh(r,a)  r=(GET_TAG(((StgClosure *)a)->header.info))
 875 /*  tagToEnum# is handled directly by the code generator. */
 876
 877 /* -----------------------------------------------------------------------------
 878    Signal processing.  Not really primops, but called directly from
 879    Haskell.
 880    -------------------------------------------------------------------------- */
 881
 882 #define STG_SIG_DFL  (-1)
 883 #define STG_SIG_IGN  (-2)
 884 #define STG_SIG_ERR  (-3)
 885 #define STG_SIG_HAN  (-4)
 886
 887 extern StgInt sig_install (StgInt, StgInt, StgStablePtr, sigset_t *);
 888 #define stg_sig_default(sig,mask) sig_install(sig,STG_SIG_DFL,0,(sigset_t *)mask)
 889 #define stg_sig_ignore(sig,mask) sig_install(sig,STG_SIG_IGN,0,(sigset_t *)mask)
 890 #define stg_sig_catch(sig,ptr,mask) sig_install(sig,STG_SIG_HAN,ptr,(sigset_t *)mask)
 891
 892 #endif PRIMOPS_H