ghc/includes/PrimOps.h

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