ghc/includes/PrimOps.h

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