ghc/includes/PrimOps.h

   1 /* -----------------------------------------------------------------------------
   2  * $Id: PrimOps.h,v 1.8 1999/01/21 10:31:42 simonm 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_)((a) >(b))
  24 #define ZgZeZh(r,a,b)   r=(I_)((a)>=(b))
  25 #define ZeZeZh(r,a,b)   r=(I_)((a)==(b))
  26 #define ZdZeZh(r,a,b)   r=(I_)((a)!=(b))
  27 #define ZlZh(r,a,b)     r=(I_)((a) <(b))
  28 #define ZlZeZh(r,a,b)   r=(I_)((a)<=(b))
  29
  30 #define gtWordZh(r,a,b) r=(I_)((a) >(b))
  31 #define geWordZh(r,a,b) r=(I_)((a)>=(b))
  32 #define eqWordZh(r,a,b) r=(I_)((a)==(b))
  33 #define neWordZh(r,a,b) r=(I_)((a)!=(b))
  34 #define ltWordZh(r,a,b) r=(I_)((a) <(b))
  35 #define leWordZh(r,a,b) r=(I_)((a)<=(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   }                                                                     \
 351   (r) = res;                                                            \
 352 }
 353
 354 /* Conversions */
 355 EF_(int64ToIntegerZh_fast);
 356 EF_(word64ToIntegerZh_fast);
 357
 358 /* The rest are (way!) out of line, implemented via C entry points.
 359  */
 360 I_ stg_gtWord64 (StgNat64, StgNat64);
 361 I_ stg_geWord64 (StgNat64, StgNat64);
 362 I_ stg_eqWord64 (StgNat64, StgNat64);
 363 I_ stg_neWord64 (StgNat64, StgNat64);
 364 I_ stg_ltWord64 (StgNat64, StgNat64);
 365 I_ stg_leWord64 (StgNat64, StgNat64);
 366
 367 I_ stg_gtInt64 (StgInt64, StgInt64);
 368 I_ stg_geInt64 (StgInt64, StgInt64);
 369 I_ stg_eqInt64 (StgInt64, StgInt64);
 370 I_ stg_neInt64 (StgInt64, StgInt64);
 371 I_ stg_ltInt64 (StgInt64, StgInt64);
 372 I_ stg_leInt64 (StgInt64, StgInt64);
 373
 374 LW_ stg_remWord64  (StgNat64, StgNat64);
 375 LW_ stg_quotWord64 (StgNat64, StgNat64);
 376
 377 LI_ stg_remInt64    (StgInt64, StgInt64);
 378 LI_ stg_quotInt64   (StgInt64, StgInt64);
 379 LI_ stg_negateInt64 (StgInt64);
 380 LI_ stg_plusInt64   (StgInt64, StgInt64);
 381 LI_ stg_minusInt64  (StgInt64, StgInt64);
 382 LI_ stg_timesInt64  (StgInt64, StgInt64);
 383
 384 LW_ stg_and64  (StgNat64, StgNat64);
 385 LW_ stg_or64   (StgNat64, StgNat64);
 386 LW_ stg_xor64  (StgNat64, StgNat64);
 387 LW_ stg_not64  (StgNat64);
 388
 389 LW_ stg_shiftL64   (StgNat64, StgInt);
 390 LW_ stg_shiftRL64  (StgNat64, StgInt);
 391 LI_ stg_iShiftL64  (StgInt64, StgInt);
 392 LI_ stg_iShiftRL64 (StgInt64, StgInt);
 393 LI_ stg_iShiftRA64 (StgInt64, StgInt);
 394
 395 LI_ stg_intToInt64    (StgInt);
 396 I_ stg_int64ToInt     (StgInt64);
 397 LW_ stg_int64ToWord64 (StgInt64);
 398
 399 LW_ stg_wordToWord64  (StgWord);
 400 W_  stg_word64ToWord  (StgNat64);
 401 LI_ stg_word64ToInt64 (StgNat64);
 402 #endif
 403
 404 /* -----------------------------------------------------------------------------
 405    Array PrimOps.
 406    -------------------------------------------------------------------------- */
 407
 408 /* We cast to void* instead of StgChar* because this avoids a warning
 409  * about increasing the alignment requirements.
 410  */
 411 #define REAL_BYTE_ARR_CTS(a)   ((void *) (((StgArrWords *)(a))->payload))
 412 #define REAL_PTRS_ARR_CTS(a)   ((P_)   (((StgMutArrPtrs  *)(a))->payload))
 413
 414 #ifdef DEBUG
 415 #define BYTE_ARR_CTS(a)                           \
 416  ({ ASSERT((GET_INFO(a) == &ARR_WORDS_info)       \
 417         || (GET_INFO(a) == &MUT_ARR_WORDS_info)); \
 418     REAL_BYTE_ARR_CTS(a); })
 419 #define PTRS_ARR_CTS(a)                           \
 420  ({ ASSERT((GET_INFO(a) == &ARR_PTRS_info)        \
 421         || (GET_INFO(a) == &MUT_ARR_PTRS_info));  \
 422     REAL_PTRS_ARR_CTS(a); })
 423 #else
 424 #define BYTE_ARR_CTS(a)         REAL_BYTE_ARR_CTS(a)
 425 #define PTRS_ARR_CTS(a)         REAL_PTRS_ARR_CTS(a)
 426 #endif
 427
 428 extern I_ genSymZh(void);
 429 extern I_ resetGenSymZh(void);
 430
 431 /*--- everything except new*Array is done inline: */
 432
 433 #define sameMutableArrayZh(r,a,b)       r=(I_)((a)==(b))
 434 #define sameMutableByteArrayZh(r,a,b)   r=(I_)((a)==(b))
 435
 436 #define readArrayZh(r,a,i)       r=((PP_) PTRS_ARR_CTS(a))[(i)]
 437
 438 #define readCharArrayZh(r,a,i)   indexCharOffAddrZh(r,BYTE_ARR_CTS(a),i)
 439 #define readIntArrayZh(r,a,i)    indexIntOffAddrZh(r,BYTE_ARR_CTS(a),i)
 440 #define readWordArrayZh(r,a,i)   indexWordOffAddrZh(r,BYTE_ARR_CTS(a),i)
 441 #define readAddrArrayZh(r,a,i)   indexAddrOffAddrZh(r,BYTE_ARR_CTS(a),i)
 442 #define readFloatArrayZh(r,a,i)  indexFloatOffAddrZh(r,BYTE_ARR_CTS(a),i)
 443 #define readDoubleArrayZh(r,a,i) indexDoubleOffAddrZh(r,BYTE_ARR_CTS(a),i)
 444 #define readStablePtrArrayZh(r,a,i) indexStablePtrOffAddrZh(r,BYTE_ARR_CTS(a),i)
 445 #ifdef SUPPORT_LONG_LONGS
 446 #define readInt64ArrayZh(r,a,i)  indexInt64OffAddrZh(r,BYTE_ARR_CTS(a),i)
 447 #define readWord64ArrayZh(r,a,i) indexWord64OffAddrZh(r,BYTE_ARR_CTS(a),i)
 448 #endif
 449
 450 /* result ("r") arg ignored in write macros! */
 451 #define writeArrayZh(a,i,v)     ((PP_) PTRS_ARR_CTS(a))[(i)]=(v)
 452
 453 #define writeCharArrayZh(a,i,v)   ((C_ *)(BYTE_ARR_CTS(a)))[i] = (v)
 454 #define writeIntArrayZh(a,i,v)    ((I_ *)(BYTE_ARR_CTS(a)))[i] = (v)
 455 #define writeWordArrayZh(a,i,v)   ((W_ *)(BYTE_ARR_CTS(a)))[i] = (v)
 456 #define writeAddrArrayZh(a,i,v)   ((PP_)(BYTE_ARR_CTS(a)))[i] = (v)
 457 #define writeFloatArrayZh(a,i,v)  \
 458         ASSIGN_FLT((P_) (((StgFloat *)(BYTE_ARR_CTS(a))) + i),v)
 459 #define writeDoubleArrayZh(a,i,v) \
 460         ASSIGN_DBL((P_) (((StgDouble *)(BYTE_ARR_CTS(a))) + i),v)
 461 #define writeStablePtrArrayZh(a,i,v)      ((StgStablePtr *)(BYTE_ARR_CTS(a)))[i] = (v)
 462 #ifdef SUPPORT_LONG_LONGS
 463 #define writeInt64ArrayZh(a,i,v)  ((LI_ *)(BYTE_ARR_CTS(a)))[i] = (v)
 464 #define writeWord64ArrayZh(a,i,v) ((LW_ *)(BYTE_ARR_CTS(a)))[i] = (v)
 465 #endif
 466
 467 #define indexArrayZh(r,a,i)       r=((PP_) PTRS_ARR_CTS(a))[(i)]
 468
 469 #define indexCharArrayZh(r,a,i)   indexCharOffAddrZh(r,BYTE_ARR_CTS(a),i)
 470 #define indexIntArrayZh(r,a,i)    indexIntOffAddrZh(r,BYTE_ARR_CTS(a),i)
 471 #define indexWordArrayZh(r,a,i)   indexWordOffAddrZh(r,BYTE_ARR_CTS(a),i)
 472 #define indexAddrArrayZh(r,a,i)   indexAddrOffAddrZh(r,BYTE_ARR_CTS(a),i)
 473 #define indexFloatArrayZh(r,a,i)  indexFloatOffAddrZh(r,BYTE_ARR_CTS(a),i)
 474 #define indexDoubleArrayZh(r,a,i) indexDoubleOffAddrZh(r,BYTE_ARR_CTS(a),i)
 475 #define indexStablePtrArrayZh(r,a,i) indexStablePtrOffAddrZh(r,BYTE_ARR_CTS(a),i)
 476 #ifdef SUPPORT_LONG_LONGS
 477 #define indexInt64ArrayZh(r,a,i)  indexInt64OffAddrZh(r,BYTE_ARR_CTS(a),i)
 478 #define indexWord64ArrayZh(r,a,i) indexWord64OffAddrZh(r,BYTE_ARR_CTS(a),i)
 479 #endif
 480
 481 #define indexCharOffForeignObjZh(r,fo,i)   indexCharOffAddrZh(r,ForeignObj_CLOSURE_DATA(fo),i)
 482 #define indexIntOffForeignObjZh(r,fo,i)    indexIntOffAddrZh(r,ForeignObj_CLOSURE_DATA(fo),i)
 483 #define indexWordOffForeignObjZh(r,fo,i)   indexWordOffAddrZh(r,ForeignObj_CLOSURE_DATA(fo),i)
 484 #define indexAddrOffForeignObjZh(r,fo,i)   indexAddrOffAddrZh(r,ForeignObj_CLOSURE_DATA(fo),i)
 485 #define indexFloatOffForeignObjZh(r,fo,i)  indexFloatOffAddrZh(r,ForeignObj_CLOSURE_DATA(fo),i)
 486 #define indexDoubleOffForeignObjZh(r,fo,i) indexDoubleOffAddrZh(r,ForeignObj_CLOSURE_DATA(fo),i)
 487 #define indexStablePtrOffForeignObjZh(r,fo,i)  indexStablePtrOffAddrZh(r,ForeignObj_CLOSURE_DATA(fo),i)
 488 #ifdef SUPPORT_LONG_LONGS
 489 #define indexInt64OffForeignObjZh(r,fo,i)  indexInt64OffAddrZh(r,ForeignObj_CLOSURE_DATA(fo),i)
 490 #define indexWord64OffForeignObjZh(r,fo,i) indexWord64OffAddrZh(r,ForeignObj_CLOSURE_DATA(fo),i)
 491 #endif
 492
 493 #define indexCharOffAddrZh(r,a,i)   r= ((C_ *)(a))[i]
 494 #define indexIntOffAddrZh(r,a,i)    r= ((I_ *)(a))[i]
 495 #define indexWordOffAddrZh(r,a,i)   r= ((W_ *)(a))[i]
 496 #define indexAddrOffAddrZh(r,a,i)   r= ((PP_)(a))[i]
 497 #define indexFloatOffAddrZh(r,a,i)  r= PK_FLT((P_) (((StgFloat *)(a)) + i))
 498 #define indexDoubleOffAddrZh(r,a,i) r= PK_DBL((P_) (((StgDouble *)(a)) + i))
 499 #ifdef SUPPORT_LONG_LONGS
 500 #define indexInt64OffAddrZh(r,a,i)  r= ((LI_ *)(a))[i]
 501 #define indexWord64OffAddrZh(r,a,i) r= ((LW_ *)(a))[i]
 502 #endif
 503
 504 /* Freezing arrays-of-ptrs requires changing an info table, for the
 505    benefit of the generational collector.  It needs to scavenge mutable
 506    objects, even if they are in old space.  When they become immutable,
 507    they can be removed from this scavenge list.  */
 508
 509 #define unsafeFreezeArrayZh(r,a)                                        \
 510         {                                                               \
 511         SET_INFO((StgClosure *)a,&MUT_ARR_PTRS_FROZEN_info);            \
 512         r = a;                                                          \
 513         }
 514
 515 #define unsafeFreezeByteArrayZh(r,a)    r=(a)
 516
 517 #define sizeofByteArrayZh(r,a) \
 518      r = (((StgArrWords *)(a))->words * sizeof(W_))
 519 #define sizeofMutableByteArrayZh(r,a) \
 520      r = (((StgArrWords *)(a))->words * sizeof(W_))
 521
 522 /* and the out-of-line ones... */
 523
 524 EF_(newCharArrayZh_fast);
 525 EF_(newIntArrayZh_fast);
 526 EF_(newWordArrayZh_fast);
 527 EF_(newAddrArrayZh_fast);
 528 EF_(newFloatArrayZh_fast);
 529 EF_(newDoubleArrayZh_fast);
 530 EF_(newStablePtrArrayZh_fast);
 531 EF_(newArrayZh_fast);
 532
 533 /* encoding and decoding of floats/doubles. */
 534
 535 /* We only support IEEE floating point format */
 536 #include "ieee-flpt.h"
 537
 538 #if FLOATS_AS_DOUBLES  /* i.e. 64-bit machines */
 539 #define encodeFloatZh(r, aa,sa,da, expon)   encodeDoubleZh(r, aa,sa,da, expon)
 540 #else
 541 #define encodeFloatZh(r, aa,sa,da, expon)       \
 542 { MP_INT arg;                                   \
 543   /* Does not allocate memory */                \
 544                                                 \
 545   arg._mp_alloc = aa;                           \
 546   arg._mp_size  = sa;                           \
 547   arg._mp_d     = (unsigned long int *) (BYTE_ARR_CTS(da)); \
 548                                                 \
 549   r = RET_PRIM_STGCALL2(StgFloat, __encodeFloat,&arg,(expon));\
 550 }
 551 #endif /* FLOATS_AS_DOUBLES */
 552
 553 #define encodeDoubleZh(r, aa,sa,da, expon)      \
 554 { MP_INT arg;                                   \
 555   /* Does not allocate memory */                \
 556                                                 \
 557   arg._mp_alloc = aa;                           \
 558   arg._mp_size  = sa;                           \
 559   arg._mp_d     = (unsigned long int *) (BYTE_ARR_CTS(da)); \
 560                                                 \
 561   r = RET_PRIM_STGCALL2(StgDouble, __encodeDouble,&arg,(expon));\
 562 }
 563
 564 /* The decode operations are out-of-line because they need to allocate
 565  * a byte array.
 566  */
 567
 568 #ifdef FLOATS_AS_DOUBLES
 569 #define decodeFloatZh_fast decodeDoubleZh_fast
 570 #else
 571 EF_(decodeFloatZh_fast);
 572 #endif
 573
 574 EF_(decodeDoubleZh_fast);
 575
 576 /* grimy low-level support functions defined in StgPrimFloat.c */
 577
 578 extern StgDouble __encodeDouble (MP_INT *s, I_ e);
 579 extern StgFloat  __encodeFloat  (MP_INT *s, I_ e);
 580 extern void      __decodeDouble (MP_INT *man, I_ *_exp, StgDouble dbl);
 581 extern void      __decodeFloat  (MP_INT *man, I_ *_exp, StgFloat flt);
 582 extern StgInt    isDoubleNaN(StgDouble d);
 583 extern StgInt    isDoubleInfinite(StgDouble d);
 584 extern StgInt    isDoubleDenormalized(StgDouble d);
 585 extern StgInt    isDoubleNegativeZero(StgDouble d);
 586 extern StgInt    isFloatNaN(StgFloat f);
 587 extern StgInt    isFloatInfinite(StgFloat f);
 588 extern StgInt    isFloatDenormalized(StgFloat f);
 589 extern StgInt    isFloatNegativeZero(StgFloat f);
 590
 591 /* -----------------------------------------------------------------------------
 592    Mutable variables
 593
 594    newMutVar is out of line.
 595    -------------------------------------------------------------------------- */
 596
 597 EF_(newMutVarZh_fast);
 598
 599 #define readMutVarZh(r,a)        r=(P_)(((StgMutVar *)(a))->var)
 600 #define writeMutVarZh(a,v)       (P_)(((StgMutVar *)(a))->var)=(v)
 601 #define sameMutVarZh(r,a,b)      r=(I_)((a)==(b))
 602
 603 /* -----------------------------------------------------------------------------
 604    MVar PrimOps.
 605
 606    All out of line, because they either allocate or may block.
 607    -------------------------------------------------------------------------- */
 608
 609 #define sameMVarZh(r,a,b)        r=(I_)((a)==(b))
 610
 611 /* Assume external decl of EMPTY_MVAR_info is in scope by now */
 612 #define isEmptyMVarZh(r,a)       r=(I_)((GET_INFO((StgMVar*)(a))) == &EMPTY_MVAR_info )
 613 EF_(newMVarZh_fast);
 614 EF_(takeMVarZh_fast);
 615 EF_(putMVarZh_fast);
 616
 617 /* -----------------------------------------------------------------------------
 618    Delay/Wait PrimOps
 619    -------------------------------------------------------------------------- */
 620
 621 /* Hmm, I'll think about these later. */
 622
 623 /* -----------------------------------------------------------------------------
 624    Primitive I/O, error-handling PrimOps
 625    -------------------------------------------------------------------------- */
 626
 627 EF_(catchZh_fast);
 628 EF_(raiseZh_fast);
 629
 630 extern void stg_exit(I_ n)  __attribute__ ((noreturn));
 631
 632 /* -----------------------------------------------------------------------------
 633    Stable Pointer PrimOps.
 634    -------------------------------------------------------------------------- */
 635
 636 #ifndef PAR
 637
 638 extern StgPtr *stable_ptr_table;
 639 extern StgPtr *stable_ptr_free;
 640 #define deRefStablePtrZh(r,sp)   (r=stable_ptr_table[(sp)])
 641 #define eqStablePtrZh(r,sp1,sp2) (r=(sp1==sp2))
 642
 643 #define freeStablePointer(stable_ptr)                   \
 644  {                                                      \
 645   stable_ptr_table[stable_ptr] = (P_)stable_ptr_free;   \
 646   stable_ptr_free = &stable_ptr_table[stable_ptr];      \
 647  }
 648
 649 EF_(makeStablePtrZh_fast);
 650
 651 #else /* PAR */
 652 #define deRefStablePtrZh(ri,sp)                                     \
 653 do {                                                                \
 654     fflush(stdout);                                                 \
 655     fprintf(stderr, "deRefStablePtr#: no stable pointer support.\n");\
 656     stg_exit(EXIT_FAILURE);                                         \
 657 } while(0)
 658
 659 #define eqStablePtrZh(ri,sp1,sp2)                                   \
 660 do {                                                                \
 661     fflush(stdout);                                                 \
 662     fprintf(stderr, "eqStablePtr#: no stable pointer support.\n");  \
 663     stg_exit(EXIT_FAILURE);                                         \
 664 } while(0)
 665
 666 #define makeStablePtrZh(stablePtr,liveness,unstablePtr)             \
 667 do {                                                                \
 668     fflush(stdout);                                                 \
 669     fprintf(stderr, "makeStablePtr#: no stable pointer support.\n");\
 670     EXIT(EXIT_FAILURE);                                             \
 671 } while(0)
 672
 673 #define freeStablePtrZh(stablePtr,liveness,unstablePtr)             \
 674 do {                                                                \
 675     fflush(stdout);                                                 \
 676     fprintf(stderr, "makeStablePtr#: no stable pointer support.\n");\
 677     EXIT(EXIT_FAILURE);                                             \
 678 } while(0)
 679 #endif
 680
 681
 682 /* -----------------------------------------------------------------------------
 683    Parallel PrimOps.
 684    -------------------------------------------------------------------------- */
 685
 686 EF_(forkZh_fast);
 687 EF_(killThreadZh_fast);
 688 EF_(seqZh_fast);
 689
 690 /* Hmm, I'll think about these later. */
 691 /* -----------------------------------------------------------------------------
 692    Pointer equality
 693    -------------------------------------------------------------------------- */
 694
 695 /* warning: extremely non-referentially transparent, need to hide in
 696    an appropriate monad.
 697
 698    ToDo: follow indirections.
 699 */
 700
 701 #define reallyUnsafePtrEqualityZh(r,a,b) r=((StgPtr)(a) == (StgPtr)(b))
 702
 703 /* -----------------------------------------------------------------------------
 704    Weak Pointer PrimOps.
 705    -------------------------------------------------------------------------- */
 706
 707 #ifndef PAR
 708
 709 EF_(mkWeakZh_fast);
 710 EF_(deRefWeakZh_fast);
 711 #define sameWeakZh(w1,w2)  ((w1)==(w2))
 712
 713 #endif
 714
 715 /* -----------------------------------------------------------------------------
 716    Foreign Object PrimOps.
 717    -------------------------------------------------------------------------- */
 718
 719 #ifndef PAR
 720
 721 #define ForeignObj_CLOSURE_DATA(c)  (((StgForeignObj *)c)->data)
 722
 723 EF_(makeForeignObjZh_fast);
 724
 725 #define writeForeignObjZh(res,datum) \
 726    (ForeignObj_CLOSURE_DATA(res) = (P_)(datum))
 727
 728 #define eqForeignObj(f1,f2)  ((f1)==(f2))
 729
 730 #endif
 731
 732 /* -----------------------------------------------------------------------------
 733    Signal processing.  Not really primops, but called directly from
 734    Haskell.
 735    -------------------------------------------------------------------------- */
 736
 737 #define STG_SIG_DFL  (-1)
 738 #define STG_SIG_IGN  (-2)
 739 #define STG_SIG_ERR  (-3)
 740 #define STG_SIG_HAN  (-4)
 741
 742 extern StgInt sig_install (StgInt, StgInt, StgStablePtr, sigset_t *);
 743 #define stg_sig_default(sig,mask) sig_install(sig,STG_SIG_DFL,0,(sigset_t *)mask)
 744 #define stg_sig_ignore(sig,mask) sig_install(sig,STG_SIG_IGN,0,(sigset_t *)mask)
 745 #define stg_sig_catch(sig,ptr,mask) sig_install(sig,STG_SIG_HAN,ptr,(sigset_t *)mask)
 746
 747 #endif PRIMOPS_H