ghc/includes/PrimOps.h

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