ghc/includes/PrimOps.h

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