ghc/includes/PrimOps.h

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