1 /* -----------------------------------------------------------------------------
2 * $Id: PrimOps.h,v 1.88 2001/12/11 18:25:15 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 /* 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
35 * Return : r = a + b, c = 0 if no overflow, 1 on overflow.
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#.
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); \
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); \
55 /* Multiply with overflow checking.
57 * This is slightly more tricky - the usual sign rules for add/subtract
60 * On x86 hardware we use a hand-crafted assembly fragment to do the job.
62 * On other 32-bit machines we use gcc's 'long long' types, finding
63 * overflow with some careful bit-twiddling.
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
73 #define mulIntCzh(r,c,a,b) \
75 __asm__("xorl %1,%1\n\t \
80 : "=r" (r), "=&r" (c) : "r" (a), "0" (b)); \
83 #elif SIZEOF_VOID_P == 4
85 #ifdef WORDS_BIGENDIAN
98 #define mulIntCzh(r,c,a,b) \
101 z.l = (StgInt64)a * (StgInt64)b; \
104 if (c == 0 || c == -1) { \
105 c = ((StgWord)((a^b) ^ r)) \
106 >> (BITS_IN (I_) - 1); \
109 /* Careful: the carry calculation above is extremely delicate. Make sure
110 * you test it thoroughly after changing it.
115 #define HALF_INT (((I_)1) << (BITS_IN (I_) / 2))
117 #define stg_abs(a) (((I_)(a)) < 0 ? -((I_)(a)) : ((I_)(a)))
119 #define mulIntCzh(r,c,a,b) \
121 if (stg_abs(a) >= HALF_INT || \
122 stg_abs(b) >= HALF_INT) { \
125 r = ((I_)(a)) * ((I_)(b)); \
132 /* -----------------------------------------------------------------------------
134 -------------------------------------------------------------------------- */
136 /* NOTE: gcdIntzh and gcdIntegerIntzh work only for positive inputs! */
138 /* Some of these are out-of-line: -------- */
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);
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);
159 EXTFUN_RTS(int2Integerzh_fast);
160 EXTFUN_RTS(word2Integerzh_fast);
162 /* Floating-point decodings */
163 EXTFUN_RTS(decodeFloatzh_fast);
164 EXTFUN_RTS(decodeDoublezh_fast);
167 EXTFUN_RTS(andIntegerzh_fast);
168 EXTFUN_RTS(orIntegerzh_fast);
169 EXTFUN_RTS(xorIntegerzh_fast);
170 EXTFUN_RTS(complementIntegerzh_fast);
173 /* -----------------------------------------------------------------------------
175 -------------------------------------------------------------------------- */
177 #ifdef SUPPORT_LONG_LONGS
180 EXTFUN_RTS(int64ToIntegerzh_fast);
181 EXTFUN_RTS(word64ToIntegerzh_fast);
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);
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);
198 LW_ stg_remWord64 (StgWord64, StgWord64);
199 LW_ stg_quotWord64 (StgWord64, StgWord64);
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);
208 LW_ stg_and64 (StgWord64, StgWord64);
209 LW_ stg_or64 (StgWord64, StgWord64);
210 LW_ stg_xor64 (StgWord64, StgWord64);
211 LW_ stg_not64 (StgWord64);
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);
219 LI_ stg_intToInt64 (StgInt);
220 I_ stg_int64ToInt (StgInt64);
221 LW_ stg_int64ToWord64 (StgInt64);
223 LW_ stg_wordToWord64 (StgWord);
224 W_ stg_word64ToWord (StgWord64);
225 LI_ stg_word64ToInt64 (StgWord64);
227 LI_ stg_integerToInt64 (I_ sa, StgByteArray /* Really: mp_limb_t* */ da);
228 LW_ stg_integerToWord64 (I_ sa, StgByteArray /* Really: mp_limb_t* */ da);
232 /* -----------------------------------------------------------------------------
234 -------------------------------------------------------------------------- */
236 /* We cast to void* instead of StgChar* because this avoids a warning
237 * about increasing the alignment requirements.
239 #define REAL_BYTE_ARR_CTS(a) ((void *) (((StgArrWords *)(a))->payload))
240 #define REAL_PTRS_ARR_CTS(a) ((P_) (((StgMutArrPtrs *)(a))->payload))
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); })
251 #define BYTE_ARR_CTS(a) REAL_BYTE_ARR_CTS(a)
252 #define PTRS_ARR_CTS(a) REAL_PTRS_ARR_CTS(a)
256 extern I_ genSymZh(void);
257 extern I_ resetGenSymZh(void);
259 /*--- Almost everything in line. */
261 EXTFUN_RTS(unsafeThawArrayzh_fast);
262 EXTFUN_RTS(newByteArrayzh_fast);
263 EXTFUN_RTS(newPinnedByteArrayzh_fast);
264 EXTFUN_RTS(newArrayzh_fast);
266 /* The decode operations are out-of-line because they need to allocate
270 /* We only support IEEE floating point formats. */
271 #include "ieee-flpt.h"
272 EXTFUN_RTS(decodeFloatzh_fast);
273 EXTFUN_RTS(decodeDoublezh_fast);
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);
292 /* -----------------------------------------------------------------------------
295 newMutVar is out of line.
296 -------------------------------------------------------------------------- */
298 EXTFUN_RTS(newMutVarzh_fast);
301 /* -----------------------------------------------------------------------------
304 All out of line, because they either allocate or may block.
305 -------------------------------------------------------------------------- */
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);
315 /* -----------------------------------------------------------------------------
317 -------------------------------------------------------------------------- */
319 EXTFUN_RTS(waitReadzh_fast);
320 EXTFUN_RTS(waitWritezh_fast);
321 EXTFUN_RTS(delayzh_fast);
324 /* -----------------------------------------------------------------------------
325 Primitive I/O, error-handling PrimOps
326 -------------------------------------------------------------------------- */
328 EXTFUN_RTS(catchzh_fast);
329 EXTFUN_RTS(raisezh_fast);
331 extern void stg_exit(I_ n) __attribute__ ((noreturn));
334 /* -----------------------------------------------------------------------------
335 Stable Name / Stable Pointer PrimOps
336 -------------------------------------------------------------------------- */
338 EXTFUN_RTS(makeStableNamezh_fast);
339 EXTFUN_RTS(makeStablePtrzh_fast);
340 EXTFUN_RTS(deRefStablePtrzh_fast);
343 /* -----------------------------------------------------------------------------
344 Concurrency/Exception PrimOps.
345 -------------------------------------------------------------------------- */
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);
355 extern int cmp_thread(const StgTSO *tso1, const StgTSO *tso2);
356 extern int rts_getThreadId(const StgTSO *tso);
359 /* -----------------------------------------------------------------------------
360 Weak Pointer PrimOps.
361 -------------------------------------------------------------------------- */
363 EXTFUN_RTS(mkWeakzh_fast);
364 EXTFUN_RTS(finalizzeWeakzh_fast);
365 EXTFUN_RTS(deRefWeakzh_fast);
368 /* -----------------------------------------------------------------------------
369 Foreign Object PrimOps.
370 -------------------------------------------------------------------------- */
372 EXTFUN_RTS(mkForeignObjzh_fast);
375 /* -----------------------------------------------------------------------------
377 -------------------------------------------------------------------------- */
379 EXTFUN_RTS(newBCOzh_fast);
380 EXTFUN_RTS(mkApUpd0zh_fast);
383 /* -----------------------------------------------------------------------------
384 Signal handling. Not really primops, but called directly from Haskell.
385 -------------------------------------------------------------------------- */
387 #define STG_SIG_DFL (-1)
388 #define STG_SIG_IGN (-2)
389 #define STG_SIG_ERR (-3)
390 #define STG_SIG_HAN (-4)
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)
398 /* ------------------------------------------------------------------------
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 ---------------------------------------------------------------------- */
412 #define parzh(r,node) parAny(r,node,1,0,0,0,0,0)
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)
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)
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)
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)
430 #define parAT(r,node,where,identifier,gran_info,size_info,par_info,rest,local) \
432 if (closure_SHOULD_SPARK((StgClosure*)node)) { \
436 STGCALL6(newSpark, node,identifier,gran_info,size_info,par_info,local); \
438 case 2: p = where; /* parAtAbs means absolute PE no. expected */ \
440 case 3: p = CurrentProc+where; /* parAtRel means rel PE no. expected */\
442 default: p = where_is(where); /* parAt means closure expected */ \
445 /* update GranSim state according to this spark */ \
446 STGCALL3(GranSimSparkAtAbs, result, (I_)p, identifier); \
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)
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)
458 #define parAny(r,node,rest,identifier,gran_info,size_info,par_info,local) \
460 if (closure_SHOULD_SPARK((StgClosure*)node)) { \
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); \
469 #define copyablezh(r,node) \
470 /* copyable not yet implemented!! */
472 #define noFollowzh(r,node) \
473 /* noFollow not yet implemented!! */
475 #elif defined(SMP) || defined(PAR)
477 #define parzh(r,node) \
479 extern unsigned int context_switch; \
480 if (closure_SHOULD_SPARK((StgClosure *)node) && \
481 SparkTl < SparkLim) { \
482 *SparkTl++ = (StgClosure *)(node); \
484 r = context_switch = 1; \
486 #else /* !GRAN && !SMP && !PAR */
487 #define parzh(r,node) r = 1
490 /* -----------------------------------------------------------------------------
491 ForeignObj - the C backend still needs this.
492 -------------------------------------------------------------------------- */
493 #define ForeignObj_CLOSURE_DATA(c) (((StgForeignObj *)c)->data)
495 #endif /* PRIMOPS_H */