1 /* -----------------------------------------------------------------------------
2 * $Id: PrimOps.h,v 1.106 2003/10/01 10:57:41 wolfgang 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
51 #define RTS_CARRY_IDX__ 0
52 #define RTS_REM_IDX__ 1
54 #define RTS_CARRY_IDX__ 1
55 #define RTS_REM_IDX__ 0
63 #define mulIntMayOflo(a,b) \
67 z.l = (StgInt64)a * (StgInt64)b; \
68 r = z.i[RTS_REM_IDX__]; \
69 c = z.i[RTS_CARRY_IDX__]; \
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);
154 /* -----------------------------------------------------------------------------
156 -------------------------------------------------------------------------- */
158 /* We cast to void* instead of StgChar* because this avoids a warning
159 * about increasing the alignment requirements.
161 #define REAL_BYTE_ARR_CTS(a) ((void *) (((StgArrWords *)(a))->payload))
162 #define REAL_PTRS_ARR_CTS(a) ((P_) (((StgMutArrPtrs *)(a))->payload))
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); })
173 #define BYTE_ARR_CTS(a) REAL_BYTE_ARR_CTS(a)
174 #define PTRS_ARR_CTS(a) REAL_PTRS_ARR_CTS(a)
178 extern I_ genSymZh(void);
179 extern I_ resetGenSymZh(void);
181 /*--- Almost everything in line. */
183 EXTFUN_RTS(unsafeThawArrayzh_fast);
184 EXTFUN_RTS(newByteArrayzh_fast);
185 EXTFUN_RTS(newPinnedByteArrayzh_fast);
186 EXTFUN_RTS(newArrayzh_fast);
188 /* The decode operations are out-of-line because they need to allocate
192 /* We only support IEEE floating point formats. */
193 #include "ieee-flpt.h"
194 EXTFUN_RTS(decodeFloatzh_fast);
195 EXTFUN_RTS(decodeDoublezh_fast);
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);
214 /* -----------------------------------------------------------------------------
217 newMutVar is out of line.
218 -------------------------------------------------------------------------- */
220 EXTFUN_RTS(newMutVarzh_fast);
221 EXTFUN_RTS(atomicModifyMutVarzh_fast);
223 /* -----------------------------------------------------------------------------
226 All out of line, because they either allocate or may block.
227 -------------------------------------------------------------------------- */
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);
237 /* -----------------------------------------------------------------------------
239 -------------------------------------------------------------------------- */
241 EXTFUN_RTS(waitReadzh_fast);
242 EXTFUN_RTS(waitWritezh_fast);
243 EXTFUN_RTS(delayzh_fast);
244 #ifdef mingw32_TARGET_OS
245 EXTFUN_RTS(asyncReadzh_fast);
246 EXTFUN_RTS(asyncWritezh_fast);
247 EXTFUN_RTS(asyncDoProczh_fast);
251 /* -----------------------------------------------------------------------------
252 Primitive I/O, error-handling PrimOps
253 -------------------------------------------------------------------------- */
255 EXTFUN_RTS(catchzh_fast);
256 EXTFUN_RTS(raisezh_fast);
257 EXTFUN_RTS(raiseIOzh_fast);
259 extern void stg_exit(int n) __attribute__ ((noreturn));
262 /* -----------------------------------------------------------------------------
263 Stable Name / Stable Pointer PrimOps
264 -------------------------------------------------------------------------- */
266 EXTFUN_RTS(makeStableNamezh_fast);
267 EXTFUN_RTS(makeStablePtrzh_fast);
268 EXTFUN_RTS(deRefStablePtrzh_fast);
271 /* -----------------------------------------------------------------------------
272 Concurrency/Exception PrimOps.
273 -------------------------------------------------------------------------- */
275 EXTFUN_RTS(forkzh_fast);
276 EXTFUN_RTS(yieldzh_fast);
277 EXTFUN_RTS(killThreadzh_fast);
278 EXTFUN_RTS(seqzh_fast);
279 EXTFUN_RTS(blockAsyncExceptionszh_fast);
280 EXTFUN_RTS(unblockAsyncExceptionszh_fast);
281 EXTFUN_RTS(myThreadIdzh_fast);
282 EXTFUN_RTS(labelThreadzh_fast);
283 EXTFUN_RTS(isCurrentThreadBoundzh_fast);
285 extern int cmp_thread(StgPtr tso1, StgPtr tso2);
286 extern int rts_getThreadId(StgPtr tso);
287 extern int forkOS_createThread ( HsStablePtr entry );
289 /* -----------------------------------------------------------------------------
290 Weak Pointer PrimOps.
291 -------------------------------------------------------------------------- */
293 EXTFUN_RTS(mkWeakzh_fast);
294 EXTFUN_RTS(finalizzeWeakzh_fast);
295 EXTFUN_RTS(deRefWeakzh_fast);
298 /* -----------------------------------------------------------------------------
299 Foreign Object PrimOps.
300 -------------------------------------------------------------------------- */
302 EXTFUN_RTS(mkForeignObjzh_fast);
305 /* -----------------------------------------------------------------------------
307 -------------------------------------------------------------------------- */
310 * This macro is only used when compiling unregisterised code (see
311 * AbsCUtils.dsCOpStmt for motivation & the Story).
313 #ifndef TABLES_NEXT_TO_CODE
314 # define dataToTagzh(r,a) r=(GET_TAG(((StgClosure *)a)->header.info))
317 /* -----------------------------------------------------------------------------
319 -------------------------------------------------------------------------- */
321 EXTFUN_RTS(newBCOzh_fast);
322 EXTFUN_RTS(mkApUpd0zh_fast);
324 /* ------------------------------------------------------------------------
327 A par in the Haskell code is ultimately translated to a parzh macro
328 (with a case wrapped around it to guarantee that the macro is actually
329 executed; see compiler/prelude/PrimOps.lhs)
330 In GUM and SMP we only add a pointer to the spark pool.
331 In GranSim we call an RTS fct, forwarding additional parameters which
332 supply info on granularity of the computation, size of the result value
333 and the degree of parallelism in the sparked expression.
334 ---------------------------------------------------------------------- */
338 #define parzh(r,node) parAny(r,node,1,0,0,0,0,0)
341 #define parAtzh(r,node,where,identifier,gran_info,size_info,par_info,rest) \
342 parAT(r,node,where,identifier,gran_info,size_info,par_info,rest,1)
345 #define parAtAbszh(r,node,proc,identifier,gran_info,size_info,par_info,rest) \
346 parAT(r,node,proc,identifier,gran_info,size_info,par_info,rest,2)
349 #define parAtRelzh(r,node,proc,identifier,gran_info,size_info,par_info,rest) \
350 parAT(r,node,proc,identifier,gran_info,size_info,par_info,rest,3)
352 //@cindex _parAtForNow_
353 #define parAtForNowzh(r,node,where,identifier,gran_info,size_info,par_info,rest) \
354 parAT(r,node,where,identifier,gran_info,size_info,par_info,rest,0)
356 #define parAT(r,node,where,identifier,gran_info,size_info,par_info,rest,local) \
358 if (closure_SHOULD_SPARK((StgClosure*)node)) { \
362 STGCALL6(newSpark, node,identifier,gran_info,size_info,par_info,local); \
364 case 2: p = where; /* parAtAbs means absolute PE no. expected */ \
366 case 3: p = CurrentProc+where; /* parAtRel means rel PE no. expected */\
368 default: p = where_is(where); /* parAt means closure expected */ \
371 /* update GranSim state according to this spark */ \
372 STGCALL3(GranSimSparkAtAbs, result, (I_)p, identifier); \
377 #define parLocalzh(r,node,identifier,gran_info,size_info,par_info,rest) \
378 parAny(r,node,rest,identifier,gran_info,size_info,par_info,1)
380 //@cindex _parGlobal_
381 #define parGlobalzh(r,node,identifier,gran_info,size_info,par_info,rest) \
382 parAny(r,node,rest,identifier,gran_info,size_info,par_info,0)
384 #define parAny(r,node,rest,identifier,gran_info,size_info,par_info,local) \
386 if (closure_SHOULD_SPARK((StgClosure*)node)) { \
388 result = RET_STGCALL6(rtsSpark*, newSpark, \
389 node,identifier,gran_info,size_info,par_info,local);\
390 STGCALL1(add_to_spark_queue,result); \
391 STGCALL2(GranSimSpark, local,(P_)node); \
395 #define copyablezh(r,node) \
396 /* copyable not yet implemented!! */
398 #define noFollowzh(r,node) \
399 /* noFollow not yet implemented!! */
401 #elif defined(SMP) || defined(PAR)
403 #define parzh(r,node) \
405 extern unsigned int context_switch; \
406 if (closure_SHOULD_SPARK((StgClosure *)node) && \
407 SparkTl < SparkLim) { \
408 *SparkTl++ = (StgClosure *)(node); \
410 r = context_switch = 1; \
412 #else /* !GRAN && !SMP && !PAR */
413 #define parzh(r,node) r = 1
416 /* -----------------------------------------------------------------------------
417 ForeignObj - the C backend still needs this.
418 -------------------------------------------------------------------------- */
419 #define ForeignObj_CLOSURE_DATA(c) (((StgForeignObj *)c)->data)
422 #endif /* PRIMOPS_H */