ghc/includes/PrimOps.h

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