ghc/includes/PrimOps.h

   1 /* -----------------------------------------------------------------------------
   2  * $Id: PrimOps.h,v 1.91 2002/03/02 17:51:22 sof Exp $
   3  *
   4  * (c) The GHC Team, 1998-2000
   5  *
   6  * Macros for primitive operations in STG-ish C code.
   7  *
   8  * ---------------------------------------------------------------------------*/
   9
  10 /* As of 5 Dec 01, this file no longer implements the primops, since they are
  11    translated into standard C in compiler/absCSyn/AbsCUtils during the absC
  12    flattening pass.  Only {add,sub,mul}IntCzh remain untranslated.  Most of
  13    what is here is now EXTFUN_RTS declarations for the out-of-line primop
  14    implementations which live in compiler/rts/PrimOps.hc.
  15 */
  16
  17 #ifndef PRIMOPS_H
  18 #define PRIMOPS_H
  19
  20 #include "MachDeps.h"
  21
  22 #if WORD_SIZE_IN_BITS < 32
  23 #error GHC C backend requires 32+-bit words
  24 #endif
  25
  26
  27 /* -----------------------------------------------------------------------------
  28  * Int operations with carry.
  29  * -------------------------------------------------------------------------- */
  30
  31 /* Multiply with overflow checking.
  32  *
  33  * This is tricky - the usual sign rules for add/subtract don't apply.
  34  *
  35  * On 32-bit machines we use gcc's 'long long' types, finding
  36  * overflow with some careful bit-twiddling.
  37  *
  38  * On 64-bit machines where gcc's 'long long' type is also 64-bits,
  39  * we use a crude approximation, testing whether either operand is
  40  * larger than 32-bits; if neither is, then we go ahead with the
  41  * multiplication.
  42  *
  43  * Return non-zero if there is any possibility that the signed multiply
  44  * of a and b might overflow.  Return zero only if you are absolutely sure
  45  * that it won't overflow.  If in doubt, return non-zero.
  46  */
  47
  48 #if SIZEOF_VOID_P == 4
  49
  50 #ifdef WORDS_BIGENDIAN
  51 #define C 0
  52 #define R 1
  53 #else
  54 #define C 1
  55 #define R 0
  56 #endif
  57
  58 typedef union {
  59     StgInt64 l;
  60     StgInt32 i[2];
  61 } long_long_u ;
  62
  63 #define mulIntMayOflo(a,b)                      \
  64 ({                                              \
  65   StgInt32 r, c;                                \
  66   long_long_u z;                                \
  67   z.l = (StgInt64)a * (StgInt64)b;              \
  68   r = z.i[R];                                   \
  69   c = z.i[C];                                   \
  70   if (c == 0 || c == -1) {                      \
  71     c = ((StgWord)((a^b) ^ r))                  \
  72       >> (BITS_IN (I_) - 1);                    \
  73   }                                             \
  74   c;                                            \
  75 })
  76
  77 /* Careful: the carry calculation above is extremely delicate.  Make sure
  78  * you test it thoroughly after changing it.
  79  */
  80
  81 #else
  82
  83 #define HALF_INT  (((I_)1) << (BITS_IN (I_) / 2))
  84
  85 #define stg_abs(a) (((I_)(a)) < 0 ? -((I_)(a)) : ((I_)(a)))
  86
  87 #define mulIntMayOflo(a,b)                      \
  88 ({                                              \
  89   I_ c;                                         \
  90   if (stg_abs(a) >= HALF_INT ||                 \
  91       stg_abs(b) >= HALF_INT) {                 \
  92     c = 1;                                      \
  93   } else {                                      \
  94     c = 0;                                      \
  95   }                                             \
  96   c;                                            \
  97 })
  98 #endif
  99
 100
 101 /* -----------------------------------------------------------------------------
 102    Integer PrimOps.
 103    -------------------------------------------------------------------------- */
 104
 105 /* NOTE: gcdIntzh and gcdIntegerIntzh work only for positive inputs! */
 106
 107 /* Some of these are out-of-line: -------- */
 108
 109 /* Integer arithmetic */
 110 EXTFUN_RTS(plusIntegerzh_fast);
 111 EXTFUN_RTS(minusIntegerzh_fast);
 112 EXTFUN_RTS(timesIntegerzh_fast);
 113 EXTFUN_RTS(gcdIntegerzh_fast);
 114 EXTFUN_RTS(quotRemIntegerzh_fast);
 115 EXTFUN_RTS(quotIntegerzh_fast);
 116 EXTFUN_RTS(remIntegerzh_fast);
 117 EXTFUN_RTS(divExactIntegerzh_fast);
 118 EXTFUN_RTS(divModIntegerzh_fast);
 119
 120 EXTFUN_RTS(cmpIntegerIntzh_fast);
 121 EXTFUN_RTS(cmpIntegerzh_fast);
 122 EXTFUN_RTS(integer2Intzh_fast);
 123 EXTFUN_RTS(integer2Wordzh_fast);
 124 EXTFUN_RTS(gcdIntegerIntzh_fast);
 125 EXTFUN_RTS(gcdIntzh_fast);
 126
 127 /* Conversions */
 128 EXTFUN_RTS(int2Integerzh_fast);
 129 EXTFUN_RTS(word2Integerzh_fast);
 130
 131 /* Floating-point decodings */
 132 EXTFUN_RTS(decodeFloatzh_fast);
 133 EXTFUN_RTS(decodeDoublezh_fast);
 134
 135 /* Bit operations */
 136 EXTFUN_RTS(andIntegerzh_fast);
 137 EXTFUN_RTS(orIntegerzh_fast);
 138 EXTFUN_RTS(xorIntegerzh_fast);
 139 EXTFUN_RTS(complementIntegerzh_fast);
 140
 141
 142 /* -----------------------------------------------------------------------------
 143    Word64 PrimOps.
 144    -------------------------------------------------------------------------- */
 145
 146 #ifdef SUPPORT_LONG_LONGS
 147
 148 /* Conversions */
 149 EXTFUN_RTS(int64ToIntegerzh_fast);
 150 EXTFUN_RTS(word64ToIntegerzh_fast);
 151
 152 /* The rest are (way!) out of line, implemented in vanilla C. */
 153 I_ stg_gtWord64 (StgWord64, StgWord64);
 154 I_ stg_geWord64 (StgWord64, StgWord64);
 155 I_ stg_eqWord64 (StgWord64, StgWord64);
 156 I_ stg_neWord64 (StgWord64, StgWord64);
 157 I_ stg_ltWord64 (StgWord64, StgWord64);
 158 I_ stg_leWord64 (StgWord64, StgWord64);
 159
 160 I_ stg_gtInt64 (StgInt64, StgInt64);
 161 I_ stg_geInt64 (StgInt64, StgInt64);
 162 I_ stg_eqInt64 (StgInt64, StgInt64);
 163 I_ stg_neInt64 (StgInt64, StgInt64);
 164 I_ stg_ltInt64 (StgInt64, StgInt64);
 165 I_ stg_leInt64 (StgInt64, StgInt64);
 166
 167 LW_ stg_remWord64  (StgWord64, StgWord64);
 168 LW_ stg_quotWord64 (StgWord64, StgWord64);
 169
 170 LI_ stg_remInt64    (StgInt64, StgInt64);
 171 LI_ stg_quotInt64   (StgInt64, StgInt64);
 172 LI_ stg_negateInt64 (StgInt64);
 173 LI_ stg_plusInt64   (StgInt64, StgInt64);
 174 LI_ stg_minusInt64  (StgInt64, StgInt64);
 175 LI_ stg_timesInt64  (StgInt64, StgInt64);
 176
 177 LW_ stg_and64  (StgWord64, StgWord64);
 178 LW_ stg_or64   (StgWord64, StgWord64);
 179 LW_ stg_xor64  (StgWord64, StgWord64);
 180 LW_ stg_not64  (StgWord64);
 181
 182 LW_ stg_uncheckedShiftL64   (StgWord64, StgInt);
 183 LW_ stg_uncheckedShiftRL64  (StgWord64, StgInt);
 184 LI_ stg_uncheckedIShiftL64  (StgInt64, StgInt);
 185 LI_ stg_uncheckedIShiftRL64 (StgInt64, StgInt);
 186 LI_ stg_uncheckedIShiftRA64 (StgInt64, StgInt);
 187
 188 LI_ stg_intToInt64    (StgInt);
 189 I_  stg_int64ToInt    (StgInt64);
 190 LW_ stg_int64ToWord64 (StgInt64);
 191
 192 LW_ stg_wordToWord64  (StgWord);
 193 W_  stg_word64ToWord  (StgWord64);
 194 LI_ stg_word64ToInt64 (StgWord64);
 195
 196 LI_ stg_integerToInt64 (I_ sa, StgByteArray /* Really: mp_limb_t* */ da);
 197 LW_ stg_integerToWord64 (I_ sa, StgByteArray /* Really: mp_limb_t* */ da);
 198
 199 #endif
 200
 201 /* -----------------------------------------------------------------------------
 202    Array PrimOps.
 203    -------------------------------------------------------------------------- */
 204
 205 /* We cast to void* instead of StgChar* because this avoids a warning
 206  * about increasing the alignment requirements.
 207  */
 208 #define REAL_BYTE_ARR_CTS(a)   ((void *) (((StgArrWords *)(a))->payload))
 209 #define REAL_PTRS_ARR_CTS(a)   ((P_)   (((StgMutArrPtrs  *)(a))->payload))
 210
 211 #ifdef DEBUG
 212 #define BYTE_ARR_CTS(a)                           \
 213  ({ ASSERT(GET_INFO((StgArrWords *)(a)) == &stg_ARR_WORDS_info);          \
 214     REAL_BYTE_ARR_CTS(a); })
 215 #define PTRS_ARR_CTS(a)                           \
 216  ({ ASSERT((GET_INFO((StgMutArrPtrs  *)(a)) == &stg_MUT_ARR_PTRS_FROZEN_info)     \
 217         || (GET_INFO((StgMutArrPtrs  *)(a)) == &stg_MUT_ARR_PTRS_info));  \
 218     REAL_PTRS_ARR_CTS(a); })
 219 #else
 220 #define BYTE_ARR_CTS(a)         REAL_BYTE_ARR_CTS(a)
 221 #define PTRS_ARR_CTS(a)         REAL_PTRS_ARR_CTS(a)
 222 #endif
 223
 224
 225 extern I_ genSymZh(void);
 226 extern I_ resetGenSymZh(void);
 227
 228 /*--- Almost everything in line. */
 229
 230 EXTFUN_RTS(unsafeThawArrayzh_fast);
 231 EXTFUN_RTS(newByteArrayzh_fast);
 232 EXTFUN_RTS(newPinnedByteArrayzh_fast);
 233 EXTFUN_RTS(newArrayzh_fast);
 234
 235 /* The decode operations are out-of-line because they need to allocate
 236  * a byte array.
 237  */
 238
 239 /* We only support IEEE floating point formats. */
 240 #include "ieee-flpt.h"
 241 EXTFUN_RTS(decodeFloatzh_fast);
 242 EXTFUN_RTS(decodeDoublezh_fast);
 243
 244 /* grimy low-level support functions defined in StgPrimFloat.c */
 245 extern StgDouble __encodeDouble (I_ size, StgByteArray arr, I_ e);
 246 extern StgDouble __int_encodeDouble (I_ j, I_ e);
 247 extern StgFloat  __encodeFloat (I_ size, StgByteArray arr, I_ e);
 248 extern StgFloat  __int_encodeFloat (I_ j, I_ e);
 249 extern void      __decodeDouble (MP_INT *man, I_ *_exp, StgDouble dbl);
 250 extern void      __decodeFloat  (MP_INT *man, I_ *_exp, StgFloat flt);
 251 extern StgInt    isDoubleNaN(StgDouble d);
 252 extern StgInt    isDoubleInfinite(StgDouble d);
 253 extern StgInt    isDoubleDenormalized(StgDouble d);
 254 extern StgInt    isDoubleNegativeZero(StgDouble d);
 255 extern StgInt    isFloatNaN(StgFloat f);
 256 extern StgInt    isFloatInfinite(StgFloat f);
 257 extern StgInt    isFloatDenormalized(StgFloat f);
 258 extern StgInt    isFloatNegativeZero(StgFloat f);
 259
 260
 261 /* -----------------------------------------------------------------------------
 262    Mutable variables
 263
 264    newMutVar is out of line.
 265    -------------------------------------------------------------------------- */
 266
 267 EXTFUN_RTS(newMutVarzh_fast);
 268
 269
 270 /* -----------------------------------------------------------------------------
 271    MVar PrimOps.
 272
 273    All out of line, because they either allocate or may block.
 274    -------------------------------------------------------------------------- */
 275
 276 EXTFUN_RTS(isEmptyMVarzh_fast);
 277 EXTFUN_RTS(newMVarzh_fast);
 278 EXTFUN_RTS(takeMVarzh_fast);
 279 EXTFUN_RTS(putMVarzh_fast);
 280 EXTFUN_RTS(tryTakeMVarzh_fast);
 281 EXTFUN_RTS(tryPutMVarzh_fast);
 282
 283
 284 /* -----------------------------------------------------------------------------
 285    Delay/Wait PrimOps
 286    -------------------------------------------------------------------------- */
 287
 288 EXTFUN_RTS(waitReadzh_fast);
 289 EXTFUN_RTS(waitWritezh_fast);
 290 EXTFUN_RTS(delayzh_fast);
 291
 292
 293 /* -----------------------------------------------------------------------------
 294    Primitive I/O, error-handling PrimOps
 295    -------------------------------------------------------------------------- */
 296
 297 EXTFUN_RTS(catchzh_fast);
 298 EXTFUN_RTS(raisezh_fast);
 299
 300 extern void stg_exit(I_ n)  __attribute__ ((noreturn));
 301
 302
 303 /* -----------------------------------------------------------------------------
 304    Stable Name / Stable Pointer  PrimOps
 305    -------------------------------------------------------------------------- */
 306
 307 EXTFUN_RTS(makeStableNamezh_fast);
 308 EXTFUN_RTS(makeStablePtrzh_fast);
 309 EXTFUN_RTS(deRefStablePtrzh_fast);
 310
 311
 312 /* -----------------------------------------------------------------------------
 313    Concurrency/Exception PrimOps.
 314    -------------------------------------------------------------------------- */
 315
 316 EXTFUN_RTS(forkzh_fast);
 317 EXTFUN_RTS(yieldzh_fast);
 318 EXTFUN_RTS(killThreadzh_fast);
 319 EXTFUN_RTS(seqzh_fast);
 320 EXTFUN_RTS(blockAsyncExceptionszh_fast);
 321 EXTFUN_RTS(unblockAsyncExceptionszh_fast);
 322 EXTFUN_RTS(myThreadIdzh_fast);
 323
 324 extern int cmp_thread(const StgTSO *tso1, const StgTSO *tso2);
 325 extern int rts_getThreadId(const StgTSO *tso);
 326
 327
 328 /* -----------------------------------------------------------------------------
 329    Weak Pointer PrimOps.
 330    -------------------------------------------------------------------------- */
 331
 332 EXTFUN_RTS(mkWeakzh_fast);
 333 EXTFUN_RTS(finalizzeWeakzh_fast);
 334 EXTFUN_RTS(deRefWeakzh_fast);
 335
 336
 337 /* -----------------------------------------------------------------------------
 338    Foreign Object PrimOps.
 339    -------------------------------------------------------------------------- */
 340
 341 EXTFUN_RTS(mkForeignObjzh_fast);
 342
 343
 344 /* -----------------------------------------------------------------------------
 345    Constructor tags
 346    -------------------------------------------------------------------------- */
 347
 348 /*
 349  * This macro is only used when compiling unregisterised code (see
 350  * AbsCUtils.dsCOpStmt for motivation & the Story).
 351  */
 352 #ifndef TABLES_NEXT_TO_CODE
 353 # define dataToTagzh(r,a)  r=(GET_TAG(((StgClosure *)a)->header.info))
 354 #endif
 355
 356 /* -----------------------------------------------------------------------------
 357    BCOs and BCO linkery
 358    -------------------------------------------------------------------------- */
 359
 360 EXTFUN_RTS(newBCOzh_fast);
 361 EXTFUN_RTS(mkApUpd0zh_fast);
 362
 363
 364 /* -----------------------------------------------------------------------------
 365    Signal handling.  Not really primops, but called directly from Haskell.
 366    -------------------------------------------------------------------------- */
 367
 368 #define STG_SIG_DFL  (-1)
 369 #define STG_SIG_IGN  (-2)
 370 #define STG_SIG_ERR  (-3)
 371 #define STG_SIG_HAN  (-4)
 372
 373 extern StgInt stg_sig_install (StgInt, StgInt, StgStablePtr, sigset_t *);
 374 #define stg_sig_default(sig,mask) stg_sig_install(sig,STG_SIG_DFL,0,(sigset_t *)mask)
 375 #define stg_sig_ignore(sig,mask) stg_sig_install(sig,STG_SIG_IGN,0,(sigset_t *)mask)
 376 #define stg_sig_catch(sig,ptr,mask) stg_sig_install(sig,STG_SIG_HAN,ptr,(sigset_t *)mask)
 377
 378
 379 /* ------------------------------------------------------------------------
 380    Parallel PrimOps
 381
 382    A par in the Haskell code is ultimately translated to a parzh macro
 383    (with a case wrapped around it to guarantee that the macro is actually
 384     executed; see compiler/prelude/PrimOps.lhs)
 385    In GUM and SMP we only add a pointer to the spark pool.
 386    In GranSim we call an RTS fct, forwarding additional parameters which
 387    supply info on granularity of the computation, size of the result value
 388    and the degree of parallelism in the sparked expression.
 389    ---------------------------------------------------------------------- */
 390
 391 #if defined(GRAN)
 392 //@cindex _par_
 393 #define parzh(r,node)             parAny(r,node,1,0,0,0,0,0)
 394
 395 //@cindex _parAt_
 396 #define parAtzh(r,node,where,identifier,gran_info,size_info,par_info,rest) \
 397         parAT(r,node,where,identifier,gran_info,size_info,par_info,rest,1)
 398
 399 //@cindex _parAtAbs_
 400 #define parAtAbszh(r,node,proc,identifier,gran_info,size_info,par_info,rest) \
 401         parAT(r,node,proc,identifier,gran_info,size_info,par_info,rest,2)
 402
 403 //@cindex _parAtRel_
 404 #define parAtRelzh(r,node,proc,identifier,gran_info,size_info,par_info,rest) \
 405         parAT(r,node,proc,identifier,gran_info,size_info,par_info,rest,3)
 406
 407 //@cindex _parAtForNow_
 408 #define parAtForNowzh(r,node,where,identifier,gran_info,size_info,par_info,rest)        \
 409         parAT(r,node,where,identifier,gran_info,size_info,par_info,rest,0)
 410
 411 #define parAT(r,node,where,identifier,gran_info,size_info,par_info,rest,local)  \
 412 {                                                               \
 413   if (closure_SHOULD_SPARK((StgClosure*)node)) {                \
 414     rtsSparkQ result;                                           \
 415     PEs p;                                                      \
 416                                                                 \
 417     STGCALL6(newSpark, node,identifier,gran_info,size_info,par_info,local); \
 418     switch (local) {                                                        \
 419       case 2: p = where;  /* parAtAbs means absolute PE no. expected */     \
 420               break;                                                        \
 421       case 3: p = CurrentProc+where; /* parAtRel means rel PE no. expected */\
 422               break;                                                        \
 423       default: p = where_is(where); /* parAt means closure expected */      \
 424               break;                                                        \
 425     }                                                                       \
 426     /* update GranSim state according to this spark */                      \
 427     STGCALL3(GranSimSparkAtAbs, result, (I_)p, identifier);                 \
 428   }                                                                         \
 429 }
 430
 431 //@cindex _parLocal_
 432 #define parLocalzh(r,node,identifier,gran_info,size_info,par_info,rest) \
 433         parAny(r,node,rest,identifier,gran_info,size_info,par_info,1)
 434
 435 //@cindex _parGlobal_
 436 #define parGlobalzh(r,node,identifier,gran_info,size_info,par_info,rest) \
 437         parAny(r,node,rest,identifier,gran_info,size_info,par_info,0)
 438
 439 #define parAny(r,node,rest,identifier,gran_info,size_info,par_info,local) \
 440 {                                                                        \
 441   if (closure_SHOULD_SPARK((StgClosure*)node)) {                         \
 442     rtsSpark *result;                                                    \
 443     result = RET_STGCALL6(rtsSpark*, newSpark,                           \
 444                           node,identifier,gran_info,size_info,par_info,local);\
 445     STGCALL1(add_to_spark_queue,result);                                \
 446     STGCALL2(GranSimSpark, local,(P_)node);                             \
 447   }                                                                     \
 448 }
 449
 450 #define copyablezh(r,node)                              \
 451   /* copyable not yet implemented!! */
 452
 453 #define noFollowzh(r,node)                              \
 454   /* noFollow not yet implemented!! */
 455
 456 #elif defined(SMP) || defined(PAR)
 457
 458 #define parzh(r,node)                                   \
 459 {                                                       \
 460   extern unsigned int context_switch;                   \
 461   if (closure_SHOULD_SPARK((StgClosure *)node) &&       \
 462       SparkTl < SparkLim) {                             \
 463     *SparkTl++ = (StgClosure *)(node);                  \
 464   }                                                     \
 465   r = context_switch = 1;                               \
 466 }
 467 #else /* !GRAN && !SMP && !PAR */
 468 #define parzh(r,node) r = 1
 469 #endif
 470
 471 /* -----------------------------------------------------------------------------
 472    ForeignObj - the C backend still needs this.
 473    -------------------------------------------------------------------------- */
 474 #define ForeignObj_CLOSURE_DATA(c)  (((StgForeignObj *)c)->data)
 475
 476 #endif /* PRIMOPS_H */