ghc/includes/PrimOps.h

   1 /* -----------------------------------------------------------------------------
   2  * $Id: PrimOps.h,v 1.9 1999/01/23 17:48:23 sof 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 ZdZeZh(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 ZdZeZhZh(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 ZdZh(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
 114 #define subWithCarryZh(r,c,a,b)                 \
 115 { long_long_u z;                                \
 116   z.l = a + b;                                  \
 117   r = z.i[R];                                   \
 118   c = z.i[C];                                   \
 119 }
 120
 121 #define mulWithCarryZh(r,c,a,b)                 \
 122 { long_long_u z;                                \
 123   z.l = a * b;                                  \
 124   r = z.i[R];                                   \
 125   c = z.i[C];                                   \
 126 }
 127
 128 /* -----------------------------------------------------------------------------
 129    Word PrimOps.
 130    -------------------------------------------------------------------------- */
 131
 132 #define quotWordZh(r,a,b)       r=((W_)a)/((W_)b)
 133 #define remWordZh(r,a,b)        r=((W_)a)%((W_)b)
 134
 135 #define andZh(r,a,b)            r=(a)&(b)
 136 #define orZh(r,a,b)             r=(a)|(b)
 137 #define xorZh(r,a,b)            r=(a)^(b)
 138 #define notZh(r,a)              r=~(a)
 139
 140 #define shiftLZh(r,a,b)         r=(a)<<(b)
 141 #define shiftRLZh(r,a,b)        r=(a)>>(b)
 142 #define iShiftLZh(r,a,b)        r=(a)<<(b)
 143 /* Right shifting of signed quantities is not portable in C, so
 144    the behaviour you'll get from using these primops depends
 145    on the whatever your C compiler is doing. ToDo: fix/document. -- sof 8/98
 146 */
 147 #define iShiftRAZh(r,a,b)       r=(a)>>(b)
 148 #define iShiftRLZh(r,a,b)       r=(a)>>(b)
 149
 150 #define int2WordZh(r,a)         r=(W_)(a)
 151 #define word2IntZh(r,a)         r=(I_)(a)
 152
 153 /* -----------------------------------------------------------------------------
 154    Addr PrimOps.
 155    -------------------------------------------------------------------------- */
 156
 157 #define int2AddrZh(r,a)         r=(A_)(a)
 158 #define addr2IntZh(r,a)         r=(I_)(a)
 159
 160 #define indexCharOffAddrZh(r,a,i)   r= ((C_ *)(a))[i]
 161 #define indexIntOffAddrZh(r,a,i)    r= ((I_ *)(a))[i]
 162 #define indexAddrOffAddrZh(r,a,i)   r= ((PP_)(a))[i]
 163 #define indexFloatOffAddrZh(r,a,i)  r= PK_FLT((P_) (((StgFloat *)(a)) + i))
 164 #define indexDoubleOffAddrZh(r,a,i) r= PK_DBL((P_) (((StgDouble *)(a)) + i))
 165 #define indexStablePtrOffAddrZh(r,a,i)    r= ((StgStablePtr *)(a))[i]
 166 #ifdef SUPPORT_LONG_LONGS
 167 #define indexInt64OffAddrZh(r,a,i)  r= ((LI_ *)(a))[i]
 168 #define indexWord64OffAddrZh(r,a,i) r= ((LW_ *)(a))[i]
 169 #endif
 170
 171 #define writeCharOffAddrZh(a,i,v)       ((C_ *)(a))[i] = (v)
 172 #define writeIntOffAddrZh(a,i,v)        ((I_ *)(a))[i] = (v)
 173 #define writeWordOffAddrZh(a,i,v)       ((W_ *)(a))[i] = (v)
 174 #define writeAddrOffAddrZh(a,i,v)       ((PP_)(a))[i] = (v)
 175 #define writeForeignObjOffAddrZh(a,i,v) ((PP_)(a))[i] = ForeignObj_CLOSURE_DATA(v)
 176 #define writeFloatOffAddrZh(a,i,v)      ASSIGN_FLT((P_) (((StgFloat *)(a)) + i),v)
 177 #define writeDoubleOffAddrZh(a,i,v)     ASSIGN_DBL((P_) (((StgDouble *)(a)) + i),v)
 178 #define writeStablePtrOffAddrZh(a,i,v)  ((StgStablePtr *)(a))[i] = (v)
 179 #ifdef SUPPORT_LONG_LONGS
 180 #define writeInt64OffAddrZh(a,i,v)   ((LI_ *)(a))[i] = (v)
 181 #define writeWord64OffAddrZh(a,i,v)  ((LW_ *)(a))[i] = (v)
 182 #endif
 183
 184 /* -----------------------------------------------------------------------------
 185    Float PrimOps.
 186    -------------------------------------------------------------------------- */
 187
 188 #define plusFloatZh(r,a,b)   r=(a)+(b)
 189 #define minusFloatZh(r,a,b)  r=(a)-(b)
 190 #define timesFloatZh(r,a,b)  r=(a)*(b)
 191 #define divideFloatZh(r,a,b) r=(a)/(b)
 192 #define negateFloatZh(r,a)   r=-(a)
 193
 194 #define int2FloatZh(r,a)     r=(StgFloat)(a)
 195 #define float2IntZh(r,a)     r=(I_)(a)
 196
 197 #define expFloatZh(r,a)      r=(StgFloat) RET_PRIM_STGCALL1(StgDouble,exp,a)
 198 #define logFloatZh(r,a)      r=(StgFloat) RET_PRIM_STGCALL1(StgDouble,log,a)
 199 #define sqrtFloatZh(r,a)     r=(StgFloat) RET_PRIM_STGCALL1(StgDouble,sqrt,a)
 200 #define sinFloatZh(r,a)      r=(StgFloat) RET_PRIM_STGCALL1(StgDouble,sin,a)
 201 #define cosFloatZh(r,a)      r=(StgFloat) RET_PRIM_STGCALL1(StgDouble,cos,a)
 202 #define tanFloatZh(r,a)      r=(StgFloat) RET_PRIM_STGCALL1(StgDouble,tan,a)
 203 #define asinFloatZh(r,a)     r=(StgFloat) RET_PRIM_STGCALL1(StgDouble,asin,a)
 204 #define acosFloatZh(r,a)     r=(StgFloat) RET_PRIM_STGCALL1(StgDouble,acos,a)
 205 #define atanFloatZh(r,a)     r=(StgFloat) RET_PRIM_STGCALL1(StgDouble,atan,a)
 206 #define sinhFloatZh(r,a)     r=(StgFloat) RET_PRIM_STGCALL1(StgDouble,sinh,a)
 207 #define coshFloatZh(r,a)     r=(StgFloat) RET_PRIM_STGCALL1(StgDouble,cosh,a)
 208 #define tanhFloatZh(r,a)     r=(StgFloat) RET_PRIM_STGCALL1(StgDouble,tanh,a)
 209 #define powerFloatZh(r,a,b)  r=(StgFloat) RET_PRIM_STGCALL2(StgDouble,pow,a,b)
 210
 211 /* -----------------------------------------------------------------------------
 212    Double PrimOps.
 213    -------------------------------------------------------------------------- */
 214
 215 #define ZpZhZh(r,a,b)        r=(a)+(b)
 216 #define ZmZhZh(r,a,b)        r=(a)-(b)
 217 #define ZtZhZh(r,a,b)        r=(a)*(b)
 218 #define ZdZhZh(r,a,b)        r=(a)/(b)
 219 #define negateDoubleZh(r,a)  r=-(a)
 220
 221 #define int2DoubleZh(r,a)    r=(StgDouble)(a)
 222 #define double2IntZh(r,a)    r=(I_)(a)
 223
 224 #define float2DoubleZh(r,a)  r=(StgDouble)(a)
 225 #define double2FloatZh(r,a)  r=(StgFloat)(a)
 226
 227 #define expDoubleZh(r,a)     r=(StgDouble) RET_PRIM_STGCALL1(StgDouble,exp,a)
 228 #define logDoubleZh(r,a)     r=(StgDouble) RET_PRIM_STGCALL1(StgDouble,log,a)
 229 #define sqrtDoubleZh(r,a)    r=(StgDouble) RET_PRIM_STGCALL1(StgDouble,sqrt,a)
 230 #define sinDoubleZh(r,a)     r=(StgDouble) RET_PRIM_STGCALL1(StgDouble,sin,a)
 231 #define cosDoubleZh(r,a)     r=(StgDouble) RET_PRIM_STGCALL1(StgDouble,cos,a)
 232 #define tanDoubleZh(r,a)     r=(StgDouble) RET_PRIM_STGCALL1(StgDouble,tan,a)
 233 #define asinDoubleZh(r,a)    r=(StgDouble) RET_PRIM_STGCALL1(StgDouble,asin,a)
 234 #define acosDoubleZh(r,a)    r=(StgDouble) RET_PRIM_STGCALL1(StgDouble,acos,a)
 235 #define atanDoubleZh(r,a)    r=(StgDouble) RET_PRIM_STGCALL1(StgDouble,atan,a)
 236 #define sinhDoubleZh(r,a)    r=(StgDouble) RET_PRIM_STGCALL1(StgDouble,sinh,a)
 237 #define coshDoubleZh(r,a)    r=(StgDouble) RET_PRIM_STGCALL1(StgDouble,cosh,a)
 238 #define tanhDoubleZh(r,a)    r=(StgDouble) RET_PRIM_STGCALL1(StgDouble,tanh,a)
 239 /* Power: **## */
 240 #define ZtZtZhZh(r,a,b) r=(StgDouble) RET_PRIM_STGCALL2(StgDouble,pow,a,b)
 241
 242 /* -----------------------------------------------------------------------------
 243    Integer PrimOps.
 244    -------------------------------------------------------------------------- */
 245
 246 /* We can do integer2Int and cmpInteger inline, since they don't need
 247  * to allocate any memory.
 248  */
 249
 250 #define integer2IntZh(r, aa,sa,da)                                      \
 251 { MP_INT arg;                                                           \
 252                                                                         \
 253   arg._mp_alloc = (aa);                                                 \
 254   arg._mp_size  = (sa);                                                 \
 255   arg._mp_d     = (unsigned long int *) (BYTE_ARR_CTS(da));             \
 256                                                                         \
 257   (r) = RET_PRIM_STGCALL1(I_,mpz_get_si,&arg);                          \
 258 }
 259
 260 #define integer2WordZh(r, aa,sa,da)                                     \
 261 { MP_INT arg;                                                           \
 262                                                                         \
 263   arg._mp_alloc = (aa);                                                 \
 264   arg._mp_size  = (sa);                                                 \
 265   arg._mp_d     = (unsigned long int *) (BYTE_ARR_CTS(da));             \
 266                                                                         \
 267   (r) = RET_PRIM_STGCALL1(I_,mpz_get_ui,&arg);                          \
 268 }
 269
 270 #define cmpIntegerZh(r, a1,s1,d1, a2,s2,d2)                             \
 271 { MP_INT arg1;                                                          \
 272   MP_INT arg2;                                                          \
 273                                                                         \
 274   arg1._mp_alloc= (a1);                                                 \
 275   arg1._mp_size = (s1);                                                 \
 276   arg1._mp_d    = (unsigned long int *) (BYTE_ARR_CTS(d1));             \
 277   arg2._mp_alloc= (a2);                                                 \
 278   arg2._mp_size = (s2);                                                 \
 279   arg2._mp_d    = (unsigned long int *) (BYTE_ARR_CTS(d2));             \
 280                                                                         \
 281   (r) = RET_PRIM_STGCALL2(I_,mpz_cmp,&arg1,&arg2);                      \
 282 }
 283
 284 /* A glorious hack: calling mpz_neg would entail allocation and
 285  * copying, but by looking at what mpz_neg actually does, we can
 286  * derive a better version:
 287  */
 288
 289 #define negateIntegerZh(ra, rs, rd, a, s, d)                            \
 290 {                                                                       \
 291   (ra) = (a);                                                           \
 292   (rs) = -(s);                                                          \
 293   (rd) = d;                                                             \
 294 }
 295
 296 /* The rest are all out-of-line: -------- */
 297
 298 /* Integer arithmetic */
 299 EF_(plusIntegerZh_fast);
 300 EF_(minusIntegerZh_fast);
 301 EF_(timesIntegerZh_fast);
 302 EF_(gcdIntegerZh_fast);
 303 EF_(quotRemIntegerZh_fast);
 304 EF_(divModIntegerZh_fast);
 305
 306 /* Conversions */
 307 EF_(int2IntegerZh_fast);
 308 EF_(word2IntegerZh_fast);
 309 EF_(addr2IntegerZh_fast);
 310
 311 /* Floating-point encodings/decodings */
 312 EF_(encodeFloatZh_fast);
 313 EF_(decodeFloatZh_fast);
 314
 315 EF_(encodeDoubleZh_fast);
 316 EF_(decodeDoubleZh_fast);
 317
 318 /* -----------------------------------------------------------------------------
 319    Word64 PrimOps.
 320    -------------------------------------------------------------------------- */
 321
 322 #ifdef SUPPORT_LONG_LONGS
 323
 324 #define integerToWord64Zh(r, aa,sa,da)                                  \
 325 { unsigned long int* d;                                                 \
 326   StgNat64 res;                                                         \
 327                                                                         \
 328   d             = (unsigned long int *) (BYTE_ARR_CTS(da));             \
 329   if ( (aa) == 0 ) {                                                    \
 330      res = (LW_)0;                                                      \
 331   } else if ( (aa) == 1) {                                              \
 332      res = (LW_)d[0];                                                   \
 333   } else {                                                              \
 334      res = (LW_)d[0] + (LW_)d[1] * 0x100000000ULL;                      \
 335   }                                                                     \
 336   (r) = res;                                                            \
 337 }
 338
 339 #define integerToInt64Zh(r, aa,sa,da)                                   \
 340 { unsigned long int* d;                                                 \
 341   StgInt64 res;                                                         \
 342                                                                         \
 343   d             = (unsigned long int *) (BYTE_ARR_CTS(da));             \
 344   if ( (aa) == 0 ) {                                                    \
 345      res = (LI_)0;                                                      \
 346   } else if ( (aa) == 1) {                                              \
 347      res = (LI_)d[0];                                                   \
 348   } else {                                                              \
 349      res = (LI_)d[0] + (LI_)d[1] * 0x100000000LL;                       \
 350      if ( sa < 0 ) {                                                    \
 351            res = (LI_)-res;                                             \
 352      }                                                                  \
 353   }                                                                     \
 354   (r) = res;                                                            \
 355 }
 356
 357 /* Conversions */
 358 EF_(int64ToIntegerZh_fast);
 359 EF_(word64ToIntegerZh_fast);
 360
 361 /* The rest are (way!) out of line, implemented via C entry points.
 362  */
 363 I_ stg_gtWord64 (StgNat64, StgNat64);
 364 I_ stg_geWord64 (StgNat64, StgNat64);
 365 I_ stg_eqWord64 (StgNat64, StgNat64);
 366 I_ stg_neWord64 (StgNat64, StgNat64);
 367 I_ stg_ltWord64 (StgNat64, StgNat64);
 368 I_ stg_leWord64 (StgNat64, StgNat64);
 369
 370 I_ stg_gtInt64 (StgInt64, StgInt64);
 371 I_ stg_geInt64 (StgInt64, StgInt64);
 372 I_ stg_eqInt64 (StgInt64, StgInt64);
 373 I_ stg_neInt64 (StgInt64, StgInt64);
 374 I_ stg_ltInt64 (StgInt64, StgInt64);
 375 I_ stg_leInt64 (StgInt64, StgInt64);
 376
 377 LW_ stg_remWord64  (StgNat64, StgNat64);
 378 LW_ stg_quotWord64 (StgNat64, StgNat64);
 379
 380 LI_ stg_remInt64    (StgInt64, StgInt64);
 381 LI_ stg_quotInt64   (StgInt64, StgInt64);
 382 LI_ stg_negateInt64 (StgInt64);
 383 LI_ stg_plusInt64   (StgInt64, StgInt64);
 384 LI_ stg_minusInt64  (StgInt64, StgInt64);
 385 LI_ stg_timesInt64  (StgInt64, StgInt64);
 386
 387 LW_ stg_and64  (StgNat64, StgNat64);
 388 LW_ stg_or64   (StgNat64, StgNat64);
 389 LW_ stg_xor64  (StgNat64, StgNat64);
 390 LW_ stg_not64  (StgNat64);
 391
 392 LW_ stg_shiftL64   (StgNat64, StgInt);
 393 LW_ stg_shiftRL64  (StgNat64, StgInt);
 394 LI_ stg_iShiftL64  (StgInt64, StgInt);
 395 LI_ stg_iShiftRL64 (StgInt64, StgInt);
 396 LI_ stg_iShiftRA64 (StgInt64, StgInt);
 397
 398 LI_ stg_intToInt64    (StgInt);
 399 I_ stg_int64ToInt     (StgInt64);
 400 LW_ stg_int64ToWord64 (StgInt64);
 401
 402 LW_ stg_wordToWord64  (StgWord);
 403 W_  stg_word64ToWord  (StgNat64);
 404 LI_ stg_word64ToInt64 (StgNat64);
 405 #endif
 406
 407 /* -----------------------------------------------------------------------------
 408    Array PrimOps.
 409    -------------------------------------------------------------------------- */
 410
 411 /* We cast to void* instead of StgChar* because this avoids a warning
 412  * about increasing the alignment requirements.
 413  */
 414 #define REAL_BYTE_ARR_CTS(a)   ((void *) (((StgArrWords *)(a))->payload))
 415 #define REAL_PTRS_ARR_CTS(a)   ((P_)   (((StgMutArrPtrs  *)(a))->payload))
 416
 417 #ifdef DEBUG
 418 #define BYTE_ARR_CTS(a)                           \
 419  ({ ASSERT((GET_INFO(a) == &ARR_WORDS_info)       \
 420         || (GET_INFO(a) == &MUT_ARR_WORDS_info)); \
 421     REAL_BYTE_ARR_CTS(a); })
 422 #define PTRS_ARR_CTS(a)                           \
 423  ({ ASSERT((GET_INFO(a) == &ARR_PTRS_info)        \
 424         || (GET_INFO(a) == &MUT_ARR_PTRS_info));  \
 425     REAL_PTRS_ARR_CTS(a); })
 426 #else
 427 #define BYTE_ARR_CTS(a)         REAL_BYTE_ARR_CTS(a)
 428 #define PTRS_ARR_CTS(a)         REAL_PTRS_ARR_CTS(a)
 429 #endif
 430
 431 extern I_ genSymZh(void);
 432 extern I_ resetGenSymZh(void);
 433
 434 /*--- everything except new*Array is done inline: */
 435
 436 #define sameMutableArrayZh(r,a,b)       r=(I_)((a)==(b))
 437 #define sameMutableByteArrayZh(r,a,b)   r=(I_)((a)==(b))
 438
 439 #define readArrayZh(r,a,i)       r=((PP_) PTRS_ARR_CTS(a))[(i)]
 440
 441 #define readCharArrayZh(r,a,i)   indexCharOffAddrZh(r,BYTE_ARR_CTS(a),i)
 442 #define readIntArrayZh(r,a,i)    indexIntOffAddrZh(r,BYTE_ARR_CTS(a),i)
 443 #define readWordArrayZh(r,a,i)   indexWordOffAddrZh(r,BYTE_ARR_CTS(a),i)
 444 #define readAddrArrayZh(r,a,i)   indexAddrOffAddrZh(r,BYTE_ARR_CTS(a),i)
 445 #define readFloatArrayZh(r,a,i)  indexFloatOffAddrZh(r,BYTE_ARR_CTS(a),i)
 446 #define readDoubleArrayZh(r,a,i) indexDoubleOffAddrZh(r,BYTE_ARR_CTS(a),i)
 447 #define readStablePtrArrayZh(r,a,i) indexStablePtrOffAddrZh(r,BYTE_ARR_CTS(a),i)
 448 #ifdef SUPPORT_LONG_LONGS
 449 #define readInt64ArrayZh(r,a,i)  indexInt64OffAddrZh(r,BYTE_ARR_CTS(a),i)
 450 #define readWord64ArrayZh(r,a,i) indexWord64OffAddrZh(r,BYTE_ARR_CTS(a),i)
 451 #endif
 452
 453 /* result ("r") arg ignored in write macros! */
 454 #define writeArrayZh(a,i,v)     ((PP_) PTRS_ARR_CTS(a))[(i)]=(v)
 455
 456 #define writeCharArrayZh(a,i,v)   ((C_ *)(BYTE_ARR_CTS(a)))[i] = (v)
 457 #define writeIntArrayZh(a,i,v)    ((I_ *)(BYTE_ARR_CTS(a)))[i] = (v)
 458 #define writeWordArrayZh(a,i,v)   ((W_ *)(BYTE_ARR_CTS(a)))[i] = (v)
 459 #define writeAddrArrayZh(a,i,v)   ((PP_)(BYTE_ARR_CTS(a)))[i] = (v)
 460 #define writeFloatArrayZh(a,i,v)  \
 461         ASSIGN_FLT((P_) (((StgFloat *)(BYTE_ARR_CTS(a))) + i),v)
 462 #define writeDoubleArrayZh(a,i,v) \
 463         ASSIGN_DBL((P_) (((StgDouble *)(BYTE_ARR_CTS(a))) + i),v)
 464 #define writeStablePtrArrayZh(a,i,v)      ((StgStablePtr *)(BYTE_ARR_CTS(a)))[i] = (v)
 465 #ifdef SUPPORT_LONG_LONGS
 466 #define writeInt64ArrayZh(a,i,v)  ((LI_ *)(BYTE_ARR_CTS(a)))[i] = (v)
 467 #define writeWord64ArrayZh(a,i,v) ((LW_ *)(BYTE_ARR_CTS(a)))[i] = (v)
 468 #endif
 469
 470 #define indexArrayZh(r,a,i)       r=((PP_) PTRS_ARR_CTS(a))[(i)]
 471
 472 #define indexCharArrayZh(r,a,i)   indexCharOffAddrZh(r,BYTE_ARR_CTS(a),i)
 473 #define indexIntArrayZh(r,a,i)    indexIntOffAddrZh(r,BYTE_ARR_CTS(a),i)
 474 #define indexWordArrayZh(r,a,i)   indexWordOffAddrZh(r,BYTE_ARR_CTS(a),i)
 475 #define indexAddrArrayZh(r,a,i)   indexAddrOffAddrZh(r,BYTE_ARR_CTS(a),i)
 476 #define indexFloatArrayZh(r,a,i)  indexFloatOffAddrZh(r,BYTE_ARR_CTS(a),i)
 477 #define indexDoubleArrayZh(r,a,i) indexDoubleOffAddrZh(r,BYTE_ARR_CTS(a),i)
 478 #define indexStablePtrArrayZh(r,a,i) indexStablePtrOffAddrZh(r,BYTE_ARR_CTS(a),i)
 479 #ifdef SUPPORT_LONG_LONGS
 480 #define indexInt64ArrayZh(r,a,i)  indexInt64OffAddrZh(r,BYTE_ARR_CTS(a),i)
 481 #define indexWord64ArrayZh(r,a,i) indexWord64OffAddrZh(r,BYTE_ARR_CTS(a),i)
 482 #endif
 483
 484 #define indexCharOffForeignObjZh(r,fo,i)   indexCharOffAddrZh(r,ForeignObj_CLOSURE_DATA(fo),i)
 485 #define indexIntOffForeignObjZh(r,fo,i)    indexIntOffAddrZh(r,ForeignObj_CLOSURE_DATA(fo),i)
 486 #define indexWordOffForeignObjZh(r,fo,i)   indexWordOffAddrZh(r,ForeignObj_CLOSURE_DATA(fo),i)
 487 #define indexAddrOffForeignObjZh(r,fo,i)   indexAddrOffAddrZh(r,ForeignObj_CLOSURE_DATA(fo),i)
 488 #define indexFloatOffForeignObjZh(r,fo,i)  indexFloatOffAddrZh(r,ForeignObj_CLOSURE_DATA(fo),i)
 489 #define indexDoubleOffForeignObjZh(r,fo,i) indexDoubleOffAddrZh(r,ForeignObj_CLOSURE_DATA(fo),i)
 490 #define indexStablePtrOffForeignObjZh(r,fo,i)  indexStablePtrOffAddrZh(r,ForeignObj_CLOSURE_DATA(fo),i)
 491 #ifdef SUPPORT_LONG_LONGS
 492 #define indexInt64OffForeignObjZh(r,fo,i)  indexInt64OffAddrZh(r,ForeignObj_CLOSURE_DATA(fo),i)
 493 #define indexWord64OffForeignObjZh(r,fo,i) indexWord64OffAddrZh(r,ForeignObj_CLOSURE_DATA(fo),i)
 494 #endif
 495
 496 #define indexCharOffAddrZh(r,a,i)   r= ((C_ *)(a))[i]
 497 #define indexIntOffAddrZh(r,a,i)    r= ((I_ *)(a))[i]
 498 #define indexWordOffAddrZh(r,a,i)   r= ((W_ *)(a))[i]
 499 #define indexAddrOffAddrZh(r,a,i)   r= ((PP_)(a))[i]
 500 #define indexFloatOffAddrZh(r,a,i)  r= PK_FLT((P_) (((StgFloat *)(a)) + i))
 501 #define indexDoubleOffAddrZh(r,a,i) r= PK_DBL((P_) (((StgDouble *)(a)) + i))
 502 #ifdef SUPPORT_LONG_LONGS
 503 #define indexInt64OffAddrZh(r,a,i)  r= ((LI_ *)(a))[i]
 504 #define indexWord64OffAddrZh(r,a,i) r= ((LW_ *)(a))[i]
 505 #endif
 506
 507 /* Freezing arrays-of-ptrs requires changing an info table, for the
 508    benefit of the generational collector.  It needs to scavenge mutable
 509    objects, even if they are in old space.  When they become immutable,
 510    they can be removed from this scavenge list.  */
 511
 512 #define unsafeFreezeArrayZh(r,a)                                        \
 513         {                                                               \
 514         SET_INFO((StgClosure *)a,&MUT_ARR_PTRS_FROZEN_info);            \
 515         r = a;                                                          \
 516         }
 517
 518 #define unsafeFreezeByteArrayZh(r,a)    r=(a)
 519
 520 #define sizeofByteArrayZh(r,a) \
 521      r = (((StgArrWords *)(a))->words * sizeof(W_))
 522 #define sizeofMutableByteArrayZh(r,a) \
 523      r = (((StgArrWords *)(a))->words * sizeof(W_))
 524
 525 /* and the out-of-line ones... */
 526
 527 EF_(newCharArrayZh_fast);
 528 EF_(newIntArrayZh_fast);
 529 EF_(newWordArrayZh_fast);
 530 EF_(newAddrArrayZh_fast);
 531 EF_(newFloatArrayZh_fast);
 532 EF_(newDoubleArrayZh_fast);
 533 EF_(newStablePtrArrayZh_fast);
 534 EF_(newArrayZh_fast);
 535
 536 /* encoding and decoding of floats/doubles. */
 537
 538 /* We only support IEEE floating point format */
 539 #include "ieee-flpt.h"
 540
 541 #if FLOATS_AS_DOUBLES  /* i.e. 64-bit machines */
 542 #define encodeFloatZh(r, aa,sa,da, expon)   encodeDoubleZh(r, aa,sa,da, expon)
 543 #else
 544 #define encodeFloatZh(r, aa,sa,da, expon)       \
 545 { MP_INT arg;                                   \
 546   /* Does not allocate memory */                \
 547                                                 \
 548   arg._mp_alloc = aa;                           \
 549   arg._mp_size  = sa;                           \
 550   arg._mp_d     = (unsigned long int *) (BYTE_ARR_CTS(da)); \
 551                                                 \
 552   r = RET_PRIM_STGCALL2(StgFloat, __encodeFloat,&arg,(expon));\
 553 }
 554 #endif /* FLOATS_AS_DOUBLES */
 555
 556 #define encodeDoubleZh(r, aa,sa,da, expon)      \
 557 { MP_INT arg;                                   \
 558   /* Does not allocate memory */                \
 559                                                 \
 560   arg._mp_alloc = aa;                           \
 561   arg._mp_size  = sa;                           \
 562   arg._mp_d     = (unsigned long int *) (BYTE_ARR_CTS(da)); \
 563                                                 \
 564   r = RET_PRIM_STGCALL2(StgDouble, __encodeDouble,&arg,(expon));\
 565 }
 566
 567 /* The decode operations are out-of-line because they need to allocate
 568  * a byte array.
 569  */
 570
 571 #ifdef FLOATS_AS_DOUBLES
 572 #define decodeFloatZh_fast decodeDoubleZh_fast
 573 #else
 574 EF_(decodeFloatZh_fast);
 575 #endif
 576
 577 EF_(decodeDoubleZh_fast);
 578
 579 /* grimy low-level support functions defined in StgPrimFloat.c */
 580
 581 extern StgDouble __encodeDouble (MP_INT *s, I_ e);
 582 extern StgFloat  __encodeFloat  (MP_INT *s, I_ e);
 583 extern void      __decodeDouble (MP_INT *man, I_ *_exp, StgDouble dbl);
 584 extern void      __decodeFloat  (MP_INT *man, I_ *_exp, StgFloat flt);
 585 extern StgInt    isDoubleNaN(StgDouble d);
 586 extern StgInt    isDoubleInfinite(StgDouble d);
 587 extern StgInt    isDoubleDenormalized(StgDouble d);
 588 extern StgInt    isDoubleNegativeZero(StgDouble d);
 589 extern StgInt    isFloatNaN(StgFloat f);
 590 extern StgInt    isFloatInfinite(StgFloat f);
 591 extern StgInt    isFloatDenormalized(StgFloat f);
 592 extern StgInt    isFloatNegativeZero(StgFloat f);
 593
 594 /* -----------------------------------------------------------------------------
 595    Mutable variables
 596
 597    newMutVar is out of line.
 598    -------------------------------------------------------------------------- */
 599
 600 EF_(newMutVarZh_fast);
 601
 602 #define readMutVarZh(r,a)        r=(P_)(((StgMutVar *)(a))->var)
 603 #define writeMutVarZh(a,v)       (P_)(((StgMutVar *)(a))->var)=(v)
 604 #define sameMutVarZh(r,a,b)      r=(I_)((a)==(b))
 605
 606 /* -----------------------------------------------------------------------------
 607    MVar PrimOps.
 608
 609    All out of line, because they either allocate or may block.
 610    -------------------------------------------------------------------------- */
 611
 612 #define sameMVarZh(r,a,b)        r=(I_)((a)==(b))
 613
 614 /* Assume external decl of EMPTY_MVAR_info is in scope by now */
 615 #define isEmptyMVarZh(r,a)       r=(I_)((GET_INFO((StgMVar*)(a))) == &EMPTY_MVAR_info )
 616 EF_(newMVarZh_fast);
 617 EF_(takeMVarZh_fast);
 618 EF_(putMVarZh_fast);
 619
 620 /* -----------------------------------------------------------------------------
 621    Delay/Wait PrimOps
 622    -------------------------------------------------------------------------- */
 623
 624 /* Hmm, I'll think about these later. */
 625
 626 /* -----------------------------------------------------------------------------
 627    Primitive I/O, error-handling PrimOps
 628    -------------------------------------------------------------------------- */
 629
 630 EF_(catchZh_fast);
 631 EF_(raiseZh_fast);
 632
 633 extern void stg_exit(I_ n)  __attribute__ ((noreturn));
 634
 635 /* -----------------------------------------------------------------------------
 636    Stable Pointer PrimOps.
 637    -------------------------------------------------------------------------- */
 638
 639 #ifndef PAR
 640
 641 extern StgPtr *stable_ptr_table;
 642 extern StgPtr *stable_ptr_free;
 643 #define deRefStablePtrZh(r,sp)   (r=stable_ptr_table[(sp)])
 644 #define eqStablePtrZh(r,sp1,sp2) (r=(sp1==sp2))
 645
 646 #define freeStablePointer(stable_ptr)                   \
 647  {                                                      \
 648   stable_ptr_table[stable_ptr] = (P_)stable_ptr_free;   \
 649   stable_ptr_free = &stable_ptr_table[stable_ptr];      \
 650  }
 651
 652 EF_(makeStablePtrZh_fast);
 653
 654 #else /* PAR */
 655 #define deRefStablePtrZh(ri,sp)                                     \
 656 do {                                                                \
 657     fflush(stdout);                                                 \
 658     fprintf(stderr, "deRefStablePtr#: no stable pointer support.\n");\
 659     stg_exit(EXIT_FAILURE);                                         \
 660 } while(0)
 661
 662 #define eqStablePtrZh(ri,sp1,sp2)                                   \
 663 do {                                                                \
 664     fflush(stdout);                                                 \
 665     fprintf(stderr, "eqStablePtr#: no stable pointer support.\n");  \
 666     stg_exit(EXIT_FAILURE);                                         \
 667 } while(0)
 668
 669 #define makeStablePtrZh(stablePtr,liveness,unstablePtr)             \
 670 do {                                                                \
 671     fflush(stdout);                                                 \
 672     fprintf(stderr, "makeStablePtr#: no stable pointer support.\n");\
 673     EXIT(EXIT_FAILURE);                                             \
 674 } while(0)
 675
 676 #define freeStablePtrZh(stablePtr,liveness,unstablePtr)             \
 677 do {                                                                \
 678     fflush(stdout);                                                 \
 679     fprintf(stderr, "makeStablePtr#: no stable pointer support.\n");\
 680     EXIT(EXIT_FAILURE);                                             \
 681 } while(0)
 682 #endif
 683
 684
 685 /* -----------------------------------------------------------------------------
 686    Parallel PrimOps.
 687    -------------------------------------------------------------------------- */
 688
 689 EF_(forkZh_fast);
 690 EF_(killThreadZh_fast);
 691 EF_(seqZh_fast);
 692
 693 /* Hmm, I'll think about these later. */
 694 /* -----------------------------------------------------------------------------
 695    Pointer equality
 696    -------------------------------------------------------------------------- */
 697
 698 /* warning: extremely non-referentially transparent, need to hide in
 699    an appropriate monad.
 700
 701    ToDo: follow indirections.
 702 */
 703
 704 #define reallyUnsafePtrEqualityZh(r,a,b) r=((StgPtr)(a) == (StgPtr)(b))
 705
 706 /* -----------------------------------------------------------------------------
 707    Weak Pointer PrimOps.
 708    -------------------------------------------------------------------------- */
 709
 710 #ifndef PAR
 711
 712 EF_(mkWeakZh_fast);
 713 EF_(deRefWeakZh_fast);
 714 #define sameWeakZh(w1,w2)  ((w1)==(w2))
 715
 716 #endif
 717
 718 /* -----------------------------------------------------------------------------
 719    Foreign Object PrimOps.
 720    -------------------------------------------------------------------------- */
 721
 722 #ifndef PAR
 723
 724 #define ForeignObj_CLOSURE_DATA(c)  (((StgForeignObj *)c)->data)
 725
 726 EF_(makeForeignObjZh_fast);
 727
 728 #define writeForeignObjZh(res,datum) \
 729    (ForeignObj_CLOSURE_DATA(res) = (P_)(datum))
 730
 731 #define eqForeignObj(f1,f2)  ((f1)==(f2))
 732
 733 #endif
 734
 735 /* -----------------------------------------------------------------------------
 736    Signal processing.  Not really primops, but called directly from
 737    Haskell.
 738    -------------------------------------------------------------------------- */
 739
 740 #define STG_SIG_DFL  (-1)
 741 #define STG_SIG_IGN  (-2)
 742 #define STG_SIG_ERR  (-3)
 743 #define STG_SIG_HAN  (-4)
 744
 745 extern StgInt sig_install (StgInt, StgInt, StgStablePtr, sigset_t *);
 746 #define stg_sig_default(sig,mask) sig_install(sig,STG_SIG_DFL,0,(sigset_t *)mask)
 747 #define stg_sig_ignore(sig,mask) sig_install(sig,STG_SIG_IGN,0,(sigset_t *)mask)
 748 #define stg_sig_catch(sig,ptr,mask) sig_install(sig,STG_SIG_HAN,ptr,(sigset_t *)mask)
 749
 750 #endif PRIMOPS_H