ghc/includes/PrimOps.h

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