/* -----------------------------------------------------------------------------
- * $Id: PrimOps.h,v 1.20 1999/02/18 12:26:11 simonm Exp $
+ * $Id: PrimOps.h,v 1.46 2000/03/13 12:11:43 simonmar Exp $
*
* (c) The GHC Team, 1998-1999
*
#define zlzhzh(r,a,b) r=(I_)((a) <(b))
#define zlzezhzh(r,a,b) r=(I_)((a)<=(b))
-/* used by returning comparison primops, defined in Prims.hc. */
-extern const StgClosure *PrelBase_Bool_closure_tbl[];
-
/* -----------------------------------------------------------------------------
Char# PrimOps.
-------------------------------------------------------------------------- */
#define mulIntCzh(r,c,a,b) \
{ \
- __asm__("xor %1,%1\n\t \
+ __asm__("xorl %1,%1\n\t \
imull %2,%3\n\t \
jno 1f\n\t \
movl $1,%1\n\t \
1:" \
- : "=r" (r), "=r" (c) : "r" (a), "0" (b)); \
+ : "=r" (r), "=&r" (c) : "r" (a), "0" (b)); \
}
#elif SIZEOF_VOID_P == 4
StgInt32 i[2];
} long_long_u ;
-#define mulIntCzh(r,c,a,b) \
- long_long_u z; \
- z.l = (StgInt64)a * (StgInt64)b; \
- r = z.i[R]; \
- c = z.i[C]; \
- if (c == 0 || c == -1) { \
- c = ((StgWord)((a^b) ^ r)) \
- >> (BITS_PER_BYTE * sizeof(I_) - 1); \
- } \
+#define mulIntCzh(r,c,a,b) \
+{ \
+ long_long_u z; \
+ z.l = (StgInt64)a * (StgInt64)b; \
+ r = z.i[R]; \
+ c = z.i[C]; \
+ if (c == 0 || c == -1) { \
+ c = ((StgWord)((a^b) ^ r)) \
+ >> (BITS_PER_BYTE * sizeof(I_) - 1); \
+ } \
}
/* Careful: the carry calculation above is extremely delicate. Make sure
* you test it thoroughly after changing it.
#define xorzh(r,a,b) r=(a)^(b)
#define notzh(r,a) r=~(a)
-#define shiftLzh(r,a,b) r=(a)<<(b)
-#define shiftRLzh(r,a,b) r=(a)>>(b)
-#define iShiftLzh(r,a,b) r=(a)<<(b)
+/* The extra tests below properly define the behaviour when shifting
+ * by offsets larger than the width of the value being shifted. Doing
+ * so is undefined in C (and in fact gives different answers depending
+ * on whether the operation is constant folded or not with gcc on x86!)
+ */
+
+#define shiftLzh(r,a,b) r=((b) >= BITS_IN(W_)) ? 0 : (a)<<(b)
+#define shiftRLzh(r,a,b) r=((b) >= BITS_IN(W_)) ? 0 : (a)>>(b)
+#define iShiftLzh(r,a,b) r=((b) >= BITS_IN(W_)) ? 0 : (a)<<(b)
/* Right shifting of signed quantities is not portable in C, so
the behaviour you'll get from using these primops depends
on the whatever your C compiler is doing. ToDo: fix/document. -- sof 8/98
*/
-#define iShiftRAzh(r,a,b) r=(a)>>(b)
-#define iShiftRLzh(r,a,b) r=(a)>>(b)
+#define iShiftRAzh(r,a,b) r=((b) >= BITS_IN(I_)) ? (((a) < 0) ? -1 : 0) : (a)>>(b)
+#define iShiftRLzh(r,a,b) r=((b) >= BITS_IN(I_)) ? 0 : ((W_)(a))>>(b)
#define int2Wordzh(r,a) r=(W_)(a)
#define word2Intzh(r,a) r=(I_)(a)
/* We can do integer2Int and cmpInteger inline, since they don't need
* to allocate any memory.
+ *
+ * integer2Int# is now modular.
*/
-#define integer2Intzh(r, sa,da) \
-{ MP_INT arg; \
- \
- arg._mp_size = (sa); \
- arg._mp_alloc = ((StgArrWords *)da)->words; \
- arg._mp_d = (unsigned long int *) (BYTE_ARR_CTS(da)); \
- \
- (r) = RET_PRIM_STGCALL1(I_,mpz_get_si,&arg); \
+#define integer2Intzh(r, sa,da) \
+{ StgWord word0 = ((StgWord *)BYTE_ARR_CTS(da))[0]; \
+ int size = sa; \
+ \
+ (r) = \
+ ( size == 0 ) ? \
+ 0 : \
+ ( size < 0 && word0 != 0x8000000 ) ? \
+ -(I_)word0 : \
+ (I_)word0; \
}
-#define integer2Wordzh(r, sa,da) \
-{ MP_INT arg; \
- \
- arg._mp_size = (sa); \
- arg._mp_alloc = ((StgArrWords *)da)->words; \
- arg._mp_d = (unsigned long int *) (BYTE_ARR_CTS(da)); \
- \
- (r) = RET_PRIM_STGCALL1(I_,mpz_get_ui,&arg); \
+#define integer2Wordzh(r, sa,da) \
+{ StgWord word0 = ((StgWord *)BYTE_ARR_CTS(da))[0]; \
+ int size = sa; \
+ (r) = ( size == 0 ) ? 0 : word0 ; \
}
#define cmpIntegerzh(r, s1,d1, s2,d2) \
(r) = RET_PRIM_STGCALL2(I_,mpz_cmp_si,&arg,i); \
}
+/* I think mp_limb_t must be the same size as StgInt for this to work
+ * properly --SDM
+ */
+#define gcdIntzh(r,a,b) \
+{ StgInt aa = a; \
+ r = (aa) ? (b) ? \
+ RET_STGCALL3(StgInt, mpn_gcd_1, (mp_limb_t *)(&aa), 1, (mp_limb_t)(b)) \
+ : abs(aa) \
+ : abs(b); \
+}
+
+#define gcdIntegerIntzh(r,a,sb,b) \
+ RET_STGCALL3(StgInt, mpn_gcd_1, (unsigned long int *) b, sb, (mp_limb_t)(a))
+
/* The rest are all out-of-line: -------- */
/* Integer arithmetic */
EF_(timesIntegerzh_fast);
EF_(gcdIntegerzh_fast);
EF_(quotRemIntegerzh_fast);
+EF_(quotIntegerzh_fast);
+EF_(remIntegerzh_fast);
+EF_(divExactIntegerzh_fast);
EF_(divModIntegerzh_fast);
/* Conversions */
#define integerToWord64zh(r, sa,da) \
{ unsigned long int* d; \
I_ aa; \
- StgNat64 res; \
+ StgWord64 res; \
\
d = (unsigned long int *) (BYTE_ARR_CTS(da)); \
aa = ((StgArrWords *)da)->words; \
/* The rest are (way!) out of line, implemented via C entry points.
*/
-I_ stg_gtWord64 (StgNat64, StgNat64);
-I_ stg_geWord64 (StgNat64, StgNat64);
-I_ stg_eqWord64 (StgNat64, StgNat64);
-I_ stg_neWord64 (StgNat64, StgNat64);
-I_ stg_ltWord64 (StgNat64, StgNat64);
-I_ stg_leWord64 (StgNat64, StgNat64);
+I_ stg_gtWord64 (StgWord64, StgWord64);
+I_ stg_geWord64 (StgWord64, StgWord64);
+I_ stg_eqWord64 (StgWord64, StgWord64);
+I_ stg_neWord64 (StgWord64, StgWord64);
+I_ stg_ltWord64 (StgWord64, StgWord64);
+I_ stg_leWord64 (StgWord64, StgWord64);
I_ stg_gtInt64 (StgInt64, StgInt64);
I_ stg_geInt64 (StgInt64, StgInt64);
I_ stg_ltInt64 (StgInt64, StgInt64);
I_ stg_leInt64 (StgInt64, StgInt64);
-LW_ stg_remWord64 (StgNat64, StgNat64);
-LW_ stg_quotWord64 (StgNat64, StgNat64);
+LW_ stg_remWord64 (StgWord64, StgWord64);
+LW_ stg_quotWord64 (StgWord64, StgWord64);
LI_ stg_remInt64 (StgInt64, StgInt64);
LI_ stg_quotInt64 (StgInt64, StgInt64);
LI_ stg_minusInt64 (StgInt64, StgInt64);
LI_ stg_timesInt64 (StgInt64, StgInt64);
-LW_ stg_and64 (StgNat64, StgNat64);
-LW_ stg_or64 (StgNat64, StgNat64);
-LW_ stg_xor64 (StgNat64, StgNat64);
-LW_ stg_not64 (StgNat64);
+LW_ stg_and64 (StgWord64, StgWord64);
+LW_ stg_or64 (StgWord64, StgWord64);
+LW_ stg_xor64 (StgWord64, StgWord64);
+LW_ stg_not64 (StgWord64);
-LW_ stg_shiftL64 (StgNat64, StgInt);
-LW_ stg_shiftRL64 (StgNat64, StgInt);
+LW_ stg_shiftL64 (StgWord64, StgInt);
+LW_ stg_shiftRL64 (StgWord64, StgInt);
LI_ stg_iShiftL64 (StgInt64, StgInt);
LI_ stg_iShiftRL64 (StgInt64, StgInt);
LI_ stg_iShiftRA64 (StgInt64, StgInt);
LW_ stg_int64ToWord64 (StgInt64);
LW_ stg_wordToWord64 (StgWord);
-W_ stg_word64ToWord (StgNat64);
-LI_ stg_word64ToInt64 (StgNat64);
+W_ stg_word64ToWord (StgWord64);
+LI_ stg_word64ToInt64 (StgWord64);
#endif
/* -----------------------------------------------------------------------------
#ifdef DEBUG
#define BYTE_ARR_CTS(a) \
- ({ ASSERT(GET_INFO(a) == &ARR_WORDS_info); \
+ ({ ASSERT(GET_INFO((StgArrWords *)(a)) == &ARR_WORDS_info); \
REAL_BYTE_ARR_CTS(a); })
#define PTRS_ARR_CTS(a) \
- ({ ASSERT((GET_INFO(a) == &ARR_PTRS_info) \
- || (GET_INFO(a) == &MUT_ARR_PTRS_info)); \
+ ({ ASSERT((GET_INFO((StgMutArrPtrs *)(a)) == &MUT_ARR_PTRS_FROZEN_info) \
+ || (GET_INFO((StgMutArrPtrs *)(a)) == &MUT_ARR_PTRS_info)); \
REAL_PTRS_ARR_CTS(a); })
#else
#define BYTE_ARR_CTS(a) REAL_BYTE_ARR_CTS(a)
#define unsafeFreezzeByteArrayzh(r,a) r=(a)
+EF_(unsafeThawArrayzh_fast);
+
#define sizzeofByteArrayzh(r,a) \
r = (((StgArrWords *)(a))->words * sizeof(W_))
#define sizzeofMutableByteArrayzh(r,a) \
Delay/Wait PrimOps
-------------------------------------------------------------------------- */
-/* Hmm, I'll think about these later. */
+EF_(waitReadzh_fast);
+EF_(waitWritezh_fast);
+EF_(delayzh_fast);
/* -----------------------------------------------------------------------------
Primitive I/O, error-handling PrimOps
#endif
/* -----------------------------------------------------------------------------
- Parallel PrimOps.
+ Concurrency/Exception PrimOps.
-------------------------------------------------------------------------- */
EF_(forkzh_fast);
+EF_(yieldzh_fast);
EF_(killThreadzh_fast);
EF_(seqzh_fast);
+EF_(blockAsyncExceptionszh_fast);
+EF_(unblockAsyncExceptionszh_fast);
+
+#define myThreadIdzh(t) (t = CurrentTSO)
+
+extern int cmp_thread(const StgTSO *tso1, const StgTSO *tso2);
+
+/* ------------------------------------------------------------------------
+ Parallel PrimOps
+
+ A par in the Haskell code is ultimately translated to a parzh macro
+ (with a case wrapped around it to guarantee that the macro is actually
+ executed; see compiler/prelude/PrimOps.lhs)
+ ---------------------------------------------------------------------- */
+
+#if defined(GRAN)
+// hash coding changed from 2.10 to 4.00
+#define parzh(r,node) parZh(r,node)
+
+#define parZh(r,node) \
+ PARZh(r,node,1,0,0,0,0,0)
+
+#define parAtzh(r,node,where,identifier,gran_info,size_info,par_info,rest) \
+ parATZh(r,node,where,identifier,gran_info,size_info,par_info,rest,1)
+
+#define parAtAbszh(r,node,proc,identifier,gran_info,size_info,par_info,rest) \
+ parATZh(r,node,proc,identifier,gran_info,size_info,par_info,rest,2)
+
+#define parAtRelzh(r,node,proc,identifier,gran_info,size_info,par_info,rest) \
+ parATZh(r,node,proc,identifier,gran_info,size_info,par_info,rest,3)
+
+#define parAtForNowzh(r,node,where,identifier,gran_info,size_info,par_info,rest) \
+ parATZh(r,node,where,identifier,gran_info,size_info,par_info,rest,0)
+
+#define parATZh(r,node,where,identifier,gran_info,size_info,par_info,rest,local) \
+{ \
+ rtsSparkQ result; \
+ if (closure_SHOULD_SPARK((StgClosure*)node)) { \
+ rtsSparkQ result; \
+ STGCALL6(newSpark, node,identifier,gran_info,size_info,par_info,local); \
+ if (local==2) { /* special case for parAtAbs */ \
+ STGCALL3(GranSimSparkAtAbs, result,(I_)where,identifier);\
+ } else if (local==3) { /* special case for parAtRel */ \
+ STGCALL3(GranSimSparkAtAbs, result,(I_)(CurrentProc+where),identifier); \
+ } else { \
+ STGCALL3(GranSimSparkAt, result,where,identifier); \
+ } \
+ } \
+}
+
+#define parLocalzh(r,node,identifier,gran_info,size_info,par_info,rest) \
+ PARZh(r,node,rest,identifier,gran_info,size_info,par_info,1)
+
+#define parGlobalzh(r,node,identifier,gran_info,size_info,par_info,rest) \
+ PARZh(r,node,rest,identifier,gran_info,size_info,par_info,0)
+
+#define PARZh(r,node,rest,identifier,gran_info,size_info,par_info,local) \
+{ \
+ if (closure_SHOULD_SPARK((StgClosure*)node)) { \
+ rtsSpark *result; \
+ result = RET_STGCALL6(rtsSpark*, newSpark, \
+ node,identifier,gran_info,size_info,par_info,local);\
+ STGCALL1(add_to_spark_queue,result); \
+ STGCALL2(GranSimSpark, local,(P_)node); \
+ } \
+}
+
+#define copyablezh(r,node) \
+ /* copyable not yet implemented!! */
+
+#define noFollowzh(r,node) \
+ /* noFollow not yet implemented!! */
+
+#endif /* GRAN */
+
+#if defined(SMP) || defined(PAR)
+#define parzh(r,node) \
+{ \
+ extern unsigned int context_switch; \
+ if (closure_SHOULD_SPARK((StgClosure *)node) && \
+ SparkTl < SparkLim) { \
+ *SparkTl++ = (StgClosure *)(node); \
+ } \
+ r = context_switch = 1; \
+}
+#else
+#define parzh(r,node) r = 1
+#endif
-/* Hmm, I'll think about these later. */
/* -----------------------------------------------------------------------------
Pointer equality
-------------------------------------------------------------------------- */
#endif
/* -----------------------------------------------------------------------------
+ Constructor tags
+ -------------------------------------------------------------------------- */
+
+#define dataToTagzh(r,a) r=(GET_TAG(((StgClosure *)a)->header.info))
+/* tagToEnum# is handled directly by the code generator. */
+
+/* -----------------------------------------------------------------------------
Signal processing. Not really primops, but called directly from
Haskell.
-------------------------------------------------------------------------- */
projects / ghc-hetmet.git / blobdiff