ghc/includes/PrimOps.h

   1 /* -----------------------------------------------------------------------------
   2  * $Id: PrimOps.h,v 1.53 2000/05/10 11:02:00 simonmar Exp $
   3  *
   4  * (c) The GHC Team, 1998-1999
   5  *
   6  * Macros for primitive operations in STG-ish C code.
   7  *
   8  * ---------------------------------------------------------------------------*/
   9
  10 #ifndef PRIMOPS_H
  11 #define PRIMOPS_H
  12
  13 /* -----------------------------------------------------------------------------
  14    Comparison PrimOps.
  15    -------------------------------------------------------------------------- */
  16
  17 #define gtCharzh(r,a,b) r=(I_)((a)> (b))
  18 #define geCharzh(r,a,b) r=(I_)((a)>=(b))
  19 #define eqCharzh(r,a,b) r=(I_)((a)==(b))
  20 #define neCharzh(r,a,b) r=(I_)((a)!=(b))
  21 #define ltCharzh(r,a,b) r=(I_)((a)< (b))
  22 #define leCharzh(r,a,b) r=(I_)((a)<=(b))
  23
  24 /* Int comparisons: >#, >=# etc */
  25 #define zgzh(r,a,b)     r=(I_)((I_)(a) >(I_)(b))
  26 #define zgzezh(r,a,b)   r=(I_)((I_)(a)>=(I_)(b))
  27 #define zezezh(r,a,b)   r=(I_)((I_)(a)==(I_)(b))
  28 #define zszezh(r,a,b)   r=(I_)((I_)(a)!=(I_)(b))
  29 #define zlzh(r,a,b)     r=(I_)((I_)(a) <(I_)(b))
  30 #define zlzezh(r,a,b)   r=(I_)((I_)(a)<=(I_)(b))
  31
  32 #define gtWordzh(r,a,b) r=(I_)((W_)(a) >(W_)(b))
  33 #define geWordzh(r,a,b) r=(I_)((W_)(a)>=(W_)(b))
  34 #define eqWordzh(r,a,b) r=(I_)((W_)(a)==(W_)(b))
  35 #define neWordzh(r,a,b) r=(I_)((W_)(a)!=(W_)(b))
  36 #define ltWordzh(r,a,b) r=(I_)((W_)(a) <(W_)(b))
  37 #define leWordzh(r,a,b) r=(I_)((W_)(a)<=(W_)(b))
  38
  39 #define gtAddrzh(r,a,b) r=(I_)((a) >(b))
  40 #define geAddrzh(r,a,b) r=(I_)((a)>=(b))
  41 #define eqAddrzh(r,a,b) r=(I_)((a)==(b))
  42 #define neAddrzh(r,a,b) r=(I_)((a)!=(b))
  43 #define ltAddrzh(r,a,b) r=(I_)((a) <(b))
  44 #define leAddrzh(r,a,b) r=(I_)((a)<=(b))
  45
  46 #define gtFloatzh(r,a,b)  r=(I_)((a)> (b))
  47 #define geFloatzh(r,a,b)  r=(I_)((a)>=(b))
  48 #define eqFloatzh(r,a,b)  r=(I_)((a)==(b))
  49 #define neFloatzh(r,a,b)  r=(I_)((a)!=(b))
  50 #define ltFloatzh(r,a,b)  r=(I_)((a)< (b))
  51 #define leFloatzh(r,a,b)  r=(I_)((a)<=(b))
  52
  53 /* Double comparisons: >##, >=#@ etc */
  54 #define zgzhzh(r,a,b)   r=(I_)((a) >(b))
  55 #define zgzezhzh(r,a,b) r=(I_)((a)>=(b))
  56 #define zezezhzh(r,a,b) r=(I_)((a)==(b))
  57 #define zszezhzh(r,a,b) r=(I_)((a)!=(b))
  58 #define zlzhzh(r,a,b)   r=(I_)((a) <(b))
  59 #define zlzezhzh(r,a,b) r=(I_)((a)<=(b))
  60
  61 /* -----------------------------------------------------------------------------
  62    Char# PrimOps.
  63    -------------------------------------------------------------------------- */
  64
  65 #define ordzh(r,a)      r=(I_)((W_) (a))
  66 #define chrzh(r,a)      r=(StgChar)((W_)(a))
  67
  68 /* -----------------------------------------------------------------------------
  69    Int# PrimOps.
  70    -------------------------------------------------------------------------- */
  71
  72 I_ stg_div (I_ a, I_ b);
  73
  74 #define zpzh(r,a,b)             r=(a)+(b)
  75 #define zmzh(r,a,b)             r=(a)-(b)
  76 #define ztzh(r,a,b)             r=(a)*(b)
  77 #define quotIntzh(r,a,b)        r=(a)/(b)
  78 #define zszh(r,a,b)             r=ULTRASAFESTGCALL2(I_,(void *, I_, I_),stg_div,(a),(b))
  79 #define remIntzh(r,a,b)         r=(a)%(b)
  80 #define negateIntzh(r,a)        r=-(a)
  81
  82 /* -----------------------------------------------------------------------------
  83  * Int operations with carry.
  84  * -------------------------------------------------------------------------- */
  85
  86 /* With some bit-twiddling, we can define int{Add,Sub}Czh portably in
  87  * C, and without needing any comparisons.  This may not be the
  88  * fastest way to do it - if you have better code, please send it! --SDM
  89  *
  90  * Return : r = a + b,  c = 0 if no overflow, 1 on overflow.
  91  *
  92  * We currently don't make use of the r value if c is != 0 (i.e.
  93  * overflow), we just convert to big integers and try again.  This
  94  * could be improved by making r and c the correct values for
  95  * plugging into a new J#.
  96  */
  97 #define addIntCzh(r,c,a,b)                      \
  98 { r = a + b;                                    \
  99   c = ((StgWord)(~(a^b) & (a^r)))               \
 100     >> (BITS_PER_BYTE * sizeof(I_) - 1);        \
 101 }
 102
 103
 104 #define subIntCzh(r,c,a,b)                      \
 105 { r = a - b;                                    \
 106   c = ((StgWord)((a^b) & (a^r)))                \
 107     >> (BITS_PER_BYTE * sizeof(I_) - 1);        \
 108 }
 109
 110 /* Multiply with overflow checking.
 111  *
 112  * This is slightly more tricky - the usual sign rules for add/subtract
 113  * don't apply.
 114  *
 115  * On x86 hardware we use a hand-crafted assembly fragment to do the job.
 116  *
 117  * On other 32-bit machines we use gcc's 'long long' types, finding
 118  * overflow with some careful bit-twiddling.
 119  *
 120  * On 64-bit machines where gcc's 'long long' type is also 64-bits,
 121  * we use a crude approximation, testing whether either operand is
 122  * larger than 32-bits; if neither is, then we go ahead with the
 123  * multiplication.
 124  */
 125
 126 #if i386_TARGET_ARCH
 127
 128 #define mulIntCzh(r,c,a,b)                              \
 129 {                                                       \
 130   __asm__("xorl %1,%1\n\t                               \
 131            imull %2,%3\n\t                              \
 132            jno 1f\n\t                                   \
 133            movl $1,%1\n\t                               \
 134            1:"                                          \
 135         : "=r" (r), "=&r" (c) : "r" (a), "0" (b));      \
 136 }
 137
 138 #elif SIZEOF_VOID_P == 4
 139
 140 #ifdef WORDS_BIGENDIAN
 141 #define C 0
 142 #define R 1
 143 #else
 144 #define C 1
 145 #define R 0
 146 #endif
 147
 148 typedef union {
 149     StgInt64 l;
 150     StgInt32 i[2];
 151 } long_long_u ;
 152
 153 #define mulIntCzh(r,c,a,b)                      \
 154 {                                               \
 155   long_long_u z;                                \
 156   z.l = (StgInt64)a * (StgInt64)b;              \
 157   r = z.i[R];                                   \
 158   c = z.i[C];                                   \
 159   if (c == 0 || c == -1) {                      \
 160     c = ((StgWord)((a^b) ^ r))                  \
 161       >> (BITS_PER_BYTE * sizeof(I_) - 1);      \
 162   }                                             \
 163 }
 164 /* Careful: the carry calculation above is extremely delicate.  Make sure
 165  * you test it thoroughly after changing it.
 166  */
 167
 168 #else
 169
 170 #define HALF_INT  (1 << (BITS_PER_BYTE * sizeof(I_) / 2))
 171
 172 #define stg_abs(a) ((a) < 0 ? -(a) : (a))
 173
 174 #define mulIntCzh(r,c,a,b)                      \
 175 {                                               \
 176   if (stg_abs(a) >= HALF_INT                    \
 177       stg_abs(b) >= HALF_INT) {                 \
 178     c = 1;                                      \
 179   } else {                                      \
 180     r = a * b;                                  \
 181     c = 0;                                      \
 182   }                                             \
 183 }
 184 #endif
 185
 186 /* -----------------------------------------------------------------------------
 187    Word PrimOps.
 188    -------------------------------------------------------------------------- */
 189
 190 #define quotWordzh(r,a,b)       r=((W_)a)/((W_)b)
 191 #define remWordzh(r,a,b)        r=((W_)a)%((W_)b)
 192
 193 #define andzh(r,a,b)            r=(a)&(b)
 194 #define orzh(r,a,b)             r=(a)|(b)
 195 #define xorzh(r,a,b)            r=(a)^(b)
 196 #define notzh(r,a)              r=~(a)
 197
 198 /* The extra tests below properly define the behaviour when shifting
 199  * by offsets larger than the width of the value being shifted.  Doing
 200  * so is undefined in C (and in fact gives different answers depending
 201  * on whether the operation is constant folded or not with gcc on x86!)
 202  */
 203
 204 #define shiftLzh(r,a,b)         r=((b) >= BITS_IN(W_)) ? 0 : (a)<<(b)
 205 #define shiftRLzh(r,a,b)        r=((b) >= BITS_IN(W_)) ? 0 : (a)>>(b)
 206 #define iShiftLzh(r,a,b)        r=((b) >= BITS_IN(W_)) ? 0 : (a)<<(b)
 207 /* Right shifting of signed quantities is not portable in C, so
 208    the behaviour you'll get from using these primops depends
 209    on the whatever your C compiler is doing. ToDo: fix/document. -- sof 8/98
 210 */
 211 #define iShiftRAzh(r,a,b)       r=((b) >= BITS_IN(I_)) ? (((a) < 0) ? -1 : 0) : (a)>>(b)
 212 #define iShiftRLzh(r,a,b)       r=((b) >= BITS_IN(I_)) ? 0 : ((W_)(a))>>(b)
 213
 214 #define int2Wordzh(r,a)         r=(W_)(a)
 215 #define word2Intzh(r,a)         r=(I_)(a)
 216
 217 /* -----------------------------------------------------------------------------
 218    Addr PrimOps.
 219    -------------------------------------------------------------------------- */
 220
 221 #define int2Addrzh(r,a)         r=(A_)(a)
 222 #define addr2Intzh(r,a)         r=(I_)(a)
 223
 224 #define readCharOffAddrzh(r,a,i)        r= ((C_ *)(a))[i]
 225 #define readIntOffAddrzh(r,a,i)         r= ((I_ *)(a))[i]
 226 #define readWordOffAddrzh(r,a,i)        r= ((W_ *)(a))[i]
 227 #define readAddrOffAddrzh(r,a,i)        r= ((PP_)(a))[i]
 228 #define readFloatOffAddrzh(r,a,i)       r= PK_FLT((P_) (((StgFloat *)(a)) + i))
 229 #define readDoubleOffAddrzh(r,a,i)      r= PK_DBL((P_) (((StgDouble *)(a)) + i))
 230 #define readStablePtrOffAddrzh(r,a,i)   r= ((StgStablePtr *)(a))[i]
 231 #ifdef SUPPORT_LONG_LONGS
 232 #define readInt64OffAddrzh(r,a,i)       r= ((LI_ *)(a))[i]
 233 #define readWord64OffAddrzh(r,a,i)      r= ((LW_ *)(a))[i]
 234 #endif
 235
 236 #define writeCharOffAddrzh(a,i,v)       ((C_ *)(a))[i] = (v)
 237 #define writeIntOffAddrzh(a,i,v)        ((I_ *)(a))[i] = (v)
 238 #define writeWordOffAddrzh(a,i,v)       ((W_ *)(a))[i] = (v)
 239 #define writeAddrOffAddrzh(a,i,v)       ((PP_)(a))[i] = (v)
 240 #define writeForeignObjOffAddrzh(a,i,v) ((PP_)(a))[i] = ForeignObj_CLOSURE_DATA(v)
 241 #define writeFloatOffAddrzh(a,i,v)      ASSIGN_FLT((P_) (((StgFloat *)(a)) + i),v)
 242 #define writeDoubleOffAddrzh(a,i,v)     ASSIGN_DBL((P_) (((StgDouble *)(a)) + i),v)
 243 #define writeStablePtrOffAddrzh(a,i,v)  ((StgStablePtr *)(a))[i] = (v)
 244 #ifdef SUPPORT_LONG_LONGS
 245 #define writeInt64OffAddrzh(a,i,v)   ((LI_ *)(a))[i] = (v)
 246 #define writeWord64OffAddrzh(a,i,v)  ((LW_ *)(a))[i] = (v)
 247 #endif
 248
 249 #define indexCharOffAddrzh(r,a,i)       r= ((C_ *)(a))[i]
 250 #define indexIntOffAddrzh(r,a,i)        r= ((I_ *)(a))[i]
 251 #define indexWordOffAddrzh(r,a,i)       r= ((W_ *)(a))[i]
 252 #define indexAddrOffAddrzh(r,a,i)       r= ((PP_)(a))[i]
 253 #define indexFloatOffAddrzh(r,a,i)      r= PK_FLT((P_) (((StgFloat *)(a)) + i))
 254 #define indexDoubleOffAddrzh(r,a,i)     r= PK_DBL((P_) (((StgDouble *)(a)) + i))
 255 #define indexStablePtrOffAddrzh(r,a,i)  r= ((StgStablePtr *)(a))[i]
 256 #ifdef SUPPORT_LONG_LONGS
 257 #define indexInt64OffAddrzh(r,a,i)      r= ((LI_ *)(a))[i]
 258 #define indexWord64OffAddrzh(r,a,i)     r= ((LW_ *)(a))[i]
 259 #endif
 260
 261 /* -----------------------------------------------------------------------------
 262    Float PrimOps.
 263    -------------------------------------------------------------------------- */
 264
 265 #define plusFloatzh(r,a,b)   r=(a)+(b)
 266 #define minusFloatzh(r,a,b)  r=(a)-(b)
 267 #define timesFloatzh(r,a,b)  r=(a)*(b)
 268 #define divideFloatzh(r,a,b) r=(a)/(b)
 269 #define negateFloatzh(r,a)   r=-(a)
 270
 271 #define int2Floatzh(r,a)     r=(StgFloat)(a)
 272 #define float2Intzh(r,a)     r=(I_)(a)
 273
 274 #define expFloatzh(r,a)      r=(StgFloat) RET_PRIM_STGCALL1(StgDouble,exp,a)
 275 #define logFloatzh(r,a)      r=(StgFloat) RET_PRIM_STGCALL1(StgDouble,log,a)
 276 #define sqrtFloatzh(r,a)     r=(StgFloat) RET_PRIM_STGCALL1(StgDouble,sqrt,a)
 277 #define sinFloatzh(r,a)      r=(StgFloat) RET_PRIM_STGCALL1(StgDouble,sin,a)
 278 #define cosFloatzh(r,a)      r=(StgFloat) RET_PRIM_STGCALL1(StgDouble,cos,a)
 279 #define tanFloatzh(r,a)      r=(StgFloat) RET_PRIM_STGCALL1(StgDouble,tan,a)
 280 #define asinFloatzh(r,a)     r=(StgFloat) RET_PRIM_STGCALL1(StgDouble,asin,a)
 281 #define acosFloatzh(r,a)     r=(StgFloat) RET_PRIM_STGCALL1(StgDouble,acos,a)
 282 #define atanFloatzh(r,a)     r=(StgFloat) RET_PRIM_STGCALL1(StgDouble,atan,a)
 283 #define sinhFloatzh(r,a)     r=(StgFloat) RET_PRIM_STGCALL1(StgDouble,sinh,a)
 284 #define coshFloatzh(r,a)     r=(StgFloat) RET_PRIM_STGCALL1(StgDouble,cosh,a)
 285 #define tanhFloatzh(r,a)     r=(StgFloat) RET_PRIM_STGCALL1(StgDouble,tanh,a)
 286 #define powerFloatzh(r,a,b)  r=(StgFloat) RET_PRIM_STGCALL2(StgDouble,pow,a,b)
 287
 288 /* -----------------------------------------------------------------------------
 289    Double PrimOps.
 290    -------------------------------------------------------------------------- */
 291
 292 #define zpzhzh(r,a,b)        r=(a)+(b)
 293 #define zmzhzh(r,a,b)        r=(a)-(b)
 294 #define ztzhzh(r,a,b)        r=(a)*(b)
 295 #define zszhzh(r,a,b)        r=(a)/(b)
 296 #define negateDoublezh(r,a)  r=-(a)
 297
 298 #define int2Doublezh(r,a)    r=(StgDouble)(a)
 299 #define double2Intzh(r,a)    r=(I_)(a)
 300
 301 #define float2Doublezh(r,a)  r=(StgDouble)(a)
 302 #define double2Floatzh(r,a)  r=(StgFloat)(a)
 303
 304 #define expDoublezh(r,a)     r=(StgDouble) RET_PRIM_STGCALL1(StgDouble,exp,a)
 305 #define logDoublezh(r,a)     r=(StgDouble) RET_PRIM_STGCALL1(StgDouble,log,a)
 306 #define sqrtDoublezh(r,a)    r=(StgDouble) RET_PRIM_STGCALL1(StgDouble,sqrt,a)
 307 #define sinDoublezh(r,a)     r=(StgDouble) RET_PRIM_STGCALL1(StgDouble,sin,a)
 308 #define cosDoublezh(r,a)     r=(StgDouble) RET_PRIM_STGCALL1(StgDouble,cos,a)
 309 #define tanDoublezh(r,a)     r=(StgDouble) RET_PRIM_STGCALL1(StgDouble,tan,a)
 310 #define asinDoublezh(r,a)    r=(StgDouble) RET_PRIM_STGCALL1(StgDouble,asin,a)
 311 #define acosDoublezh(r,a)    r=(StgDouble) RET_PRIM_STGCALL1(StgDouble,acos,a)
 312 #define atanDoublezh(r,a)    r=(StgDouble) RET_PRIM_STGCALL1(StgDouble,atan,a)
 313 #define sinhDoublezh(r,a)    r=(StgDouble) RET_PRIM_STGCALL1(StgDouble,sinh,a)
 314 #define coshDoublezh(r,a)    r=(StgDouble) RET_PRIM_STGCALL1(StgDouble,cosh,a)
 315 #define tanhDoublezh(r,a)    r=(StgDouble) RET_PRIM_STGCALL1(StgDouble,tanh,a)
 316 /* Power: **## */
 317 #define ztztzhzh(r,a,b) r=(StgDouble) RET_PRIM_STGCALL2(StgDouble,pow,a,b)
 318
 319 /* -----------------------------------------------------------------------------
 320    Integer PrimOps.
 321    -------------------------------------------------------------------------- */
 322
 323 /* We can do integer2Int and cmpInteger inline, since they don't need
 324  * to allocate any memory.
 325  *
 326  * integer2Int# is now modular.
 327  */
 328
 329 #define integer2Intzh(r, sa,da)                         \
 330 { StgWord word0 = ((StgWord *)BYTE_ARR_CTS(da))[0];     \
 331   int size = sa;                                        \
 332                                                         \
 333   (r) =                                                 \
 334     ( size == 0 ) ?                                     \
 335        0 :                                              \
 336        ( size < 0 && word0 != 0x8000000 ) ?             \
 337          -(I_)word0 :                                   \
 338           (I_)word0;                                    \
 339 }
 340
 341 #define integer2Wordzh(r, sa,da)                        \
 342 { StgWord word0 = ((StgWord *)BYTE_ARR_CTS(da))[0];     \
 343   int size = sa;                                        \
 344   (r) = ( size == 0 ) ? 0 : word0 ;                     \
 345 }
 346
 347 #define cmpIntegerzh(r, s1,d1, s2,d2)                           \
 348 { MP_INT arg1;                                                  \
 349   MP_INT arg2;                                                  \
 350                                                                 \
 351   arg1._mp_size = (s1);                                         \
 352   arg1._mp_alloc= ((StgArrWords *)d1)->words;                   \
 353   arg1._mp_d    = (unsigned long int *) (BYTE_ARR_CTS(d1));     \
 354   arg2._mp_size = (s2);                                         \
 355   arg2._mp_alloc= ((StgArrWords *)d2)->words;                   \
 356   arg2._mp_d    = (unsigned long int *) (BYTE_ARR_CTS(d2));     \
 357                                                                 \
 358   (r) = RET_PRIM_STGCALL2(I_,mpz_cmp,&arg1,&arg2);              \
 359 }
 360
 361 #define cmpIntegerIntzh(r, s,d, i)                              \
 362 { MP_INT arg;                                                   \
 363                                                                 \
 364   arg._mp_size  = (s);                                          \
 365   arg._mp_alloc = ((StgArrWords *)d)->words;                    \
 366   arg._mp_d     = (unsigned long int *) (BYTE_ARR_CTS(d));      \
 367                                                                 \
 368   (r) = RET_PRIM_STGCALL2(I_,mpz_cmp_si,&arg,i);                \
 369 }
 370
 371 /* I think mp_limb_t must be the same size as StgInt for this to work
 372  * properly --SDM
 373  */
 374 #define gcdIntzh(r,a,b) \
 375 { StgInt aa = a; \
 376   r = (aa) ? (b) ? \
 377         RET_STGCALL3(StgInt, mpn_gcd_1, (mp_limb_t *)(&aa), 1, (mp_limb_t)(b)) \
 378         : abs(aa) \
 379       : abs(b); \
 380 }
 381
 382 #define gcdIntegerIntzh(r,a,sb,b) \
 383   RET_STGCALL3(StgInt, mpn_gcd_1, (unsigned long int *) b, sb, (mp_limb_t)(a))
 384
 385 /* The rest are all out-of-line: -------- */
 386
 387 /* Integer arithmetic */
 388 EF_(plusIntegerzh_fast);
 389 EF_(minusIntegerzh_fast);
 390 EF_(timesIntegerzh_fast);
 391 EF_(gcdIntegerzh_fast);
 392 EF_(quotRemIntegerzh_fast);
 393 EF_(quotIntegerzh_fast);
 394 EF_(remIntegerzh_fast);
 395 EF_(divExactIntegerzh_fast);
 396 EF_(divModIntegerzh_fast);
 397
 398 /* Conversions */
 399 EF_(int2Integerzh_fast);
 400 EF_(word2Integerzh_fast);
 401 EF_(addr2Integerzh_fast);
 402
 403 /* Floating-point decodings */
 404 EF_(decodeFloatzh_fast);
 405 EF_(decodeDoublezh_fast);
 406
 407 /* -----------------------------------------------------------------------------
 408    Word64 PrimOps.
 409    -------------------------------------------------------------------------- */
 410
 411 #ifdef SUPPORT_LONG_LONGS
 412
 413 #define integerToWord64zh(r, sa,da)                             \
 414 { unsigned long int* d;                                         \
 415   I_ aa;                                                        \
 416   StgWord64 res;                                                \
 417                                                                 \
 418   d             = (unsigned long int *) (BYTE_ARR_CTS(da));     \
 419   aa = ((StgArrWords *)da)->words;                              \
 420   if ( (aa) == 0 ) {                                            \
 421      res = (LW_)0;                                              \
 422   } else if ( (aa) == 1) {                                      \
 423      res = (LW_)d[0];                                           \
 424   } else {                                                      \
 425      res = (LW_)d[0] + (LW_)d[1] * 0x100000000ULL;              \
 426   }                                                             \
 427   (r) = res;                                                    \
 428 }
 429
 430 #define integerToInt64zh(r, sa,da)                              \
 431 { unsigned long int* d;                                         \
 432   I_ aa;                                                        \
 433   StgInt64 res;                                                 \
 434                                                                 \
 435   d             = (unsigned long int *) (BYTE_ARR_CTS(da));     \
 436   aa = ((StgArrWords *)da)->words;                              \
 437   if ( (aa) == 0 ) {                                            \
 438      res = (LI_)0;                                              \
 439   } else if ( (aa) == 1) {                                      \
 440      res = (LI_)d[0];                                           \
 441   } else {                                                      \
 442      res = (LI_)d[0] + (LI_)d[1] * 0x100000000LL;               \
 443      if ( sa < 0 ) {                                            \
 444            res = (LI_)-res;                                     \
 445      }                                                          \
 446   }                                                             \
 447   (r) = res;                                                    \
 448 }
 449
 450 /* Conversions */
 451 EF_(int64ToIntegerzh_fast);
 452 EF_(word64ToIntegerzh_fast);
 453
 454 /* The rest are (way!) out of line, implemented via C entry points.
 455  */
 456 I_ stg_gtWord64 (StgWord64, StgWord64);
 457 I_ stg_geWord64 (StgWord64, StgWord64);
 458 I_ stg_eqWord64 (StgWord64, StgWord64);
 459 I_ stg_neWord64 (StgWord64, StgWord64);
 460 I_ stg_ltWord64 (StgWord64, StgWord64);
 461 I_ stg_leWord64 (StgWord64, StgWord64);
 462
 463 I_ stg_gtInt64 (StgInt64, StgInt64);
 464 I_ stg_geInt64 (StgInt64, StgInt64);
 465 I_ stg_eqInt64 (StgInt64, StgInt64);
 466 I_ stg_neInt64 (StgInt64, StgInt64);
 467 I_ stg_ltInt64 (StgInt64, StgInt64);
 468 I_ stg_leInt64 (StgInt64, StgInt64);
 469
 470 LW_ stg_remWord64  (StgWord64, StgWord64);
 471 LW_ stg_quotWord64 (StgWord64, StgWord64);
 472
 473 LI_ stg_remInt64    (StgInt64, StgInt64);
 474 LI_ stg_quotInt64   (StgInt64, StgInt64);
 475 LI_ stg_negateInt64 (StgInt64);
 476 LI_ stg_plusInt64   (StgInt64, StgInt64);
 477 LI_ stg_minusInt64  (StgInt64, StgInt64);
 478 LI_ stg_timesInt64  (StgInt64, StgInt64);
 479
 480 LW_ stg_and64  (StgWord64, StgWord64);
 481 LW_ stg_or64   (StgWord64, StgWord64);
 482 LW_ stg_xor64  (StgWord64, StgWord64);
 483 LW_ stg_not64  (StgWord64);
 484
 485 LW_ stg_shiftL64   (StgWord64, StgInt);
 486 LW_ stg_shiftRL64  (StgWord64, StgInt);
 487 LI_ stg_iShiftL64  (StgInt64, StgInt);
 488 LI_ stg_iShiftRL64 (StgInt64, StgInt);
 489 LI_ stg_iShiftRA64 (StgInt64, StgInt);
 490
 491 LI_ stg_intToInt64    (StgInt);
 492 I_ stg_int64ToInt     (StgInt64);
 493 LW_ stg_int64ToWord64 (StgInt64);
 494
 495 LW_ stg_wordToWord64  (StgWord);
 496 W_  stg_word64ToWord  (StgWord64);
 497 LI_ stg_word64ToInt64 (StgWord64);
 498 #endif
 499
 500 /* -----------------------------------------------------------------------------
 501    Array PrimOps.
 502    -------------------------------------------------------------------------- */
 503
 504 /* We cast to void* instead of StgChar* because this avoids a warning
 505  * about increasing the alignment requirements.
 506  */
 507 #define REAL_BYTE_ARR_CTS(a)   ((void *) (((StgArrWords *)(a))->payload))
 508 #define REAL_PTRS_ARR_CTS(a)   ((P_)   (((StgMutArrPtrs  *)(a))->payload))
 509
 510 #ifdef DEBUG
 511 #define BYTE_ARR_CTS(a)                           \
 512  ({ ASSERT(GET_INFO((StgArrWords *)(a)) == &ARR_WORDS_info);      \
 513     REAL_BYTE_ARR_CTS(a); })
 514 #define PTRS_ARR_CTS(a)                           \
 515  ({ ASSERT((GET_INFO((StgMutArrPtrs  *)(a)) == &MUT_ARR_PTRS_FROZEN_info)         \
 516         || (GET_INFO((StgMutArrPtrs  *)(a)) == &MUT_ARR_PTRS_info));  \
 517     REAL_PTRS_ARR_CTS(a); })
 518 #else
 519 #define BYTE_ARR_CTS(a)         REAL_BYTE_ARR_CTS(a)
 520 #define PTRS_ARR_CTS(a)         REAL_PTRS_ARR_CTS(a)
 521 #endif
 522
 523 extern I_ genSymZh(void);
 524 extern I_ resetGenSymZh(void);
 525
 526 /*--- everything except new*Array is done inline: */
 527
 528 #define sameMutableArrayzh(r,a,b)       r=(I_)((a)==(b))
 529 #define sameMutableByteArrayzh(r,a,b)   r=(I_)((a)==(b))
 530
 531 #define readArrayzh(r,a,i)       r=((PP_) PTRS_ARR_CTS(a))[(i)]
 532
 533 #define readCharArrayzh(r,a,i)   indexCharOffAddrzh(r,BYTE_ARR_CTS(a),i)
 534 #define readIntArrayzh(r,a,i)    indexIntOffAddrzh(r,BYTE_ARR_CTS(a),i)
 535 #define readWordArrayzh(r,a,i)   indexWordOffAddrzh(r,BYTE_ARR_CTS(a),i)
 536 #define readAddrArrayzh(r,a,i)   indexAddrOffAddrzh(r,BYTE_ARR_CTS(a),i)
 537 #define readFloatArrayzh(r,a,i)  indexFloatOffAddrzh(r,BYTE_ARR_CTS(a),i)
 538 #define readDoubleArrayzh(r,a,i) indexDoubleOffAddrzh(r,BYTE_ARR_CTS(a),i)
 539 #define readStablePtrArrayzh(r,a,i) indexStablePtrOffAddrzh(r,BYTE_ARR_CTS(a),i)
 540 #ifdef SUPPORT_LONG_LONGS
 541 #define readInt64Arrayzh(r,a,i)  indexInt64OffAddrzh(r,BYTE_ARR_CTS(a),i)
 542 #define readWord64Arrayzh(r,a,i) indexWord64OffAddrzh(r,BYTE_ARR_CTS(a),i)
 543 #endif
 544
 545 /* result ("r") arg ignored in write macros! */
 546 #define writeArrayzh(a,i,v)     ((PP_) PTRS_ARR_CTS(a))[(i)]=(v)
 547
 548 #define writeCharArrayzh(a,i,v)   ((C_ *)(BYTE_ARR_CTS(a)))[i] = (v)
 549 #define writeIntArrayzh(a,i,v)    ((I_ *)(BYTE_ARR_CTS(a)))[i] = (v)
 550 #define writeWordArrayzh(a,i,v)   ((W_ *)(BYTE_ARR_CTS(a)))[i] = (v)
 551 #define writeAddrArrayzh(a,i,v)   ((PP_)(BYTE_ARR_CTS(a)))[i] = (v)
 552 #define writeFloatArrayzh(a,i,v)  \
 553         ASSIGN_FLT((P_) (((StgFloat *)(BYTE_ARR_CTS(a))) + i),v)
 554 #define writeDoubleArrayzh(a,i,v) \
 555         ASSIGN_DBL((P_) (((StgDouble *)(BYTE_ARR_CTS(a))) + i),v)
 556 #define writeStablePtrArrayzh(a,i,v)      ((StgStablePtr *)(BYTE_ARR_CTS(a)))[i] = (v)
 557 #ifdef SUPPORT_LONG_LONGS
 558 #define writeInt64Arrayzh(a,i,v)  ((LI_ *)(BYTE_ARR_CTS(a)))[i] = (v)
 559 #define writeWord64Arrayzh(a,i,v) ((LW_ *)(BYTE_ARR_CTS(a)))[i] = (v)
 560 #endif
 561
 562 #define indexArrayzh(r,a,i)       r=((PP_) PTRS_ARR_CTS(a))[(i)]
 563
 564 #define indexCharArrayzh(r,a,i)   indexCharOffAddrzh(r,BYTE_ARR_CTS(a),i)
 565 #define indexIntArrayzh(r,a,i)    indexIntOffAddrzh(r,BYTE_ARR_CTS(a),i)
 566 #define indexWordArrayzh(r,a,i)   indexWordOffAddrzh(r,BYTE_ARR_CTS(a),i)
 567 #define indexAddrArrayzh(r,a,i)   indexAddrOffAddrzh(r,BYTE_ARR_CTS(a),i)
 568 #define indexFloatArrayzh(r,a,i)  indexFloatOffAddrzh(r,BYTE_ARR_CTS(a),i)
 569 #define indexDoubleArrayzh(r,a,i) indexDoubleOffAddrzh(r,BYTE_ARR_CTS(a),i)
 570 #define indexStablePtrArrayzh(r,a,i) indexStablePtrOffAddrzh(r,BYTE_ARR_CTS(a),i)
 571 #ifdef SUPPORT_LONG_LONGS
 572 #define indexInt64Arrayzh(r,a,i)  indexInt64OffAddrzh(r,BYTE_ARR_CTS(a),i)
 573 #define indexWord64Arrayzh(r,a,i) indexWord64OffAddrzh(r,BYTE_ARR_CTS(a),i)
 574 #endif
 575
 576 /* Freezing arrays-of-ptrs requires changing an info table, for the
 577    benefit of the generational collector.  It needs to scavenge mutable
 578    objects, even if they are in old space.  When they become immutable,
 579    they can be removed from this scavenge list.  */
 580
 581 #define unsafeFreezzeArrayzh(r,a)                                       \
 582         {                                                               \
 583         SET_INFO((StgClosure *)a,&MUT_ARR_PTRS_FROZEN_info);            \
 584         r = a;                                                          \
 585         }
 586
 587 #define unsafeFreezzeByteArrayzh(r,a)   r=(a)
 588
 589 EF_(unsafeThawArrayzh_fast);
 590
 591 #define sizzeofByteArrayzh(r,a) \
 592      r = (((StgArrWords *)(a))->words * sizeof(W_))
 593 #define sizzeofMutableByteArrayzh(r,a) \
 594      r = (((StgArrWords *)(a))->words * sizeof(W_))
 595
 596 /* and the out-of-line ones... */
 597
 598 EF_(newCharArrayzh_fast);
 599 EF_(newIntArrayzh_fast);
 600 EF_(newWordArrayzh_fast);
 601 EF_(newAddrArrayzh_fast);
 602 EF_(newFloatArrayzh_fast);
 603 EF_(newDoubleArrayzh_fast);
 604 EF_(newStablePtrArrayzh_fast);
 605 EF_(newArrayzh_fast);
 606
 607 /* encoding and decoding of floats/doubles. */
 608
 609 /* We only support IEEE floating point format */
 610 #include "ieee-flpt.h"
 611
 612 /* The decode operations are out-of-line because they need to allocate
 613  * a byte array.
 614  */
 615 #ifdef FLOATS_AS_DOUBLES
 616 #define decodeFloatzh_fast decodeDoublezh_fast
 617 #else
 618 EF_(decodeFloatzh_fast);
 619 #endif
 620
 621 EF_(decodeDoublezh_fast);
 622
 623 /* grimy low-level support functions defined in StgPrimFloat.c */
 624
 625 extern StgDouble __encodeDouble (I_ size, StgByteArray arr, I_ e);
 626 extern StgDouble __int_encodeDouble (I_ j, I_ e);
 627 #ifndef FLOATS_AS_DOUBLES
 628 extern StgFloat  __encodeFloat (I_ size, StgByteArray arr, I_ e);
 629 extern StgFloat  __int_encodeFloat (I_ j, I_ e);
 630 #endif
 631 extern void      __decodeDouble (MP_INT *man, I_ *_exp, StgDouble dbl);
 632 extern void      __decodeFloat  (MP_INT *man, I_ *_exp, StgFloat flt);
 633 extern StgInt    isDoubleNaN(StgDouble d);
 634 extern StgInt    isDoubleInfinite(StgDouble d);
 635 extern StgInt    isDoubleDenormalized(StgDouble d);
 636 extern StgInt    isDoubleNegativeZero(StgDouble d);
 637 extern StgInt    isFloatNaN(StgFloat f);
 638 extern StgInt    isFloatInfinite(StgFloat f);
 639 extern StgInt    isFloatDenormalized(StgFloat f);
 640 extern StgInt    isFloatNegativeZero(StgFloat f);
 641
 642 /* -----------------------------------------------------------------------------
 643    Mutable variables
 644
 645    newMutVar is out of line.
 646    -------------------------------------------------------------------------- */
 647
 648 EF_(newMutVarzh_fast);
 649
 650 #define readMutVarzh(r,a)        r=(P_)(((StgMutVar *)(a))->var)
 651 #define writeMutVarzh(a,v)       (P_)(((StgMutVar *)(a))->var)=(v)
 652 #define sameMutVarzh(r,a,b)      r=(I_)((a)==(b))
 653
 654 /* -----------------------------------------------------------------------------
 655    MVar PrimOps.
 656
 657    All out of line, because they either allocate or may block.
 658    -------------------------------------------------------------------------- */
 659 #define sameMVarzh(r,a,b)        r=(I_)((a)==(b))
 660
 661 /* Assume external decl of EMPTY_MVAR_info is in scope by now */
 662 #define isEmptyMVarzh(r,a)       r=(I_)((GET_INFO((StgMVar*)(a))) == &EMPTY_MVAR_info )
 663 EF_(newMVarzh_fast);
 664 EF_(takeMVarzh_fast);
 665 EF_(tryTakeMVarzh_fast);
 666 EF_(putMVarzh_fast);
 667
 668
 669 /* -----------------------------------------------------------------------------
 670    Delay/Wait PrimOps
 671    -------------------------------------------------------------------------- */
 672
 673 EF_(waitReadzh_fast);
 674 EF_(waitWritezh_fast);
 675 EF_(delayzh_fast);
 676
 677 /* -----------------------------------------------------------------------------
 678    Primitive I/O, error-handling PrimOps
 679    -------------------------------------------------------------------------- */
 680
 681 EF_(catchzh_fast);
 682 EF_(raisezh_fast);
 683
 684 extern void stg_exit(I_ n)  __attribute__ ((noreturn));
 685
 686 /* -----------------------------------------------------------------------------
 687    Stable Name / Stable Pointer  PrimOps
 688    -------------------------------------------------------------------------- */
 689
 690 #ifndef PAR
 691
 692 EF_(makeStableNamezh_fast);
 693
 694 #define stableNameToIntzh(r,s)   (r = ((StgStableName *)s)->sn)
 695
 696 #define eqStableNamezh(r,sn1,sn2)                                       \
 697     (r = (((StgStableName *)sn1)->sn == ((StgStableName *)sn2)->sn))
 698
 699 #define makeStablePtrzh(r,a) \
 700    r = RET_STGCALL1(StgStablePtr,getStablePtr,a)
 701
 702 #define deRefStablePtrzh(r,sp) do {             \
 703   ASSERT(stable_ptr_table[stgCast(StgWord,sp) & ~STABLEPTR_WEIGHT_MASK].weight > 0);    \
 704   r = stable_ptr_table[stgCast(StgWord,sp) & ~STABLEPTR_WEIGHT_MASK].addr; \
 705 } while (0);
 706
 707 #define eqStablePtrzh(r,sp1,sp2) \
 708     (r = ((stgCast(StgWord,sp1) & ~STABLEPTR_WEIGHT_MASK) == (stgCast(StgWord,sp2) & ~STABLEPTR_WEIGHT_MASK)))
 709
 710 #endif
 711
 712 /* -----------------------------------------------------------------------------
 713    Concurrency/Exception PrimOps.
 714    -------------------------------------------------------------------------- */
 715
 716 EF_(forkzh_fast);
 717 EF_(yieldzh_fast);
 718 EF_(killThreadzh_fast);
 719 EF_(seqzh_fast);
 720 EF_(blockAsyncExceptionszh_fast);
 721 EF_(unblockAsyncExceptionszh_fast);
 722
 723 #define myThreadIdzh(t) (t = CurrentTSO)
 724
 725 extern int cmp_thread(const StgTSO *tso1, const StgTSO *tso2);
 726
 727 /* ------------------------------------------------------------------------
 728    Parallel PrimOps
 729
 730    A par in the Haskell code is ultimately translated to a parzh macro
 731    (with a case wrapped around it to guarantee that the macro is actually
 732     executed; see compiler/prelude/PrimOps.lhs)
 733    In GUM and SMP we only add a pointer to the spark pool.
 734    In GranSim we call an RTS fct, forwarding additional parameters which
 735    supply info on granularity of the computation, size of the result value
 736    and the degree of parallelism in the sparked expression.
 737    ---------------------------------------------------------------------- */
 738
 739 #if defined(GRAN)
 740 //@cindex _par_
 741 #define parzh(r,node)             PAR(r,node,1,0,0,0,0,0)
 742
 743 //@cindex _parAt_
 744 #define parAtzh(r,node,where,identifier,gran_info,size_info,par_info,rest) \
 745         parAT(r,node,where,identifier,gran_info,size_info,par_info,rest,1)
 746
 747 //@cindex _parAtAbs_
 748 #define parAtAbszh(r,node,proc,identifier,gran_info,size_info,par_info,rest) \
 749         parAT(r,node,proc,identifier,gran_info,size_info,par_info,rest,2)
 750
 751 //@cindex _parAtRel_
 752 #define parAtRelzh(r,node,proc,identifier,gran_info,size_info,par_info,rest) \
 753         parAT(r,node,proc,identifier,gran_info,size_info,par_info,rest,3)
 754
 755 //@cindex _parAtForNow_
 756 #define parAtForNowzh(r,node,where,identifier,gran_info,size_info,par_info,rest)        \
 757         parAT(r,node,where,identifier,gran_info,size_info,par_info,rest,0)
 758
 759 #define parAT(r,node,where,identifier,gran_info,size_info,par_info,rest,local)  \
 760 {                                                               \
 761   if (closure_SHOULD_SPARK((StgClosure*)node)) {                \
 762     rtsSparkQ result;                                           \
 763     PEs p;                                                      \
 764                                                                 \
 765     STGCALL6(newSpark, node,identifier,gran_info,size_info,par_info,local); \
 766     switch (local) {                                                        \
 767       case 2: p = where;  /* parAtAbs means absolute PE no. expected */     \
 768               break;                                                        \
 769       case 3: p = CurrentProc+where; /* parAtRel means rel PE no. expected */\
 770               break;                                                        \
 771       default: p = where_is(where); /* parAt means closure expected */      \
 772               break;                                                        \
 773     }                                                                       \
 774     /* update GranSim state according to this spark */                      \
 775     STGCALL3(GranSimSparkAtAbs, result, (I_)p, identifier);                 \
 776   }                                                                         \
 777 }
 778
 779 //@cindex _parLocal_
 780 #define parLocalzh(r,node,identifier,gran_info,size_info,par_info,rest) \
 781         PAR(r,node,rest,identifier,gran_info,size_info,par_info,1)
 782
 783 //@cindex _parGlobal_
 784 #define parGlobalzh(r,node,identifier,gran_info,size_info,par_info,rest) \
 785         PAR(r,node,rest,identifier,gran_info,size_info,par_info,0)
 786
 787 #define PAR(r,node,rest,identifier,gran_info,size_info,par_info,local) \
 788 {                                                                        \
 789   if (closure_SHOULD_SPARK((StgClosure*)node)) {                         \
 790     rtsSpark *result;                                                    \
 791     result = RET_STGCALL6(rtsSpark*, newSpark,                           \
 792                           node,identifier,gran_info,size_info,par_info,local);\
 793     STGCALL1(add_to_spark_queue,result);                                \
 794     STGCALL2(GranSimSpark, local,(P_)node);                             \
 795   }                                                                     \
 796 }
 797
 798 #define copyablezh(r,node)                              \
 799   /* copyable not yet implemented!! */
 800
 801 #define noFollowzh(r,node)                              \
 802   /* noFollow not yet implemented!! */
 803
 804 #elif defined(SMP) || defined(PAR)
 805
 806 #define parzh(r,node)                                   \
 807 {                                                       \
 808   extern unsigned int context_switch;                   \
 809   if (closure_SHOULD_SPARK((StgClosure *)node) &&       \
 810       SparkTl < SparkLim) {                             \
 811     *SparkTl++ = (StgClosure *)(node);                  \
 812   }                                                     \
 813   r = context_switch = 1;                               \
 814 }
 815 #else /* !GRAN && !SMP && !PAR */
 816 #define parzh(r,node) r = 1
 817 #endif
 818
 819 /* -----------------------------------------------------------------------------
 820    Pointer equality
 821    -------------------------------------------------------------------------- */
 822
 823 /* warning: extremely non-referentially transparent, need to hide in
 824    an appropriate monad.
 825
 826    ToDo: follow indirections.
 827 */
 828
 829 #define reallyUnsafePtrEqualityzh(r,a,b) r=((StgPtr)(a) == (StgPtr)(b))
 830
 831 /* -----------------------------------------------------------------------------
 832    Weak Pointer PrimOps.
 833    -------------------------------------------------------------------------- */
 834
 835 #ifndef PAR
 836
 837 EF_(mkWeakzh_fast);
 838 EF_(finalizzeWeakzh_fast);
 839
 840 #define deRefWeakzh(code,val,w)                         \
 841   if (((StgWeak *)w)->header.info == &WEAK_info) {      \
 842         code = 1;                                       \
 843         val = (P_)((StgWeak *)w)->value;                \
 844   } else {                                              \
 845         code = 0;                                       \
 846         val = (P_)w;                                    \
 847   }
 848
 849 #define sameWeakzh(w1,w2)  ((w1)==(w2))
 850
 851 #endif
 852
 853 /* -----------------------------------------------------------------------------
 854    Foreign Object PrimOps.
 855    -------------------------------------------------------------------------- */
 856
 857 #ifndef PAR
 858
 859 #define ForeignObj_CLOSURE_DATA(c)  (((StgForeignObj *)c)->data)
 860
 861 EF_(mkForeignObjzh_fast);
 862
 863 #define writeForeignObjzh(res,datum) \
 864    (ForeignObj_CLOSURE_DATA(res) = (P_)(datum))
 865
 866 #define eqForeignObj(f1,f2)  ((f1)==(f2))
 867
 868 #define indexCharOffForeignObjzh(r,fo,i)   indexCharOffAddrzh(r,ForeignObj_CLOSURE_DATA(fo),i)
 869 #define indexIntOffForeignObjzh(r,fo,i)    indexIntOffAddrzh(r,ForeignObj_CLOSURE_DATA(fo),i)
 870 #define indexWordOffForeignObjzh(r,fo,i)   indexWordOffAddrzh(r,ForeignObj_CLOSURE_DATA(fo),i)
 871 #define indexAddrOffForeignObjzh(r,fo,i)   indexAddrOffAddrzh(r,ForeignObj_CLOSURE_DATA(fo),i)
 872 #define indexFloatOffForeignObjzh(r,fo,i)  indexFloatOffAddrzh(r,ForeignObj_CLOSURE_DATA(fo),i)
 873 #define indexDoubleOffForeignObjzh(r,fo,i) indexDoubleOffAddrzh(r,ForeignObj_CLOSURE_DATA(fo),i)
 874 #define indexStablePtrOffForeignObjzh(r,fo,i)  indexStablePtrOffAddrzh(r,ForeignObj_CLOSURE_DATA(fo),i)
 875 #ifdef SUPPORT_LONG_LONGS
 876 #define indexInt64OffForeignObjzh(r,fo,i)  indexInt64OffAddrzh(r,ForeignObj_CLOSURE_DATA(fo),i)
 877 #define indexWord64OffForeignObjzh(r,fo,i) indexWord64OffAddrzh(r,ForeignObj_CLOSURE_DATA(fo),i)
 878 #endif
 879
 880 #endif
 881
 882 /* -----------------------------------------------------------------------------
 883    Constructor tags
 884    -------------------------------------------------------------------------- */
 885
 886 #define dataToTagzh(r,a)  r=(GET_TAG(((StgClosure *)a)->header.info))
 887 /*  tagToEnum# is handled directly by the code generator. */
 888
 889 /* -----------------------------------------------------------------------------
 890    Signal processing.  Not really primops, but called directly from
 891    Haskell.
 892    -------------------------------------------------------------------------- */
 893
 894 #define STG_SIG_DFL  (-1)
 895 #define STG_SIG_IGN  (-2)
 896 #define STG_SIG_ERR  (-3)
 897 #define STG_SIG_HAN  (-4)
 898
 899 extern StgInt sig_install (StgInt, StgInt, StgStablePtr, sigset_t *);
 900 #define stg_sig_default(sig,mask) sig_install(sig,STG_SIG_DFL,0,(sigset_t *)mask)
 901 #define stg_sig_ignore(sig,mask) sig_install(sig,STG_SIG_IGN,0,(sigset_t *)mask)
 902 #define stg_sig_catch(sig,ptr,mask) sig_install(sig,STG_SIG_HAN,ptr,(sigset_t *)mask)
 903
 904 #endif /* PRIMOPS_H */