[project @ 2003-08-01 15:38:41 by panne]
[ghc-hetmet.git] / ghc / includes / PrimOps.h
1 /* -----------------------------------------------------------------------------
2  * $Id: PrimOps.h,v 1.103 2003/07/03 15:14:57 sof 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 RTS_CARRY_IDX__ 0
52 #define RTS_REM_IDX__  1
53 #else
54 #define RTS_CARRY_IDX__ 1
55 #define RTS_REM_IDX__ 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[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);                    \
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 EXTFUN_RTS(atomicModifyMutVarzh_fast);
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 #ifdef mingw32_TARGET_OS
245 EXTFUN_RTS(asyncReadzh_fast);
246 EXTFUN_RTS(asyncWritezh_fast);
247 EXTFUN_RTS(asyncDoProczh_fast);
248 #endif
249
250
251 /* -----------------------------------------------------------------------------
252    Primitive I/O, error-handling PrimOps
253    -------------------------------------------------------------------------- */
254
255 EXTFUN_RTS(catchzh_fast);
256 EXTFUN_RTS(raisezh_fast);
257 EXTFUN_RTS(raiseIOzh_fast);
258
259 extern void stg_exit(int n)  __attribute__ ((noreturn));
260
261
262 /* -----------------------------------------------------------------------------
263    Stable Name / Stable Pointer  PrimOps
264    -------------------------------------------------------------------------- */
265
266 EXTFUN_RTS(makeStableNamezh_fast);
267 EXTFUN_RTS(makeStablePtrzh_fast);
268 EXTFUN_RTS(deRefStablePtrzh_fast);
269
270
271 /* -----------------------------------------------------------------------------
272    Concurrency/Exception PrimOps.
273    -------------------------------------------------------------------------- */
274
275 EXTFUN_RTS(forkzh_fast);
276 EXTFUN_RTS(forkProcesszh_fast);
277 EXTFUN_RTS(yieldzh_fast);
278 EXTFUN_RTS(killThreadzh_fast);
279 EXTFUN_RTS(seqzh_fast);
280 EXTFUN_RTS(blockAsyncExceptionszh_fast);
281 EXTFUN_RTS(unblockAsyncExceptionszh_fast);
282 EXTFUN_RTS(myThreadIdzh_fast);
283 EXTFUN_RTS(labelThreadzh_fast);
284
285 extern int cmp_thread(StgPtr tso1, StgPtr tso2);
286 extern int rts_getThreadId(StgPtr tso);
287
288 /* -----------------------------------------------------------------------------
289    Weak Pointer PrimOps.
290    -------------------------------------------------------------------------- */
291
292 EXTFUN_RTS(mkWeakzh_fast);
293 EXTFUN_RTS(finalizzeWeakzh_fast);
294 EXTFUN_RTS(deRefWeakzh_fast);
295
296
297 /* -----------------------------------------------------------------------------
298    Foreign Object PrimOps.
299    -------------------------------------------------------------------------- */
300
301 EXTFUN_RTS(mkForeignObjzh_fast);
302
303
304 /* -----------------------------------------------------------------------------
305    Constructor tags
306    -------------------------------------------------------------------------- */
307
308 /*
309  * This macro is only used when compiling unregisterised code (see 
310  * AbsCUtils.dsCOpStmt for motivation & the Story).
311  */
312 #ifndef TABLES_NEXT_TO_CODE
313 # define dataToTagzh(r,a)  r=(GET_TAG(((StgClosure *)a)->header.info))
314 #endif
315
316 /* -----------------------------------------------------------------------------
317    BCOs and BCO linkery
318    -------------------------------------------------------------------------- */
319
320 EXTFUN_RTS(newBCOzh_fast);
321 EXTFUN_RTS(mkApUpd0zh_fast);
322
323 /* ------------------------------------------------------------------------
324    Parallel PrimOps
325
326    A par in the Haskell code is ultimately translated to a parzh macro
327    (with a case wrapped around it to guarantee that the macro is actually 
328     executed; see compiler/prelude/PrimOps.lhs)
329    In GUM and SMP we only add a pointer to the spark pool.
330    In GranSim we call an RTS fct, forwarding additional parameters which
331    supply info on granularity of the computation, size of the result value
332    and the degree of parallelism in the sparked expression.
333    ---------------------------------------------------------------------- */
334
335 #if defined(GRAN)
336 //@cindex _par_
337 #define parzh(r,node)             parAny(r,node,1,0,0,0,0,0)
338
339 //@cindex _parAt_
340 #define parAtzh(r,node,where,identifier,gran_info,size_info,par_info,rest) \
341         parAT(r,node,where,identifier,gran_info,size_info,par_info,rest,1)
342
343 //@cindex _parAtAbs_
344 #define parAtAbszh(r,node,proc,identifier,gran_info,size_info,par_info,rest) \
345         parAT(r,node,proc,identifier,gran_info,size_info,par_info,rest,2)
346
347 //@cindex _parAtRel_
348 #define parAtRelzh(r,node,proc,identifier,gran_info,size_info,par_info,rest) \
349         parAT(r,node,proc,identifier,gran_info,size_info,par_info,rest,3)
350
351 //@cindex _parAtForNow_
352 #define parAtForNowzh(r,node,where,identifier,gran_info,size_info,par_info,rest)        \
353         parAT(r,node,where,identifier,gran_info,size_info,par_info,rest,0)
354
355 #define parAT(r,node,where,identifier,gran_info,size_info,par_info,rest,local)  \
356 {                                                               \
357   if (closure_SHOULD_SPARK((StgClosure*)node)) {                \
358     rtsSparkQ result;                                           \
359     PEs p;                                                      \
360                                                                 \
361     STGCALL6(newSpark, node,identifier,gran_info,size_info,par_info,local); \
362     switch (local) {                                                        \
363       case 2: p = where;  /* parAtAbs means absolute PE no. expected */     \
364               break;                                                        \
365       case 3: p = CurrentProc+where; /* parAtRel means rel PE no. expected */\
366               break;                                                        \
367       default: p = where_is(where); /* parAt means closure expected */      \
368               break;                                                        \
369     }                                                                       \
370     /* update GranSim state according to this spark */                      \
371     STGCALL3(GranSimSparkAtAbs, result, (I_)p, identifier);                 \
372   }                                                                         \
373 }
374
375 //@cindex _parLocal_
376 #define parLocalzh(r,node,identifier,gran_info,size_info,par_info,rest) \
377         parAny(r,node,rest,identifier,gran_info,size_info,par_info,1)
378
379 //@cindex _parGlobal_
380 #define parGlobalzh(r,node,identifier,gran_info,size_info,par_info,rest) \
381         parAny(r,node,rest,identifier,gran_info,size_info,par_info,0)
382
383 #define parAny(r,node,rest,identifier,gran_info,size_info,par_info,local) \
384 {                                                                        \
385   if (closure_SHOULD_SPARK((StgClosure*)node)) {                         \
386     rtsSpark *result;                                                    \
387     result = RET_STGCALL6(rtsSpark*, newSpark,                           \
388                           node,identifier,gran_info,size_info,par_info,local);\
389     STGCALL1(add_to_spark_queue,result);                                \
390     STGCALL2(GranSimSpark, local,(P_)node);                             \
391   }                                                                     \
392 }
393
394 #define copyablezh(r,node)                              \
395   /* copyable not yet implemented!! */
396
397 #define noFollowzh(r,node)                              \
398   /* noFollow not yet implemented!! */
399
400 #elif defined(SMP) || defined(PAR)
401
402 #define parzh(r,node)                                   \
403 {                                                       \
404   extern unsigned int context_switch;                   \
405   if (closure_SHOULD_SPARK((StgClosure *)node) &&       \
406       SparkTl < SparkLim) {                             \
407     *SparkTl++ = (StgClosure *)(node);                  \
408   }                                                     \
409   r = context_switch = 1;                               \
410 }
411 #else /* !GRAN && !SMP && !PAR */
412 #define parzh(r,node) r = 1
413 #endif
414
415 /* -----------------------------------------------------------------------------
416    ForeignObj - the C backend still needs this. 
417    -------------------------------------------------------------------------- */
418 #define ForeignObj_CLOSURE_DATA(c)  (((StgForeignObj *)c)->data)
419
420 #endif /* PRIMOPS_H */