ghc/includes/PrimOps.h

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