ghc/includes/PrimOps.h

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