ghc/includes/PrimOps.h

   1 /* -----------------------------------------------------------------------------
   2  * $Id: PrimOps.h,v 1.24 1999/03/16 13:20:09 simonm 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 /*  used by returning comparison primops, defined in Prims.hc. */
  62 extern DLL_IMPORT_RTS const StgClosure *PrelBase_Bool_closure_tbl[];
  63
  64 /* -----------------------------------------------------------------------------
  65    Char# PrimOps.
  66    -------------------------------------------------------------------------- */
  67
  68 #define ordzh(r,a)      r=(I_)((W_) (a))
  69 #define chrzh(r,a)      r=(StgChar)((W_)(a))
  70
  71 /* -----------------------------------------------------------------------------
  72    Int# PrimOps.
  73    -------------------------------------------------------------------------- */
  74
  75 I_ stg_div (I_ a, I_ b);
  76
  77 #define zpzh(r,a,b)             r=(a)+(b)
  78 #define zmzh(r,a,b)             r=(a)-(b)
  79 #define ztzh(r,a,b)             r=(a)*(b)
  80 #define quotIntzh(r,a,b)        r=(a)/(b)
  81 #define zszh(r,a,b)             r=ULTRASAFESTGCALL2(I_,(void *, I_, I_),stg_div,(a),(b))
  82 #define remIntzh(r,a,b)         r=(a)%(b)
  83 #define negateIntzh(r,a)        r=-(a)
  84
  85 /* -----------------------------------------------------------------------------
  86  * Int operations with carry.
  87  * -------------------------------------------------------------------------- */
  88
  89 /* With some bit-twiddling, we can define int{Add,Sub}Czh portably in
  90  * C, and without needing any comparisons.  This may not be the
  91  * fastest way to do it - if you have better code, please send it! --SDM
  92  *
  93  * Return : r = a + b,  c = 0 if no overflow, 1 on overflow.
  94  *
  95  * We currently don't make use of the r value if c is != 0 (i.e.
  96  * overflow), we just convert to big integers and try again.  This
  97  * could be improved by making r and c the correct values for
  98  * plugging into a new J#.
  99  */
 100 #define addIntCzh(r,c,a,b)                      \
 101 { r = a + b;                                    \
 102   c = ((StgWord)(~(a^b) & (a^r)))               \
 103     >> (BITS_PER_BYTE * sizeof(I_) - 1);        \
 104 }
 105
 106
 107 #define subIntCzh(r,c,a,b)                      \
 108 { r = a - b;                                    \
 109   c = ((StgWord)((a^b) & (a^r)))                \
 110     >> (BITS_PER_BYTE * sizeof(I_) - 1);        \
 111 }
 112
 113 /* Multiply with overflow checking.
 114  *
 115  * This is slightly more tricky - the usual sign rules for add/subtract
 116  * don't apply.
 117  *
 118  * On x86 hardware we use a hand-crafted assembly fragment to do the job.
 119  *
 120  * On other 32-bit machines we use gcc's 'long long' types, finding
 121  * overflow with some careful bit-twiddling.
 122  *
 123  * On 64-bit machines where gcc's 'long long' type is also 64-bits,
 124  * we use a crude approximation, testing whether either operand is
 125  * larger than 32-bits; if neither is, then we go ahead with the
 126  * multiplication.
 127  */
 128
 129 #if i386_TARGET_ARCH
 130
 131 #define mulIntCzh(r,c,a,b)                              \
 132 {                                                       \
 133   __asm__("xor %1,%1\n\t                                \
 134            imull %2,%3\n\t                              \
 135            jno 1f\n\t                                   \
 136            movl $1,%1\n\t                               \
 137            1:"                                          \
 138         : "=r" (r), "=r" (c) : "r" (a), "0" (b));       \
 139 }
 140
 141 #elif SIZEOF_VOID_P == 4
 142
 143 #ifdef WORDS_BIGENDIAN
 144 #define C 0
 145 #define R 1
 146 #else
 147 #define C 1
 148 #define R 0
 149 #endif
 150
 151 typedef union {
 152     StgInt64 l;
 153     StgInt32 i[2];
 154 } long_long_u ;
 155
 156 #define mulIntCzh(r,c,a,b)                      \
 157 {                                               \
 158   long_long_u z;                                \
 159   z.l = (StgInt64)a * (StgInt64)b;              \
 160   r = z.i[R];                                   \
 161   c = z.i[C];                                   \
 162   if (c == 0 || c == -1) {                      \
 163     c = ((StgWord)((a^b) ^ r))                  \
 164       >> (BITS_PER_BYTE * sizeof(I_) - 1);      \
 165   }                                             \
 166 }
 167 /* Careful: the carry calculation above is extremely delicate.  Make sure
 168  * you test it thoroughly after changing it.
 169  */
 170
 171 #else
 172
 173 #define HALF_INT  (1 << (BITS_PER_BYTE * sizeof(I_) / 2))
 174
 175 #define stg_abs(a) ((a) < 0 ? -(a) : (a))
 176
 177 #define mulIntCzh(r,c,a,b)                      \
 178 {                                               \
 179   if (stg_abs(a) >= HALF_INT                    \
 180       stg_abs(b) >= HALF_INT) {                 \
 181     c = 1;                                      \
 182   } else {                                      \
 183     r = a * b;                                  \
 184     c = 0;                                      \
 185   }                                             \
 186 }
 187 #endif
 188
 189 /* -----------------------------------------------------------------------------
 190    Word PrimOps.
 191    -------------------------------------------------------------------------- */
 192
 193 #define quotWordzh(r,a,b)       r=((W_)a)/((W_)b)
 194 #define remWordzh(r,a,b)        r=((W_)a)%((W_)b)
 195
 196 #define andzh(r,a,b)            r=(a)&(b)
 197 #define orzh(r,a,b)             r=(a)|(b)
 198 #define xorzh(r,a,b)            r=(a)^(b)
 199 #define notzh(r,a)              r=~(a)
 200
 201 #define shiftLzh(r,a,b)         r=(a)<<(b)
 202 #define shiftRLzh(r,a,b)        r=(a)>>(b)
 203 #define iShiftLzh(r,a,b)        r=(a)<<(b)
 204 /* Right shifting of signed quantities is not portable in C, so
 205    the behaviour you'll get from using these primops depends
 206    on the whatever your C compiler is doing. ToDo: fix/document. -- sof 8/98
 207 */
 208 #define iShiftRAzh(r,a,b)       r=(a)>>(b)
 209 #define iShiftRLzh(r,a,b)       r=(a)>>(b)
 210
 211 #define int2Wordzh(r,a)         r=(W_)(a)
 212 #define word2Intzh(r,a)         r=(I_)(a)
 213
 214 /* -----------------------------------------------------------------------------
 215    Addr PrimOps.
 216    -------------------------------------------------------------------------- */
 217
 218 #define int2Addrzh(r,a)         r=(A_)(a)
 219 #define addr2Intzh(r,a)         r=(I_)(a)
 220
 221 #define indexCharOffAddrzh(r,a,i)   r= ((C_ *)(a))[i]
 222 #define indexIntOffAddrzh(r,a,i)    r= ((I_ *)(a))[i]
 223 #define indexAddrOffAddrzh(r,a,i)   r= ((PP_)(a))[i]
 224 #define indexFloatOffAddrzh(r,a,i)  r= PK_FLT((P_) (((StgFloat *)(a)) + i))
 225 #define indexDoubleOffAddrzh(r,a,i) r= PK_DBL((P_) (((StgDouble *)(a)) + i))
 226 #define indexStablePtrOffAddrzh(r,a,i)    r= ((StgStablePtr *)(a))[i]
 227 #ifdef SUPPORT_LONG_LONGS
 228 #define indexInt64OffAddrzh(r,a,i)  r= ((LI_ *)(a))[i]
 229 #define indexWord64OffAddrzh(r,a,i) r= ((LW_ *)(a))[i]
 230 #endif
 231
 232 #define writeCharOffAddrzh(a,i,v)       ((C_ *)(a))[i] = (v)
 233 #define writeIntOffAddrzh(a,i,v)        ((I_ *)(a))[i] = (v)
 234 #define writeWordOffAddrzh(a,i,v)       ((W_ *)(a))[i] = (v)
 235 #define writeAddrOffAddrzh(a,i,v)       ((PP_)(a))[i] = (v)
 236 #define writeForeignObjOffAddrzh(a,i,v) ((PP_)(a))[i] = ForeignObj_CLOSURE_DATA(v)
 237 #define writeFloatOffAddrzh(a,i,v)      ASSIGN_FLT((P_) (((StgFloat *)(a)) + i),v)
 238 #define writeDoubleOffAddrzh(a,i,v)     ASSIGN_DBL((P_) (((StgDouble *)(a)) + i),v)
 239 #define writeStablePtrOffAddrzh(a,i,v)  ((StgStablePtr *)(a))[i] = (v)
 240 #ifdef SUPPORT_LONG_LONGS
 241 #define writeInt64OffAddrzh(a,i,v)   ((LI_ *)(a))[i] = (v)
 242 #define writeWord64OffAddrzh(a,i,v)  ((LW_ *)(a))[i] = (v)
 243 #endif
 244
 245 /* -----------------------------------------------------------------------------
 246    Float PrimOps.
 247    -------------------------------------------------------------------------- */
 248
 249 #define plusFloatzh(r,a,b)   r=(a)+(b)
 250 #define minusFloatzh(r,a,b)  r=(a)-(b)
 251 #define timesFloatzh(r,a,b)  r=(a)*(b)
 252 #define divideFloatzh(r,a,b) r=(a)/(b)
 253 #define negateFloatzh(r,a)   r=-(a)
 254
 255 #define int2Floatzh(r,a)     r=(StgFloat)(a)
 256 #define float2Intzh(r,a)     r=(I_)(a)
 257
 258 #define expFloatzh(r,a)      r=(StgFloat) RET_PRIM_STGCALL1(StgDouble,exp,a)
 259 #define logFloatzh(r,a)      r=(StgFloat) RET_PRIM_STGCALL1(StgDouble,log,a)
 260 #define sqrtFloatzh(r,a)     r=(StgFloat) RET_PRIM_STGCALL1(StgDouble,sqrt,a)
 261 #define sinFloatzh(r,a)      r=(StgFloat) RET_PRIM_STGCALL1(StgDouble,sin,a)
 262 #define cosFloatzh(r,a)      r=(StgFloat) RET_PRIM_STGCALL1(StgDouble,cos,a)
 263 #define tanFloatzh(r,a)      r=(StgFloat) RET_PRIM_STGCALL1(StgDouble,tan,a)
 264 #define asinFloatzh(r,a)     r=(StgFloat) RET_PRIM_STGCALL1(StgDouble,asin,a)
 265 #define acosFloatzh(r,a)     r=(StgFloat) RET_PRIM_STGCALL1(StgDouble,acos,a)
 266 #define atanFloatzh(r,a)     r=(StgFloat) RET_PRIM_STGCALL1(StgDouble,atan,a)
 267 #define sinhFloatzh(r,a)     r=(StgFloat) RET_PRIM_STGCALL1(StgDouble,sinh,a)
 268 #define coshFloatzh(r,a)     r=(StgFloat) RET_PRIM_STGCALL1(StgDouble,cosh,a)
 269 #define tanhFloatzh(r,a)     r=(StgFloat) RET_PRIM_STGCALL1(StgDouble,tanh,a)
 270 #define powerFloatzh(r,a,b)  r=(StgFloat) RET_PRIM_STGCALL2(StgDouble,pow,a,b)
 271
 272 /* -----------------------------------------------------------------------------
 273    Double PrimOps.
 274    -------------------------------------------------------------------------- */
 275
 276 #define zpzhzh(r,a,b)        r=(a)+(b)
 277 #define zmzhzh(r,a,b)        r=(a)-(b)
 278 #define ztzhzh(r,a,b)        r=(a)*(b)
 279 #define zszhzh(r,a,b)        r=(a)/(b)
 280 #define negateDoublezh(r,a)  r=-(a)
 281
 282 #define int2Doublezh(r,a)    r=(StgDouble)(a)
 283 #define double2Intzh(r,a)    r=(I_)(a)
 284
 285 #define float2Doublezh(r,a)  r=(StgDouble)(a)
 286 #define double2Floatzh(r,a)  r=(StgFloat)(a)
 287
 288 #define expDoublezh(r,a)     r=(StgDouble) RET_PRIM_STGCALL1(StgDouble,exp,a)
 289 #define logDoublezh(r,a)     r=(StgDouble) RET_PRIM_STGCALL1(StgDouble,log,a)
 290 #define sqrtDoublezh(r,a)    r=(StgDouble) RET_PRIM_STGCALL1(StgDouble,sqrt,a)
 291 #define sinDoublezh(r,a)     r=(StgDouble) RET_PRIM_STGCALL1(StgDouble,sin,a)
 292 #define cosDoublezh(r,a)     r=(StgDouble) RET_PRIM_STGCALL1(StgDouble,cos,a)
 293 #define tanDoublezh(r,a)     r=(StgDouble) RET_PRIM_STGCALL1(StgDouble,tan,a)
 294 #define asinDoublezh(r,a)    r=(StgDouble) RET_PRIM_STGCALL1(StgDouble,asin,a)
 295 #define acosDoublezh(r,a)    r=(StgDouble) RET_PRIM_STGCALL1(StgDouble,acos,a)
 296 #define atanDoublezh(r,a)    r=(StgDouble) RET_PRIM_STGCALL1(StgDouble,atan,a)
 297 #define sinhDoublezh(r,a)    r=(StgDouble) RET_PRIM_STGCALL1(StgDouble,sinh,a)
 298 #define coshDoublezh(r,a)    r=(StgDouble) RET_PRIM_STGCALL1(StgDouble,cosh,a)
 299 #define tanhDoublezh(r,a)    r=(StgDouble) RET_PRIM_STGCALL1(StgDouble,tanh,a)
 300 /* Power: **## */
 301 #define ztztzhzh(r,a,b) r=(StgDouble) RET_PRIM_STGCALL2(StgDouble,pow,a,b)
 302
 303 /* -----------------------------------------------------------------------------
 304    Integer PrimOps.
 305    -------------------------------------------------------------------------- */
 306
 307 /* We can do integer2Int and cmpInteger inline, since they don't need
 308  * to allocate any memory.
 309  */
 310
 311 #define integer2Intzh(r, sa,da)                                 \
 312 { MP_INT arg;                                                   \
 313                                                                 \
 314   arg._mp_size  = (sa);                                         \
 315   arg._mp_alloc = ((StgArrWords *)da)->words;                   \
 316   arg._mp_d     = (unsigned long int *) (BYTE_ARR_CTS(da));     \
 317                                                                 \
 318   (r) = RET_PRIM_STGCALL1(I_,mpz_get_si,&arg);                  \
 319 }
 320
 321 #define integer2Wordzh(r, sa,da)                                \
 322 { MP_INT arg;                                                   \
 323                                                                 \
 324   arg._mp_size  = (sa);                                         \
 325   arg._mp_alloc = ((StgArrWords *)da)->words;                   \
 326   arg._mp_d     = (unsigned long int *) (BYTE_ARR_CTS(da));     \
 327                                                                 \
 328   (r) = RET_PRIM_STGCALL1(I_,mpz_get_ui,&arg);                  \
 329 }
 330
 331 #define cmpIntegerzh(r, s1,d1, s2,d2)                           \
 332 { MP_INT arg1;                                                  \
 333   MP_INT arg2;                                                  \
 334                                                                 \
 335   arg1._mp_size = (s1);                                         \
 336   arg1._mp_alloc= ((StgArrWords *)d1)->words;                   \
 337   arg1._mp_d    = (unsigned long int *) (BYTE_ARR_CTS(d1));     \
 338   arg2._mp_size = (s2);                                         \
 339   arg2._mp_alloc= ((StgArrWords *)d2)->words;                   \
 340   arg2._mp_d    = (unsigned long int *) (BYTE_ARR_CTS(d2));     \
 341                                                                 \
 342   (r) = RET_PRIM_STGCALL2(I_,mpz_cmp,&arg1,&arg2);              \
 343 }
 344
 345 #define cmpIntegerIntzh(r, s,d, i)                              \
 346 { MP_INT arg;                                                   \
 347                                                                 \
 348   arg._mp_size  = (s);                                          \
 349   arg._mp_alloc = ((StgArrWords *)d)->words;                    \
 350   arg._mp_d     = (unsigned long int *) (BYTE_ARR_CTS(d));      \
 351                                                                 \
 352   (r) = RET_PRIM_STGCALL2(I_,mpz_cmp_si,&arg,i);                \
 353 }
 354
 355 /* The rest are all out-of-line: -------- */
 356
 357 /* Integer arithmetic */
 358 EF_(plusIntegerzh_fast);
 359 EF_(minusIntegerzh_fast);
 360 EF_(timesIntegerzh_fast);
 361 EF_(gcdIntegerzh_fast);
 362 EF_(quotRemIntegerzh_fast);
 363 EF_(divModIntegerzh_fast);
 364
 365 /* Conversions */
 366 EF_(int2Integerzh_fast);
 367 EF_(word2Integerzh_fast);
 368 EF_(addr2Integerzh_fast);
 369
 370 /* Floating-point decodings */
 371 EF_(decodeFloatzh_fast);
 372 EF_(decodeDoublezh_fast);
 373
 374 /* -----------------------------------------------------------------------------
 375    Word64 PrimOps.
 376    -------------------------------------------------------------------------- */
 377
 378 #ifdef SUPPORT_LONG_LONGS
 379
 380 #define integerToWord64zh(r, sa,da)                             \
 381 { unsigned long int* d;                                         \
 382   I_ aa;                                                        \
 383   StgWord64 res;                                                \
 384                                                                 \
 385   d             = (unsigned long int *) (BYTE_ARR_CTS(da));     \
 386   aa = ((StgArrWords *)da)->words;                              \
 387   if ( (aa) == 0 ) {                                            \
 388      res = (LW_)0;                                              \
 389   } else if ( (aa) == 1) {                                      \
 390      res = (LW_)d[0];                                           \
 391   } else {                                                      \
 392      res = (LW_)d[0] + (LW_)d[1] * 0x100000000ULL;              \
 393   }                                                             \
 394   (r) = res;                                                    \
 395 }
 396
 397 #define integerToInt64zh(r, sa,da)                              \
 398 { unsigned long int* d;                                         \
 399   I_ aa;                                                        \
 400   StgInt64 res;                                                 \
 401                                                                 \
 402   d             = (unsigned long int *) (BYTE_ARR_CTS(da));     \
 403   aa = ((StgArrWords *)da)->words;                              \
 404   if ( (aa) == 0 ) {                                            \
 405      res = (LI_)0;                                              \
 406   } else if ( (aa) == 1) {                                      \
 407      res = (LI_)d[0];                                           \
 408   } else {                                                      \
 409      res = (LI_)d[0] + (LI_)d[1] * 0x100000000LL;               \
 410      if ( sa < 0 ) {                                            \
 411            res = (LI_)-res;                                     \
 412      }                                                          \
 413   }                                                             \
 414   (r) = res;                                                    \
 415 }
 416
 417 /* Conversions */
 418 EF_(int64ToIntegerzh_fast);
 419 EF_(word64ToIntegerzh_fast);
 420
 421 /* The rest are (way!) out of line, implemented via C entry points.
 422  */
 423 I_ stg_gtWord64 (StgWord64, StgWord64);
 424 I_ stg_geWord64 (StgWord64, StgWord64);
 425 I_ stg_eqWord64 (StgWord64, StgWord64);
 426 I_ stg_neWord64 (StgWord64, StgWord64);
 427 I_ stg_ltWord64 (StgWord64, StgWord64);
 428 I_ stg_leWord64 (StgWord64, StgWord64);
 429
 430 I_ stg_gtInt64 (StgInt64, StgInt64);
 431 I_ stg_geInt64 (StgInt64, StgInt64);
 432 I_ stg_eqInt64 (StgInt64, StgInt64);
 433 I_ stg_neInt64 (StgInt64, StgInt64);
 434 I_ stg_ltInt64 (StgInt64, StgInt64);
 435 I_ stg_leInt64 (StgInt64, StgInt64);
 436
 437 LW_ stg_remWord64  (StgWord64, StgWord64);
 438 LW_ stg_quotWord64 (StgWord64, StgWord64);
 439
 440 LI_ stg_remInt64    (StgInt64, StgInt64);
 441 LI_ stg_quotInt64   (StgInt64, StgInt64);
 442 LI_ stg_negateInt64 (StgInt64);
 443 LI_ stg_plusInt64   (StgInt64, StgInt64);
 444 LI_ stg_minusInt64  (StgInt64, StgInt64);
 445 LI_ stg_timesInt64  (StgInt64, StgInt64);
 446
 447 LW_ stg_and64  (StgWord64, StgWord64);
 448 LW_ stg_or64   (StgWord64, StgWord64);
 449 LW_ stg_xor64  (StgWord64, StgWord64);
 450 LW_ stg_not64  (StgWord64);
 451
 452 LW_ stg_shiftL64   (StgWord64, StgInt);
 453 LW_ stg_shiftRL64  (StgWord64, StgInt);
 454 LI_ stg_iShiftL64  (StgInt64, StgInt);
 455 LI_ stg_iShiftRL64 (StgInt64, StgInt);
 456 LI_ stg_iShiftRA64 (StgInt64, StgInt);
 457
 458 LI_ stg_intToInt64    (StgInt);
 459 I_ stg_int64ToInt     (StgInt64);
 460 LW_ stg_int64ToWord64 (StgInt64);
 461
 462 LW_ stg_wordToWord64  (StgWord);
 463 W_  stg_word64ToWord  (StgWord64);
 464 LI_ stg_word64ToInt64 (StgWord64);
 465 #endif
 466
 467 /* -----------------------------------------------------------------------------
 468    Array PrimOps.
 469    -------------------------------------------------------------------------- */
 470
 471 /* We cast to void* instead of StgChar* because this avoids a warning
 472  * about increasing the alignment requirements.
 473  */
 474 #define REAL_BYTE_ARR_CTS(a)   ((void *) (((StgArrWords *)(a))->payload))
 475 #define REAL_PTRS_ARR_CTS(a)   ((P_)   (((StgMutArrPtrs  *)(a))->payload))
 476
 477 #ifdef DEBUG
 478 #define BYTE_ARR_CTS(a)                           \
 479  ({ ASSERT(GET_INFO(a) == &ARR_WORDS_info);       \
 480     REAL_BYTE_ARR_CTS(a); })
 481 #define PTRS_ARR_CTS(a)                           \
 482  ({ ASSERT((GET_INFO(a) == &ARR_PTRS_info)        \
 483         || (GET_INFO(a) == &MUT_ARR_PTRS_info));  \
 484     REAL_PTRS_ARR_CTS(a); })
 485 #else
 486 #define BYTE_ARR_CTS(a)         REAL_BYTE_ARR_CTS(a)
 487 #define PTRS_ARR_CTS(a)         REAL_PTRS_ARR_CTS(a)
 488 #endif
 489
 490 extern I_ genSymZh(void);
 491 extern I_ resetGenSymZh(void);
 492
 493 /*--- everything except new*Array is done inline: */
 494
 495 #define sameMutableArrayzh(r,a,b)       r=(I_)((a)==(b))
 496 #define sameMutableByteArrayzh(r,a,b)   r=(I_)((a)==(b))
 497
 498 #define readArrayzh(r,a,i)       r=((PP_) PTRS_ARR_CTS(a))[(i)]
 499
 500 #define readCharArrayzh(r,a,i)   indexCharOffAddrzh(r,BYTE_ARR_CTS(a),i)
 501 #define readIntArrayzh(r,a,i)    indexIntOffAddrzh(r,BYTE_ARR_CTS(a),i)
 502 #define readWordArrayzh(r,a,i)   indexWordOffAddrzh(r,BYTE_ARR_CTS(a),i)
 503 #define readAddrArrayzh(r,a,i)   indexAddrOffAddrzh(r,BYTE_ARR_CTS(a),i)
 504 #define readFloatArrayzh(r,a,i)  indexFloatOffAddrzh(r,BYTE_ARR_CTS(a),i)
 505 #define readDoubleArrayzh(r,a,i) indexDoubleOffAddrzh(r,BYTE_ARR_CTS(a),i)
 506 #define readStablePtrArrayzh(r,a,i) indexStablePtrOffAddrzh(r,BYTE_ARR_CTS(a),i)
 507 #ifdef SUPPORT_LONG_LONGS
 508 #define readInt64Arrayzh(r,a,i)  indexInt64OffAddrzh(r,BYTE_ARR_CTS(a),i)
 509 #define readWord64Arrayzh(r,a,i) indexWord64OffAddrzh(r,BYTE_ARR_CTS(a),i)
 510 #endif
 511
 512 /* result ("r") arg ignored in write macros! */
 513 #define writeArrayzh(a,i,v)     ((PP_) PTRS_ARR_CTS(a))[(i)]=(v)
 514
 515 #define writeCharArrayzh(a,i,v)   ((C_ *)(BYTE_ARR_CTS(a)))[i] = (v)
 516 #define writeIntArrayzh(a,i,v)    ((I_ *)(BYTE_ARR_CTS(a)))[i] = (v)
 517 #define writeWordArrayzh(a,i,v)   ((W_ *)(BYTE_ARR_CTS(a)))[i] = (v)
 518 #define writeAddrArrayzh(a,i,v)   ((PP_)(BYTE_ARR_CTS(a)))[i] = (v)
 519 #define writeFloatArrayzh(a,i,v)  \
 520         ASSIGN_FLT((P_) (((StgFloat *)(BYTE_ARR_CTS(a))) + i),v)
 521 #define writeDoubleArrayzh(a,i,v) \
 522         ASSIGN_DBL((P_) (((StgDouble *)(BYTE_ARR_CTS(a))) + i),v)
 523 #define writeStablePtrArrayzh(a,i,v)      ((StgStablePtr *)(BYTE_ARR_CTS(a)))[i] = (v)
 524 #ifdef SUPPORT_LONG_LONGS
 525 #define writeInt64Arrayzh(a,i,v)  ((LI_ *)(BYTE_ARR_CTS(a)))[i] = (v)
 526 #define writeWord64Arrayzh(a,i,v) ((LW_ *)(BYTE_ARR_CTS(a)))[i] = (v)
 527 #endif
 528
 529 #define indexArrayzh(r,a,i)       r=((PP_) PTRS_ARR_CTS(a))[(i)]
 530
 531 #define indexCharArrayzh(r,a,i)   indexCharOffAddrzh(r,BYTE_ARR_CTS(a),i)
 532 #define indexIntArrayzh(r,a,i)    indexIntOffAddrzh(r,BYTE_ARR_CTS(a),i)
 533 #define indexWordArrayzh(r,a,i)   indexWordOffAddrzh(r,BYTE_ARR_CTS(a),i)
 534 #define indexAddrArrayzh(r,a,i)   indexAddrOffAddrzh(r,BYTE_ARR_CTS(a),i)
 535 #define indexFloatArrayzh(r,a,i)  indexFloatOffAddrzh(r,BYTE_ARR_CTS(a),i)
 536 #define indexDoubleArrayzh(r,a,i) indexDoubleOffAddrzh(r,BYTE_ARR_CTS(a),i)
 537 #define indexStablePtrArrayzh(r,a,i) indexStablePtrOffAddrzh(r,BYTE_ARR_CTS(a),i)
 538 #ifdef SUPPORT_LONG_LONGS
 539 #define indexInt64Arrayzh(r,a,i)  indexInt64OffAddrzh(r,BYTE_ARR_CTS(a),i)
 540 #define indexWord64Arrayzh(r,a,i) indexWord64OffAddrzh(r,BYTE_ARR_CTS(a),i)
 541 #endif
 542
 543 #define indexCharOffForeignObjzh(r,fo,i)   indexCharOffAddrzh(r,ForeignObj_CLOSURE_DATA(fo),i)
 544 #define indexIntOffForeignObjzh(r,fo,i)    indexIntOffAddrzh(r,ForeignObj_CLOSURE_DATA(fo),i)
 545 #define indexWordOffForeignObjzh(r,fo,i)   indexWordOffAddrzh(r,ForeignObj_CLOSURE_DATA(fo),i)
 546 #define indexAddrOffForeignObjzh(r,fo,i)   indexAddrOffAddrzh(r,ForeignObj_CLOSURE_DATA(fo),i)
 547 #define indexFloatOffForeignObjzh(r,fo,i)  indexFloatOffAddrzh(r,ForeignObj_CLOSURE_DATA(fo),i)
 548 #define indexDoubleOffForeignObjzh(r,fo,i) indexDoubleOffAddrzh(r,ForeignObj_CLOSURE_DATA(fo),i)
 549 #define indexStablePtrOffForeignObjzh(r,fo,i)  indexStablePtrOffAddrzh(r,ForeignObj_CLOSURE_DATA(fo),i)
 550 #ifdef SUPPORT_LONG_LONGS
 551 #define indexInt64OffForeignObjzh(r,fo,i)  indexInt64OffAddrzh(r,ForeignObj_CLOSURE_DATA(fo),i)
 552 #define indexWord64OffForeignObjzh(r,fo,i) indexWord64OffAddrzh(r,ForeignObj_CLOSURE_DATA(fo),i)
 553 #endif
 554
 555 #define indexCharOffAddrzh(r,a,i)   r= ((C_ *)(a))[i]
 556 #define indexIntOffAddrzh(r,a,i)    r= ((I_ *)(a))[i]
 557 #define indexWordOffAddrzh(r,a,i)   r= ((W_ *)(a))[i]
 558 #define indexAddrOffAddrzh(r,a,i)   r= ((PP_)(a))[i]
 559 #define indexFloatOffAddrzh(r,a,i)  r= PK_FLT((P_) (((StgFloat *)(a)) + i))
 560 #define indexDoubleOffAddrzh(r,a,i) r= PK_DBL((P_) (((StgDouble *)(a)) + i))
 561 #ifdef SUPPORT_LONG_LONGS
 562 #define indexInt64OffAddrzh(r,a,i)  r= ((LI_ *)(a))[i]
 563 #define indexWord64OffAddrzh(r,a,i) r= ((LW_ *)(a))[i]
 564 #endif
 565
 566 /* Freezing arrays-of-ptrs requires changing an info table, for the
 567    benefit of the generational collector.  It needs to scavenge mutable
 568    objects, even if they are in old space.  When they become immutable,
 569    they can be removed from this scavenge list.  */
 570
 571 #define unsafeFreezzeArrayzh(r,a)                                       \
 572         {                                                               \
 573         SET_INFO((StgClosure *)a,&MUT_ARR_PTRS_FROZEN_info);            \
 574         r = a;                                                          \
 575         }
 576
 577 #define unsafeFreezzeByteArrayzh(r,a)   r=(a)
 578 #define unsafeThawByteArrayzh(r,a)      r=(a)
 579
 580 EF_(unsafeThawArrayzh_fast);
 581
 582 #define sizzeofByteArrayzh(r,a) \
 583      r = (((StgArrWords *)(a))->words * sizeof(W_))
 584 #define sizzeofMutableByteArrayzh(r,a) \
 585      r = (((StgArrWords *)(a))->words * sizeof(W_))
 586
 587 /* and the out-of-line ones... */
 588
 589 EF_(newCharArrayzh_fast);
 590 EF_(newIntArrayzh_fast);
 591 EF_(newWordArrayzh_fast);
 592 EF_(newAddrArrayzh_fast);
 593 EF_(newFloatArrayzh_fast);
 594 EF_(newDoubleArrayzh_fast);
 595 EF_(newStablePtrArrayzh_fast);
 596 EF_(newArrayzh_fast);
 597
 598 /* encoding and decoding of floats/doubles. */
 599
 600 /* We only support IEEE floating point format */
 601 #include "ieee-flpt.h"
 602
 603 /* The decode operations are out-of-line because they need to allocate
 604  * a byte array.
 605  */
 606 #ifdef FLOATS_AS_DOUBLES
 607 #define decodeFloatzh_fast decodeDoublezh_fast
 608 #else
 609 EF_(decodeFloatzh_fast);
 610 #endif
 611
 612 EF_(decodeDoublezh_fast);
 613
 614 /* grimy low-level support functions defined in StgPrimFloat.c */
 615
 616 extern StgDouble __encodeDouble (I_ size, StgByteArray arr, I_ e);
 617 extern StgDouble __int_encodeDouble (I_ j, I_ e);
 618 #ifndef FLOATS_AS_DOUBLES
 619 extern StgFloat  __encodeFloat (I_ size, StgByteArray arr, I_ e);
 620 extern StgFloat  __int_encodeFloat (I_ j, I_ e);
 621 #endif
 622 extern void      __decodeDouble (MP_INT *man, I_ *_exp, StgDouble dbl);
 623 extern void      __decodeFloat  (MP_INT *man, I_ *_exp, StgFloat flt);
 624 extern StgInt    isDoubleNaN(StgDouble d);
 625 extern StgInt    isDoubleInfinite(StgDouble d);
 626 extern StgInt    isDoubleDenormalized(StgDouble d);
 627 extern StgInt    isDoubleNegativeZero(StgDouble d);
 628 extern StgInt    isFloatNaN(StgFloat f);
 629 extern StgInt    isFloatInfinite(StgFloat f);
 630 extern StgInt    isFloatDenormalized(StgFloat f);
 631 extern StgInt    isFloatNegativeZero(StgFloat f);
 632
 633 /* -----------------------------------------------------------------------------
 634    Mutable variables
 635
 636    newMutVar is out of line.
 637    -------------------------------------------------------------------------- */
 638
 639 EF_(newMutVarzh_fast);
 640
 641 #define readMutVarzh(r,a)        r=(P_)(((StgMutVar *)(a))->var)
 642 #define writeMutVarzh(a,v)       (P_)(((StgMutVar *)(a))->var)=(v)
 643 #define sameMutVarzh(r,a,b)      r=(I_)((a)==(b))
 644
 645 /* -----------------------------------------------------------------------------
 646    MVar PrimOps.
 647
 648    All out of line, because they either allocate or may block.
 649    -------------------------------------------------------------------------- */
 650 #define sameMVarzh(r,a,b)        r=(I_)((a)==(b))
 651
 652 /* Assume external decl of EMPTY_MVAR_info is in scope by now */
 653 #define isEmptyMVarzh(r,a)       r=(I_)((GET_INFO((StgMVar*)(a))) == &EMPTY_MVAR_info )
 654 EF_(newMVarzh_fast);
 655 EF_(takeMVarzh_fast);
 656 EF_(putMVarzh_fast);
 657
 658
 659 /* -----------------------------------------------------------------------------
 660    Delay/Wait PrimOps
 661    -------------------------------------------------------------------------- */
 662
 663 /* Hmm, I'll think about these later. */
 664
 665 /* -----------------------------------------------------------------------------
 666    Primitive I/O, error-handling PrimOps
 667    -------------------------------------------------------------------------- */
 668
 669 EF_(catchzh_fast);
 670 EF_(raisezh_fast);
 671
 672 extern void stg_exit(I_ n)  __attribute__ ((noreturn));
 673
 674 /* -----------------------------------------------------------------------------
 675    Stable Name / Stable Pointer  PrimOps
 676    -------------------------------------------------------------------------- */
 677
 678 #ifndef PAR
 679
 680 EF_(makeStableNamezh_fast);
 681
 682 #define stableNameToIntzh(r,s)   (r = ((StgStableName *)s)->sn)
 683
 684 #define eqStableNamezh(r,sn1,sn2)                                       \
 685     (r = (((StgStableName *)sn1)->sn == ((StgStableName *)sn2)->sn))
 686
 687 #define makeStablePtrzh(r,a) \
 688    r = RET_STGCALL1(StgStablePtr,getStablePtr,a)
 689
 690 #define deRefStablePtrzh(r,sp) do {             \
 691   ASSERT(stable_ptr_table[sp & ~STABLEPTR_WEIGHT_MASK].weight > 0);     \
 692   r = stable_ptr_table[sp & ~STABLEPTR_WEIGHT_MASK].addr; \
 693 } while (0);
 694
 695 #define eqStablePtrzh(r,sp1,sp2) \
 696     (r = ((sp1 & ~STABLEPTR_WEIGHT_MASK) == (sp2 & ~STABLEPTR_WEIGHT_MASK)))
 697
 698 #endif
 699
 700 /* -----------------------------------------------------------------------------
 701    Parallel PrimOps.
 702    -------------------------------------------------------------------------- */
 703
 704 EF_(forkzh_fast);
 705 EF_(yieldzh_fast);
 706 EF_(killThreadzh_fast);
 707 EF_(seqzh_fast);
 708
 709 #define myThreadIdzh(t) (t = CurrentTSO)
 710
 711 /* Hmm, I'll think about these later. */
 712 /* -----------------------------------------------------------------------------
 713    Pointer equality
 714    -------------------------------------------------------------------------- */
 715
 716 /* warning: extremely non-referentially transparent, need to hide in
 717    an appropriate monad.
 718
 719    ToDo: follow indirections.
 720 */
 721
 722 #define reallyUnsafePtrEqualityzh(r,a,b) r=((StgPtr)(a) == (StgPtr)(b))
 723
 724 /* -----------------------------------------------------------------------------
 725    Weak Pointer PrimOps.
 726    -------------------------------------------------------------------------- */
 727
 728 #ifndef PAR
 729
 730 EF_(mkWeakzh_fast);
 731 EF_(finalizzeWeakzh_fast);
 732
 733 #define deRefWeakzh(code,val,w)                         \
 734   if (((StgWeak *)w)->header.info == &WEAK_info) {      \
 735         code = 1;                                       \
 736         val = (P_)((StgWeak *)w)->value;                \
 737   } else {                                              \
 738         code = 0;                                       \
 739         val = (P_)w;                                    \
 740   }
 741
 742 #define sameWeakzh(w1,w2)  ((w1)==(w2))
 743
 744 #endif
 745
 746 /* -----------------------------------------------------------------------------
 747    Foreign Object PrimOps.
 748    -------------------------------------------------------------------------- */
 749
 750 #ifndef PAR
 751
 752 #define ForeignObj_CLOSURE_DATA(c)  (((StgForeignObj *)c)->data)
 753
 754 EF_(makeForeignObjzh_fast);
 755
 756 #define writeForeignObjzh(res,datum) \
 757    (ForeignObj_CLOSURE_DATA(res) = (P_)(datum))
 758
 759 #define eqForeignObj(f1,f2)  ((f1)==(f2))
 760
 761 #endif
 762
 763 /* -----------------------------------------------------------------------------
 764    Signal processing.  Not really primops, but called directly from
 765    Haskell.
 766    -------------------------------------------------------------------------- */
 767
 768 #define STG_SIG_DFL  (-1)
 769 #define STG_SIG_IGN  (-2)
 770 #define STG_SIG_ERR  (-3)
 771 #define STG_SIG_HAN  (-4)
 772
 773 extern StgInt sig_install (StgInt, StgInt, StgStablePtr, sigset_t *);
 774 #define stg_sig_default(sig,mask) sig_install(sig,STG_SIG_DFL,0,(sigset_t *)mask)
 775 #define stg_sig_ignore(sig,mask) sig_install(sig,STG_SIG_IGN,0,(sigset_t *)mask)
 776 #define stg_sig_catch(sig,ptr,mask) sig_install(sig,STG_SIG_HAN,ptr,(sigset_t *)mask)
 777
 778 #endif PRIMOPS_H