ghc/includes/PrimOps.h

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