ghc/includes/PrimOps.h

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