ghc/includes/PrimOps.h

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