1 /* -----------------------------------------------------------------------------
2 * $Id: PrimOps.h,v 1.91 2002/03/02 17:51:22 sof Exp $
4 * (c) The GHC Team, 1998-2000
6 * Macros for primitive operations in STG-ish C code.
8 * ---------------------------------------------------------------------------*/
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.
22 #if WORD_SIZE_IN_BITS < 32
23 #error GHC C backend requires 32+-bit words
27 /* -----------------------------------------------------------------------------
28 * Int operations with carry.
29 * -------------------------------------------------------------------------- */
31 /* Multiply with overflow checking.
33 * This is tricky - the usual sign rules for add/subtract don't apply.
35 * On 32-bit machines we use gcc's 'long long' types, finding
36 * overflow with some careful bit-twiddling.
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
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.
48 #if SIZEOF_VOID_P == 4
50 #ifdef WORDS_BIGENDIAN
63 #define mulIntMayOflo(a,b) \
67 z.l = (StgInt64)a * (StgInt64)b; \
70 if (c == 0 || c == -1) { \
71 c = ((StgWord)((a^b) ^ r)) \
72 >> (BITS_IN (I_) - 1); \
77 /* Careful: the carry calculation above is extremely delicate. Make sure
78 * you test it thoroughly after changing it.
83 #define HALF_INT (((I_)1) << (BITS_IN (I_) / 2))
85 #define stg_abs(a) (((I_)(a)) < 0 ? -((I_)(a)) : ((I_)(a)))
87 #define mulIntMayOflo(a,b) \
90 if (stg_abs(a) >= HALF_INT || \
91 stg_abs(b) >= HALF_INT) { \
101 /* -----------------------------------------------------------------------------
103 -------------------------------------------------------------------------- */
105 /* NOTE: gcdIntzh and gcdIntegerIntzh work only for positive inputs! */
107 /* Some of these are out-of-line: -------- */
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);
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);
128 EXTFUN_RTS(int2Integerzh_fast);
129 EXTFUN_RTS(word2Integerzh_fast);
131 /* Floating-point decodings */
132 EXTFUN_RTS(decodeFloatzh_fast);
133 EXTFUN_RTS(decodeDoublezh_fast);
136 EXTFUN_RTS(andIntegerzh_fast);
137 EXTFUN_RTS(orIntegerzh_fast);
138 EXTFUN_RTS(xorIntegerzh_fast);
139 EXTFUN_RTS(complementIntegerzh_fast);
142 /* -----------------------------------------------------------------------------
144 -------------------------------------------------------------------------- */
146 #ifdef SUPPORT_LONG_LONGS
149 EXTFUN_RTS(int64ToIntegerzh_fast);
150 EXTFUN_RTS(word64ToIntegerzh_fast);
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);
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);
167 LW_ stg_remWord64 (StgWord64, StgWord64);
168 LW_ stg_quotWord64 (StgWord64, StgWord64);
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);
177 LW_ stg_and64 (StgWord64, StgWord64);
178 LW_ stg_or64 (StgWord64, StgWord64);
179 LW_ stg_xor64 (StgWord64, StgWord64);
180 LW_ stg_not64 (StgWord64);
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);
188 LI_ stg_intToInt64 (StgInt);
189 I_ stg_int64ToInt (StgInt64);
190 LW_ stg_int64ToWord64 (StgInt64);
192 LW_ stg_wordToWord64 (StgWord);
193 W_ stg_word64ToWord (StgWord64);
194 LI_ stg_word64ToInt64 (StgWord64);
196 LI_ stg_integerToInt64 (I_ sa, StgByteArray /* Really: mp_limb_t* */ da);
197 LW_ stg_integerToWord64 (I_ sa, StgByteArray /* Really: mp_limb_t* */ da);
201 /* -----------------------------------------------------------------------------
203 -------------------------------------------------------------------------- */
205 /* We cast to void* instead of StgChar* because this avoids a warning
206 * about increasing the alignment requirements.
208 #define REAL_BYTE_ARR_CTS(a) ((void *) (((StgArrWords *)(a))->payload))
209 #define REAL_PTRS_ARR_CTS(a) ((P_) (((StgMutArrPtrs *)(a))->payload))
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); })
220 #define BYTE_ARR_CTS(a) REAL_BYTE_ARR_CTS(a)
221 #define PTRS_ARR_CTS(a) REAL_PTRS_ARR_CTS(a)
225 extern I_ genSymZh(void);
226 extern I_ resetGenSymZh(void);
228 /*--- Almost everything in line. */
230 EXTFUN_RTS(unsafeThawArrayzh_fast);
231 EXTFUN_RTS(newByteArrayzh_fast);
232 EXTFUN_RTS(newPinnedByteArrayzh_fast);
233 EXTFUN_RTS(newArrayzh_fast);
235 /* The decode operations are out-of-line because they need to allocate
239 /* We only support IEEE floating point formats. */
240 #include "ieee-flpt.h"
241 EXTFUN_RTS(decodeFloatzh_fast);
242 EXTFUN_RTS(decodeDoublezh_fast);
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);
261 /* -----------------------------------------------------------------------------
264 newMutVar is out of line.
265 -------------------------------------------------------------------------- */
267 EXTFUN_RTS(newMutVarzh_fast);
270 /* -----------------------------------------------------------------------------
273 All out of line, because they either allocate or may block.
274 -------------------------------------------------------------------------- */
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);
284 /* -----------------------------------------------------------------------------
286 -------------------------------------------------------------------------- */
288 EXTFUN_RTS(waitReadzh_fast);
289 EXTFUN_RTS(waitWritezh_fast);
290 EXTFUN_RTS(delayzh_fast);
293 /* -----------------------------------------------------------------------------
294 Primitive I/O, error-handling PrimOps
295 -------------------------------------------------------------------------- */
297 EXTFUN_RTS(catchzh_fast);
298 EXTFUN_RTS(raisezh_fast);
300 extern void stg_exit(I_ n) __attribute__ ((noreturn));
303 /* -----------------------------------------------------------------------------
304 Stable Name / Stable Pointer PrimOps
305 -------------------------------------------------------------------------- */
307 EXTFUN_RTS(makeStableNamezh_fast);
308 EXTFUN_RTS(makeStablePtrzh_fast);
309 EXTFUN_RTS(deRefStablePtrzh_fast);
312 /* -----------------------------------------------------------------------------
313 Concurrency/Exception PrimOps.
314 -------------------------------------------------------------------------- */
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);
324 extern int cmp_thread(const StgTSO *tso1, const StgTSO *tso2);
325 extern int rts_getThreadId(const StgTSO *tso);
328 /* -----------------------------------------------------------------------------
329 Weak Pointer PrimOps.
330 -------------------------------------------------------------------------- */
332 EXTFUN_RTS(mkWeakzh_fast);
333 EXTFUN_RTS(finalizzeWeakzh_fast);
334 EXTFUN_RTS(deRefWeakzh_fast);
337 /* -----------------------------------------------------------------------------
338 Foreign Object PrimOps.
339 -------------------------------------------------------------------------- */
341 EXTFUN_RTS(mkForeignObjzh_fast);
344 /* -----------------------------------------------------------------------------
346 -------------------------------------------------------------------------- */
349 * This macro is only used when compiling unregisterised code (see
350 * AbsCUtils.dsCOpStmt for motivation & the Story).
352 #ifndef TABLES_NEXT_TO_CODE
353 # define dataToTagzh(r,a) r=(GET_TAG(((StgClosure *)a)->header.info))
356 /* -----------------------------------------------------------------------------
358 -------------------------------------------------------------------------- */
360 EXTFUN_RTS(newBCOzh_fast);
361 EXTFUN_RTS(mkApUpd0zh_fast);
364 /* -----------------------------------------------------------------------------
365 Signal handling. Not really primops, but called directly from Haskell.
366 -------------------------------------------------------------------------- */
368 #define STG_SIG_DFL (-1)
369 #define STG_SIG_IGN (-2)
370 #define STG_SIG_ERR (-3)
371 #define STG_SIG_HAN (-4)
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)
379 /* ------------------------------------------------------------------------
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 ---------------------------------------------------------------------- */
393 #define parzh(r,node) parAny(r,node,1,0,0,0,0,0)
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)
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)
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)
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)
411 #define parAT(r,node,where,identifier,gran_info,size_info,par_info,rest,local) \
413 if (closure_SHOULD_SPARK((StgClosure*)node)) { \
417 STGCALL6(newSpark, node,identifier,gran_info,size_info,par_info,local); \
419 case 2: p = where; /* parAtAbs means absolute PE no. expected */ \
421 case 3: p = CurrentProc+where; /* parAtRel means rel PE no. expected */\
423 default: p = where_is(where); /* parAt means closure expected */ \
426 /* update GranSim state according to this spark */ \
427 STGCALL3(GranSimSparkAtAbs, result, (I_)p, identifier); \
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)
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)
439 #define parAny(r,node,rest,identifier,gran_info,size_info,par_info,local) \
441 if (closure_SHOULD_SPARK((StgClosure*)node)) { \
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); \
450 #define copyablezh(r,node) \
451 /* copyable not yet implemented!! */
453 #define noFollowzh(r,node) \
454 /* noFollow not yet implemented!! */
456 #elif defined(SMP) || defined(PAR)
458 #define parzh(r,node) \
460 extern unsigned int context_switch; \
461 if (closure_SHOULD_SPARK((StgClosure *)node) && \
462 SparkTl < SparkLim) { \
463 *SparkTl++ = (StgClosure *)(node); \
465 r = context_switch = 1; \
467 #else /* !GRAN && !SMP && !PAR */
468 #define parzh(r,node) r = 1
471 /* -----------------------------------------------------------------------------
472 ForeignObj - the C backend still needs this.
473 -------------------------------------------------------------------------- */
474 #define ForeignObj_CLOSURE_DATA(c) (((StgForeignObj *)c)->data)
476 #endif /* PRIMOPS_H */