1 /* -----------------------------------------------------------------------------
2 * $Id: PrimOps.h,v 1.94 2002/06/03 11:31:55 simonmar 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.
86 #define HALF_INT (((I_)1) << (BITS_IN (I_) / 2))
88 #define stg_abs(a) (((I_)(a)) < 0 ? -((I_)(a)) : ((I_)(a)))
90 #define mulIntMayOflo(a,b) \
93 if (stg_abs(a) >= HALF_INT || \
94 stg_abs(b) >= HALF_INT) { \
104 /* -----------------------------------------------------------------------------
106 -------------------------------------------------------------------------- */
108 /* NOTE: gcdIntzh and gcdIntegerIntzh work only for positive inputs! */
110 /* Some of these are out-of-line: -------- */
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);
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);
131 EXTFUN_RTS(int2Integerzh_fast);
132 EXTFUN_RTS(word2Integerzh_fast);
134 /* Floating-point decodings */
135 EXTFUN_RTS(decodeFloatzh_fast);
136 EXTFUN_RTS(decodeDoublezh_fast);
139 EXTFUN_RTS(andIntegerzh_fast);
140 EXTFUN_RTS(orIntegerzh_fast);
141 EXTFUN_RTS(xorIntegerzh_fast);
142 EXTFUN_RTS(complementIntegerzh_fast);
145 /* -----------------------------------------------------------------------------
147 -------------------------------------------------------------------------- */
149 #ifdef SUPPORT_LONG_LONGS
152 EXTFUN_RTS(int64ToIntegerzh_fast);
153 EXTFUN_RTS(word64ToIntegerzh_fast);
157 /* -----------------------------------------------------------------------------
159 -------------------------------------------------------------------------- */
161 /* We cast to void* instead of StgChar* because this avoids a warning
162 * about increasing the alignment requirements.
164 #define REAL_BYTE_ARR_CTS(a) ((void *) (((StgArrWords *)(a))->payload))
165 #define REAL_PTRS_ARR_CTS(a) ((P_) (((StgMutArrPtrs *)(a))->payload))
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); })
176 #define BYTE_ARR_CTS(a) REAL_BYTE_ARR_CTS(a)
177 #define PTRS_ARR_CTS(a) REAL_PTRS_ARR_CTS(a)
181 extern I_ genSymZh(void);
182 extern I_ resetGenSymZh(void);
184 /*--- Almost everything in line. */
186 EXTFUN_RTS(unsafeThawArrayzh_fast);
187 EXTFUN_RTS(newByteArrayzh_fast);
188 EXTFUN_RTS(newPinnedByteArrayzh_fast);
189 EXTFUN_RTS(newArrayzh_fast);
191 /* The decode operations are out-of-line because they need to allocate
195 /* We only support IEEE floating point formats. */
196 #include "ieee-flpt.h"
197 EXTFUN_RTS(decodeFloatzh_fast);
198 EXTFUN_RTS(decodeDoublezh_fast);
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);
217 /* -----------------------------------------------------------------------------
220 newMutVar is out of line.
221 -------------------------------------------------------------------------- */
223 EXTFUN_RTS(newMutVarzh_fast);
226 /* -----------------------------------------------------------------------------
229 All out of line, because they either allocate or may block.
230 -------------------------------------------------------------------------- */
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);
240 /* -----------------------------------------------------------------------------
242 -------------------------------------------------------------------------- */
244 EXTFUN_RTS(waitReadzh_fast);
245 EXTFUN_RTS(waitWritezh_fast);
246 EXTFUN_RTS(delayzh_fast);
249 /* -----------------------------------------------------------------------------
250 Primitive I/O, error-handling PrimOps
251 -------------------------------------------------------------------------- */
253 EXTFUN_RTS(catchzh_fast);
254 EXTFUN_RTS(raisezh_fast);
256 extern void stg_exit(I_ n) __attribute__ ((noreturn));
259 /* -----------------------------------------------------------------------------
260 Stable Name / Stable Pointer PrimOps
261 -------------------------------------------------------------------------- */
263 EXTFUN_RTS(makeStableNamezh_fast);
264 EXTFUN_RTS(makeStablePtrzh_fast);
265 EXTFUN_RTS(deRefStablePtrzh_fast);
268 /* -----------------------------------------------------------------------------
269 Concurrency/Exception PrimOps.
270 -------------------------------------------------------------------------- */
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);
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);
287 /* -----------------------------------------------------------------------------
288 Weak Pointer PrimOps.
289 -------------------------------------------------------------------------- */
291 EXTFUN_RTS(mkWeakzh_fast);
292 EXTFUN_RTS(finalizzeWeakzh_fast);
293 EXTFUN_RTS(deRefWeakzh_fast);
296 /* -----------------------------------------------------------------------------
297 Foreign Object PrimOps.
298 -------------------------------------------------------------------------- */
300 EXTFUN_RTS(mkForeignObjzh_fast);
303 /* -----------------------------------------------------------------------------
305 -------------------------------------------------------------------------- */
308 * This macro is only used when compiling unregisterised code (see
309 * AbsCUtils.dsCOpStmt for motivation & the Story).
311 #ifndef TABLES_NEXT_TO_CODE
312 # define dataToTagzh(r,a) r=(GET_TAG(((StgClosure *)a)->header.info))
315 /* -----------------------------------------------------------------------------
317 -------------------------------------------------------------------------- */
319 EXTFUN_RTS(newBCOzh_fast);
320 EXTFUN_RTS(mkApUpd0zh_fast);
323 /* -----------------------------------------------------------------------------
324 Signal handling. Not really primops, but called directly from Haskell.
325 -------------------------------------------------------------------------- */
327 #define STG_SIG_DFL (-1)
328 #define STG_SIG_IGN (-2)
329 #define STG_SIG_ERR (-3)
330 #define STG_SIG_HAN (-4)
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)
338 /* ------------------------------------------------------------------------
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 ---------------------------------------------------------------------- */
352 #define parzh(r,node) parAny(r,node,1,0,0,0,0,0)
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)
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)
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)
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)
370 #define parAT(r,node,where,identifier,gran_info,size_info,par_info,rest,local) \
372 if (closure_SHOULD_SPARK((StgClosure*)node)) { \
376 STGCALL6(newSpark, node,identifier,gran_info,size_info,par_info,local); \
378 case 2: p = where; /* parAtAbs means absolute PE no. expected */ \
380 case 3: p = CurrentProc+where; /* parAtRel means rel PE no. expected */\
382 default: p = where_is(where); /* parAt means closure expected */ \
385 /* update GranSim state according to this spark */ \
386 STGCALL3(GranSimSparkAtAbs, result, (I_)p, identifier); \
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)
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)
398 #define parAny(r,node,rest,identifier,gran_info,size_info,par_info,local) \
400 if (closure_SHOULD_SPARK((StgClosure*)node)) { \
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); \
409 #define copyablezh(r,node) \
410 /* copyable not yet implemented!! */
412 #define noFollowzh(r,node) \
413 /* noFollow not yet implemented!! */
415 #elif defined(SMP) || defined(PAR)
417 #define parzh(r,node) \
419 extern unsigned int context_switch; \
420 if (closure_SHOULD_SPARK((StgClosure *)node) && \
421 SparkTl < SparkLim) { \
422 *SparkTl++ = (StgClosure *)(node); \
424 r = context_switch = 1; \
426 #else /* !GRAN && !SMP && !PAR */
427 #define parzh(r,node) r = 1
430 /* -----------------------------------------------------------------------------
431 ForeignObj - the C backend still needs this.
432 -------------------------------------------------------------------------- */
433 #define ForeignObj_CLOSURE_DATA(c) (((StgForeignObj *)c)->data)
435 #endif /* PRIMOPS_H */