ghc/includes/PrimOps.h

   1 /* -----------------------------------------------------------------------------
   2  * $Id: PrimOps.h,v 1.40 1999/12/01 14:34:48 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 /* The rest are all out-of-line: -------- */
 359
 360 /* Integer arithmetic */
 361 EF_(plusIntegerzh_fast);
 362 EF_(minusIntegerzh_fast);
 363 EF_(timesIntegerzh_fast);
 364 EF_(gcdIntegerzh_fast);
 365 EF_(quotRemIntegerzh_fast);
 366 EF_(divModIntegerzh_fast);
 367
 368 /* Conversions */
 369 EF_(int2Integerzh_fast);
 370 EF_(word2Integerzh_fast);
 371 EF_(addr2Integerzh_fast);
 372
 373 /* Floating-point decodings */
 374 EF_(decodeFloatzh_fast);
 375 EF_(decodeDoublezh_fast);
 376
 377 /* -----------------------------------------------------------------------------
 378    Word64 PrimOps.
 379    -------------------------------------------------------------------------- */
 380
 381 #ifdef SUPPORT_LONG_LONGS
 382
 383 #define integerToWord64zh(r, sa,da)                             \
 384 { unsigned long int* d;                                         \
 385   I_ aa;                                                        \
 386   StgWord64 res;                                                \
 387                                                                 \
 388   d             = (unsigned long int *) (BYTE_ARR_CTS(da));     \
 389   aa = ((StgArrWords *)da)->words;                              \
 390   if ( (aa) == 0 ) {                                            \
 391      res = (LW_)0;                                              \
 392   } else if ( (aa) == 1) {                                      \
 393      res = (LW_)d[0];                                           \
 394   } else {                                                      \
 395      res = (LW_)d[0] + (LW_)d[1] * 0x100000000ULL;              \
 396   }                                                             \
 397   (r) = res;                                                    \
 398 }
 399
 400 #define integerToInt64zh(r, sa,da)                              \
 401 { unsigned long int* d;                                         \
 402   I_ aa;                                                        \
 403   StgInt64 res;                                                 \
 404                                                                 \
 405   d             = (unsigned long int *) (BYTE_ARR_CTS(da));     \
 406   aa = ((StgArrWords *)da)->words;                              \
 407   if ( (aa) == 0 ) {                                            \
 408      res = (LI_)0;                                              \
 409   } else if ( (aa) == 1) {                                      \
 410      res = (LI_)d[0];                                           \
 411   } else {                                                      \
 412      res = (LI_)d[0] + (LI_)d[1] * 0x100000000LL;               \
 413      if ( sa < 0 ) {                                            \
 414            res = (LI_)-res;                                     \
 415      }                                                          \
 416   }                                                             \
 417   (r) = res;                                                    \
 418 }
 419
 420 /* Conversions */
 421 EF_(int64ToIntegerzh_fast);
 422 EF_(word64ToIntegerzh_fast);
 423
 424 /* The rest are (way!) out of line, implemented via C entry points.
 425  */
 426 I_ stg_gtWord64 (StgWord64, StgWord64);
 427 I_ stg_geWord64 (StgWord64, StgWord64);
 428 I_ stg_eqWord64 (StgWord64, StgWord64);
 429 I_ stg_neWord64 (StgWord64, StgWord64);
 430 I_ stg_ltWord64 (StgWord64, StgWord64);
 431 I_ stg_leWord64 (StgWord64, StgWord64);
 432
 433 I_ stg_gtInt64 (StgInt64, StgInt64);
 434 I_ stg_geInt64 (StgInt64, StgInt64);
 435 I_ stg_eqInt64 (StgInt64, StgInt64);
 436 I_ stg_neInt64 (StgInt64, StgInt64);
 437 I_ stg_ltInt64 (StgInt64, StgInt64);
 438 I_ stg_leInt64 (StgInt64, StgInt64);
 439
 440 LW_ stg_remWord64  (StgWord64, StgWord64);
 441 LW_ stg_quotWord64 (StgWord64, StgWord64);
 442
 443 LI_ stg_remInt64    (StgInt64, StgInt64);
 444 LI_ stg_quotInt64   (StgInt64, StgInt64);
 445 LI_ stg_negateInt64 (StgInt64);
 446 LI_ stg_plusInt64   (StgInt64, StgInt64);
 447 LI_ stg_minusInt64  (StgInt64, StgInt64);
 448 LI_ stg_timesInt64  (StgInt64, StgInt64);
 449
 450 LW_ stg_and64  (StgWord64, StgWord64);
 451 LW_ stg_or64   (StgWord64, StgWord64);
 452 LW_ stg_xor64  (StgWord64, StgWord64);
 453 LW_ stg_not64  (StgWord64);
 454
 455 LW_ stg_shiftL64   (StgWord64, StgInt);
 456 LW_ stg_shiftRL64  (StgWord64, StgInt);
 457 LI_ stg_iShiftL64  (StgInt64, StgInt);
 458 LI_ stg_iShiftRL64 (StgInt64, StgInt);
 459 LI_ stg_iShiftRA64 (StgInt64, StgInt);
 460
 461 LI_ stg_intToInt64    (StgInt);
 462 I_ stg_int64ToInt     (StgInt64);
 463 LW_ stg_int64ToWord64 (StgInt64);
 464
 465 LW_ stg_wordToWord64  (StgWord);
 466 W_  stg_word64ToWord  (StgWord64);
 467 LI_ stg_word64ToInt64 (StgWord64);
 468 #endif
 469
 470 /* -----------------------------------------------------------------------------
 471    Array PrimOps.
 472    -------------------------------------------------------------------------- */
 473
 474 /* We cast to void* instead of StgChar* because this avoids a warning
 475  * about increasing the alignment requirements.
 476  */
 477 #define REAL_BYTE_ARR_CTS(a)   ((void *) (((StgArrWords *)(a))->payload))
 478 #define REAL_PTRS_ARR_CTS(a)   ((P_)   (((StgMutArrPtrs  *)(a))->payload))
 479
 480 #ifdef DEBUG
 481 #define BYTE_ARR_CTS(a)                           \
 482  ({ ASSERT(GET_INFO((StgArrWords *)(a)) == &ARR_WORDS_info);      \
 483     REAL_BYTE_ARR_CTS(a); })
 484 #define PTRS_ARR_CTS(a)                           \
 485  ({ ASSERT((GET_INFO((StgMutArrPtrs  *)(a)) == &MUT_ARR_PTRS_FROZEN_info)         \
 486         || (GET_INFO((StgMutArrPtrs  *)(a)) == &MUT_ARR_PTRS_info));  \
 487     REAL_PTRS_ARR_CTS(a); })
 488 #else
 489 #define BYTE_ARR_CTS(a)         REAL_BYTE_ARR_CTS(a)
 490 #define PTRS_ARR_CTS(a)         REAL_PTRS_ARR_CTS(a)
 491 #endif
 492
 493 extern I_ genSymZh(void);
 494 extern I_ resetGenSymZh(void);
 495
 496 /*--- everything except new*Array is done inline: */
 497
 498 #define sameMutableArrayzh(r,a,b)       r=(I_)((a)==(b))
 499 #define sameMutableByteArrayzh(r,a,b)   r=(I_)((a)==(b))
 500
 501 #define readArrayzh(r,a,i)       r=((PP_) PTRS_ARR_CTS(a))[(i)]
 502
 503 #define readCharArrayzh(r,a,i)   indexCharOffAddrzh(r,BYTE_ARR_CTS(a),i)
 504 #define readIntArrayzh(r,a,i)    indexIntOffAddrzh(r,BYTE_ARR_CTS(a),i)
 505 #define readWordArrayzh(r,a,i)   indexWordOffAddrzh(r,BYTE_ARR_CTS(a),i)
 506 #define readAddrArrayzh(r,a,i)   indexAddrOffAddrzh(r,BYTE_ARR_CTS(a),i)
 507 #define readFloatArrayzh(r,a,i)  indexFloatOffAddrzh(r,BYTE_ARR_CTS(a),i)
 508 #define readDoubleArrayzh(r,a,i) indexDoubleOffAddrzh(r,BYTE_ARR_CTS(a),i)
 509 #define readStablePtrArrayzh(r,a,i) indexStablePtrOffAddrzh(r,BYTE_ARR_CTS(a),i)
 510 #ifdef SUPPORT_LONG_LONGS
 511 #define readInt64Arrayzh(r,a,i)  indexInt64OffAddrzh(r,BYTE_ARR_CTS(a),i)
 512 #define readWord64Arrayzh(r,a,i) indexWord64OffAddrzh(r,BYTE_ARR_CTS(a),i)
 513 #endif
 514
 515 /* result ("r") arg ignored in write macros! */
 516 #define writeArrayzh(a,i,v)     ((PP_) PTRS_ARR_CTS(a))[(i)]=(v)
 517
 518 #define writeCharArrayzh(a,i,v)   ((C_ *)(BYTE_ARR_CTS(a)))[i] = (v)
 519 #define writeIntArrayzh(a,i,v)    ((I_ *)(BYTE_ARR_CTS(a)))[i] = (v)
 520 #define writeWordArrayzh(a,i,v)   ((W_ *)(BYTE_ARR_CTS(a)))[i] = (v)
 521 #define writeAddrArrayzh(a,i,v)   ((PP_)(BYTE_ARR_CTS(a)))[i] = (v)
 522 #define writeFloatArrayzh(a,i,v)  \
 523         ASSIGN_FLT((P_) (((StgFloat *)(BYTE_ARR_CTS(a))) + i),v)
 524 #define writeDoubleArrayzh(a,i,v) \
 525         ASSIGN_DBL((P_) (((StgDouble *)(BYTE_ARR_CTS(a))) + i),v)
 526 #define writeStablePtrArrayzh(a,i,v)      ((StgStablePtr *)(BYTE_ARR_CTS(a)))[i] = (v)
 527 #ifdef SUPPORT_LONG_LONGS
 528 #define writeInt64Arrayzh(a,i,v)  ((LI_ *)(BYTE_ARR_CTS(a)))[i] = (v)
 529 #define writeWord64Arrayzh(a,i,v) ((LW_ *)(BYTE_ARR_CTS(a)))[i] = (v)
 530 #endif
 531
 532 #define indexArrayzh(r,a,i)       r=((PP_) PTRS_ARR_CTS(a))[(i)]
 533
 534 #define indexCharArrayzh(r,a,i)   indexCharOffAddrzh(r,BYTE_ARR_CTS(a),i)
 535 #define indexIntArrayzh(r,a,i)    indexIntOffAddrzh(r,BYTE_ARR_CTS(a),i)
 536 #define indexWordArrayzh(r,a,i)   indexWordOffAddrzh(r,BYTE_ARR_CTS(a),i)
 537 #define indexAddrArrayzh(r,a,i)   indexAddrOffAddrzh(r,BYTE_ARR_CTS(a),i)
 538 #define indexFloatArrayzh(r,a,i)  indexFloatOffAddrzh(r,BYTE_ARR_CTS(a),i)
 539 #define indexDoubleArrayzh(r,a,i) indexDoubleOffAddrzh(r,BYTE_ARR_CTS(a),i)
 540 #define indexStablePtrArrayzh(r,a,i) indexStablePtrOffAddrzh(r,BYTE_ARR_CTS(a),i)
 541 #ifdef SUPPORT_LONG_LONGS
 542 #define indexInt64Arrayzh(r,a,i)  indexInt64OffAddrzh(r,BYTE_ARR_CTS(a),i)
 543 #define indexWord64Arrayzh(r,a,i) indexWord64OffAddrzh(r,BYTE_ARR_CTS(a),i)
 544 #endif
 545
 546 #define indexCharOffForeignObjzh(r,fo,i)   indexCharOffAddrzh(r,ForeignObj_CLOSURE_DATA(fo),i)
 547 #define indexIntOffForeignObjzh(r,fo,i)    indexIntOffAddrzh(r,ForeignObj_CLOSURE_DATA(fo),i)
 548 #define indexWordOffForeignObjzh(r,fo,i)   indexWordOffAddrzh(r,ForeignObj_CLOSURE_DATA(fo),i)
 549 #define indexAddrOffForeignObjzh(r,fo,i)   indexAddrOffAddrzh(r,ForeignObj_CLOSURE_DATA(fo),i)
 550 #define indexFloatOffForeignObjzh(r,fo,i)  indexFloatOffAddrzh(r,ForeignObj_CLOSURE_DATA(fo),i)
 551 #define indexDoubleOffForeignObjzh(r,fo,i) indexDoubleOffAddrzh(r,ForeignObj_CLOSURE_DATA(fo),i)
 552 #define indexStablePtrOffForeignObjzh(r,fo,i)  indexStablePtrOffAddrzh(r,ForeignObj_CLOSURE_DATA(fo),i)
 553 #ifdef SUPPORT_LONG_LONGS
 554 #define indexInt64OffForeignObjzh(r,fo,i)  indexInt64OffAddrzh(r,ForeignObj_CLOSURE_DATA(fo),i)
 555 #define indexWord64OffForeignObjzh(r,fo,i) indexWord64OffAddrzh(r,ForeignObj_CLOSURE_DATA(fo),i)
 556 #endif
 557
 558 #define indexCharOffAddrzh(r,a,i)   r= ((C_ *)(a))[i]
 559 #define indexIntOffAddrzh(r,a,i)    r= ((I_ *)(a))[i]
 560 #define indexWordOffAddrzh(r,a,i)   r= ((W_ *)(a))[i]
 561 #define indexAddrOffAddrzh(r,a,i)   r= ((PP_)(a))[i]
 562 #define indexFloatOffAddrzh(r,a,i)  r= PK_FLT((P_) (((StgFloat *)(a)) + i))
 563 #define indexDoubleOffAddrzh(r,a,i) r= PK_DBL((P_) (((StgDouble *)(a)) + i))
 564 #ifdef SUPPORT_LONG_LONGS
 565 #define indexInt64OffAddrzh(r,a,i)  r= ((LI_ *)(a))[i]
 566 #define indexWord64OffAddrzh(r,a,i) r= ((LW_ *)(a))[i]
 567 #endif
 568
 569 /* Freezing arrays-of-ptrs requires changing an info table, for the
 570    benefit of the generational collector.  It needs to scavenge mutable
 571    objects, even if they are in old space.  When they become immutable,
 572    they can be removed from this scavenge list.  */
 573
 574 #define unsafeFreezzeArrayzh(r,a)                                       \
 575         {                                                               \
 576         SET_INFO((StgClosure *)a,&MUT_ARR_PTRS_FROZEN_info);            \
 577         r = a;                                                          \
 578         }
 579
 580 #define unsafeFreezzeByteArrayzh(r,a)   r=(a)
 581 #define unsafeThawByteArrayzh(r,a)      r=(a)
 582
 583 EF_(unsafeThawArrayzh_fast);
 584
 585 #define sizzeofByteArrayzh(r,a) \
 586      r = (((StgArrWords *)(a))->words * sizeof(W_))
 587 #define sizzeofMutableByteArrayzh(r,a) \
 588      r = (((StgArrWords *)(a))->words * sizeof(W_))
 589
 590 /* and the out-of-line ones... */
 591
 592 EF_(newCharArrayzh_fast);
 593 EF_(newIntArrayzh_fast);
 594 EF_(newWordArrayzh_fast);
 595 EF_(newAddrArrayzh_fast);
 596 EF_(newFloatArrayzh_fast);
 597 EF_(newDoubleArrayzh_fast);
 598 EF_(newStablePtrArrayzh_fast);
 599 EF_(newArrayzh_fast);
 600
 601 /* encoding and decoding of floats/doubles. */
 602
 603 /* We only support IEEE floating point format */
 604 #include "ieee-flpt.h"
 605
 606 /* The decode operations are out-of-line because they need to allocate
 607  * a byte array.
 608  */
 609 #ifdef FLOATS_AS_DOUBLES
 610 #define decodeFloatzh_fast decodeDoublezh_fast
 611 #else
 612 EF_(decodeFloatzh_fast);
 613 #endif
 614
 615 EF_(decodeDoublezh_fast);
 616
 617 /* grimy low-level support functions defined in StgPrimFloat.c */
 618
 619 extern StgDouble __encodeDouble (I_ size, StgByteArray arr, I_ e);
 620 extern StgDouble __int_encodeDouble (I_ j, I_ e);
 621 #ifndef FLOATS_AS_DOUBLES
 622 extern StgFloat  __encodeFloat (I_ size, StgByteArray arr, I_ e);
 623 extern StgFloat  __int_encodeFloat (I_ j, I_ e);
 624 #endif
 625 extern void      __decodeDouble (MP_INT *man, I_ *_exp, StgDouble dbl);
 626 extern void      __decodeFloat  (MP_INT *man, I_ *_exp, StgFloat flt);
 627 extern StgInt    isDoubleNaN(StgDouble d);
 628 extern StgInt    isDoubleInfinite(StgDouble d);
 629 extern StgInt    isDoubleDenormalized(StgDouble d);
 630 extern StgInt    isDoubleNegativeZero(StgDouble d);
 631 extern StgInt    isFloatNaN(StgFloat f);
 632 extern StgInt    isFloatInfinite(StgFloat f);
 633 extern StgInt    isFloatDenormalized(StgFloat f);
 634 extern StgInt    isFloatNegativeZero(StgFloat f);
 635
 636 /* -----------------------------------------------------------------------------
 637    Mutable variables
 638
 639    newMutVar is out of line.
 640    -------------------------------------------------------------------------- */
 641
 642 EF_(newMutVarzh_fast);
 643
 644 #define readMutVarzh(r,a)        r=(P_)(((StgMutVar *)(a))->var)
 645 #define writeMutVarzh(a,v)       (P_)(((StgMutVar *)(a))->var)=(v)
 646 #define sameMutVarzh(r,a,b)      r=(I_)((a)==(b))
 647
 648 /* -----------------------------------------------------------------------------
 649    MVar PrimOps.
 650
 651    All out of line, because they either allocate or may block.
 652    -------------------------------------------------------------------------- */
 653 #define sameMVarzh(r,a,b)        r=(I_)((a)==(b))
 654
 655 /* Assume external decl of EMPTY_MVAR_info is in scope by now */
 656 #define isEmptyMVarzh(r,a)       r=(I_)((GET_INFO((StgMVar*)(a))) == &EMPTY_MVAR_info )
 657 EF_(newMVarzh_fast);
 658 EF_(takeMVarzh_fast);
 659 EF_(putMVarzh_fast);
 660
 661
 662 /* -----------------------------------------------------------------------------
 663    Delay/Wait PrimOps
 664    -------------------------------------------------------------------------- */
 665
 666 EF_(waitReadzh_fast);
 667 EF_(waitWritezh_fast);
 668 EF_(delayzh_fast);
 669
 670 /* -----------------------------------------------------------------------------
 671    Primitive I/O, error-handling PrimOps
 672    -------------------------------------------------------------------------- */
 673
 674 EF_(catchzh_fast);
 675 EF_(raisezh_fast);
 676
 677 extern void stg_exit(I_ n)  __attribute__ ((noreturn));
 678
 679 /* -----------------------------------------------------------------------------
 680    Stable Name / Stable Pointer  PrimOps
 681    -------------------------------------------------------------------------- */
 682
 683 #ifndef PAR
 684
 685 EF_(makeStableNamezh_fast);
 686
 687 #define stableNameToIntzh(r,s)   (r = ((StgStableName *)s)->sn)
 688
 689 #define eqStableNamezh(r,sn1,sn2)                                       \
 690     (r = (((StgStableName *)sn1)->sn == ((StgStableName *)sn2)->sn))
 691
 692 #define makeStablePtrzh(r,a) \
 693    r = RET_STGCALL1(StgStablePtr,getStablePtr,a)
 694
 695 #define deRefStablePtrzh(r,sp) do {             \
 696   ASSERT(stable_ptr_table[sp & ~STABLEPTR_WEIGHT_MASK].weight > 0);     \
 697   r = stable_ptr_table[sp & ~STABLEPTR_WEIGHT_MASK].addr; \
 698 } while (0);
 699
 700 #define eqStablePtrzh(r,sp1,sp2) \
 701     (r = ((sp1 & ~STABLEPTR_WEIGHT_MASK) == (sp2 & ~STABLEPTR_WEIGHT_MASK)))
 702
 703 #endif
 704
 705 /* -----------------------------------------------------------------------------
 706    Concurrency/Exception PrimOps.
 707    -------------------------------------------------------------------------- */
 708
 709 EF_(forkzh_fast);
 710 EF_(yieldzh_fast);
 711 EF_(killThreadzh_fast);
 712 EF_(seqzh_fast);
 713 EF_(blockAsyncExceptionszh_fast);
 714 EF_(unblockAsyncExceptionszh_fast);
 715
 716 #define myThreadIdzh(t) (t = CurrentTSO)
 717
 718 extern int cmp_thread(const StgTSO *tso1, const StgTSO *tso2);
 719
 720 /* Hmm, I'll think about these later. */
 721 /* -----------------------------------------------------------------------------
 722    Pointer equality
 723    -------------------------------------------------------------------------- */
 724
 725 /* warning: extremely non-referentially transparent, need to hide in
 726    an appropriate monad.
 727
 728    ToDo: follow indirections.
 729 */
 730
 731 #define reallyUnsafePtrEqualityzh(r,a,b) r=((StgPtr)(a) == (StgPtr)(b))
 732
 733 /* -----------------------------------------------------------------------------
 734    Weak Pointer PrimOps.
 735    -------------------------------------------------------------------------- */
 736
 737 #ifndef PAR
 738
 739 EF_(mkWeakzh_fast);
 740 EF_(finalizzeWeakzh_fast);
 741
 742 #define deRefWeakzh(code,val,w)                         \
 743   if (((StgWeak *)w)->header.info == &WEAK_info) {      \
 744         code = 1;                                       \
 745         val = (P_)((StgWeak *)w)->value;                \
 746   } else {                                              \
 747         code = 0;                                       \
 748         val = (P_)w;                                    \
 749   }
 750
 751 #define sameWeakzh(w1,w2)  ((w1)==(w2))
 752
 753 #endif
 754
 755 /* -----------------------------------------------------------------------------
 756    Foreign Object PrimOps.
 757    -------------------------------------------------------------------------- */
 758
 759 #ifndef PAR
 760
 761 #define ForeignObj_CLOSURE_DATA(c)  (((StgForeignObj *)c)->data)
 762
 763 EF_(makeForeignObjzh_fast);
 764
 765 #define writeForeignObjzh(res,datum) \
 766    (ForeignObj_CLOSURE_DATA(res) = (P_)(datum))
 767
 768 #define eqForeignObj(f1,f2)  ((f1)==(f2))
 769
 770 #endif
 771
 772 /* -----------------------------------------------------------------------------
 773    Constructor tags
 774    -------------------------------------------------------------------------- */
 775
 776 #define dataToTagzh(r,a)  r=(GET_TAG(((StgClosure *)a)->header.info))
 777 /*  tagToEnum# is handled directly by the code generator. */
 778
 779 /* -----------------------------------------------------------------------------
 780    Signal processing.  Not really primops, but called directly from
 781    Haskell.
 782    -------------------------------------------------------------------------- */
 783
 784 #define STG_SIG_DFL  (-1)
 785 #define STG_SIG_IGN  (-2)
 786 #define STG_SIG_ERR  (-3)
 787 #define STG_SIG_HAN  (-4)
 788
 789 extern StgInt sig_install (StgInt, StgInt, StgStablePtr, sigset_t *);
 790 #define stg_sig_default(sig,mask) sig_install(sig,STG_SIG_DFL,0,(sigset_t *)mask)
 791 #define stg_sig_ignore(sig,mask) sig_install(sig,STG_SIG_IGN,0,(sigset_t *)mask)
 792 #define stg_sig_catch(sig,ptr,mask) sig_install(sig,STG_SIG_HAN,ptr,(sigset_t *)mask)
 793
 794 #endif PRIMOPS_H