ghc/includes/PrimOps.h

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