/* -----------------------------------------------------------------------------
- * $Id: PrimOps.hc,v 1.80 2001/07/23 17:23:19 simonmar Exp $
+ * $Id: PrimOps.hc,v 1.87 2001/12/06 13:05:03 sewardj Exp $
*
* (c) The GHC Team, 1998-2000
*
#include "Storage.h"
#include "BlockAlloc.h" /* tmp */
#include "StablePriv.h"
-#include "HeapStackCheck.h"
#include "StgRun.h"
#include "Itimer.h"
#include "Prelude.h"
FE_ \
}
+FN_(newPinnedByteArrayzh_fast) \
+ { \
+ W_ size, stuff_size, n; \
+ StgArrWords* p; \
+ FB_ \
+ MAYBE_GC(NO_PTRS,newPinnedByteArrayzh_fast); \
+ n = R1.w; \
+ stuff_size = BYTES_TO_STGWORDS(n); \
+ size = sizeofW(StgArrWords)+ stuff_size; \
+ p = (StgArrWords *)RET_STGCALL1(P_,allocatePinned,size); \
+ TICK_ALLOC_PRIM(sizeofW(StgArrWords),stuff_size,0); \
+ SET_HDR(p, &stg_ARR_WORDS_info, CCCS); \
+ p->words = stuff_size; \
+ TICK_RET_UNBOXED_TUP(1) \
+ RET_P(p); \
+ FE_ \
+ }
+
FN_(newArrayzh_fast)
{
W_ size, n, init;
/* -----------------------------------------------------------------------------
Foreign Object Primitives
-
-------------------------------------------------------------------------- */
FN_(mkForeignObjzh_fast)
}
/* kill it */
+#ifdef PROFILING
+ // @LDV profiling
+ // A weak pointer is inherently used, so we do not need to call
+ // LDV_recordDead_FILL_SLOP_DYNAMIC():
+ // LDV_recordDead_FILL_SLOP_DYNAMIC((StgClosure *)w);
+ // or, LDV_recordDead():
+ // LDV_recordDead((StgClosure *)w, sizeofW(StgWeak) - sizeofW(StgProfHeader));
+ // Furthermore, when PROFILING is turned on, dead weak pointers are exactly as
+ // large as weak pointers, so there is no need to fill the slop, either.
+ // See stg_DEAD_WEAK_info in StgMiscClosures.hc.
+#endif
+ //
+ // Todo: maybe use SET_HDR() and remove LDV_recordCreate()?
+ //
w->header.info = &stg_DEAD_WEAK_info;
+#ifdef PROFILING
+ // @LDV profiling
+ LDV_recordCreate((StgClosure *)w);
+#endif
f = ((StgWeak *)w)->finalizer;
w->link = ((StgWeak *)w)->link;
FE_
}
+FN_(deRefWeakzh_fast)
+{
+ /* R1.p = weak ptr */
+ StgWeak* w;
+ I_ code;
+ P_ val;
+ FB_
+ w = (StgWeak*)R1.p;
+ if (w->header.info == &stg_WEAK_info) {
+ code = 1;
+ val = (P_)((StgWeak *)w)->value;
+ } else {
+ code = 0;
+ val = (P_)w;
+ }
+ RET_NP(code,val);
+ FE_
+}
+
/* -----------------------------------------------------------------------------
Arbitrary-precision Integer operations.
-------------------------------------------------------------------------- */
FE_
}
-#elif SIZEOF_VOID_P == 8
-
-FN_(word64ToIntegerzh_fast)
-{
- FB_
- JMP_(wordToIntegerzh_fast);
- FE_
-}
-
-FN_(int64ToIntegerzh_fast)
-{
- FB_
- JMP_(intToIntegerzh_fast);
- FE_
-}
-#endif /* SUPPORT_LONG_LONGS || SIZEOF_VOID_P == 8 */
+#endif /* SUPPORT_LONG_LONGS */
/* ToDo: this is shockingly inefficient */
GMP_TAKE2_RET2(quotRemIntegerzh_fast, mpz_tdiv_qr);
GMP_TAKE2_RET2(divModIntegerzh_fast, mpz_fdiv_qr);
+
+FN_(gcdIntzh_fast)
+{
+ /* R1 = the first Int#; R2 = the second Int# */
+ mp_limb_t aa;
+ I_ r;
+ FB_
+ aa = (mp_limb_t)(R1.i);
+ r = RET_STGCALL3(StgInt, mpn_gcd_1, (mp_limb_t *)(&aa), 1, (mp_limb_t)(R2.i));
+ RET_N(r);
+ FE_
+}
+
+FN_(gcdIntegerIntzh_fast)
+{
+ /* R1 = s1; R2 = d1; R3 = the int */
+ I_ r;
+ FB_
+ MAYBE_GC(R2_PTR, gcdIntegerIntzh_fast);
+ r = RET_STGCALL3(I_,mpn_gcd_1,(mp_limb_t *)(BYTE_ARR_CTS(R2.p)), R1.i, R3.i);
+ RET_N(r);
+ FE_
+}
+
+FN_(cmpIntegerIntzh_fast)
+{
+ /* R1 = s1; R2 = d1; R3 = the int */
+ MP_INT arg;
+ I_ r;
+ FB_
+ MAYBE_GC(R2_PTR, cmpIntegerIntzh_fast);
+ arg._mp_size = R1.i;
+ arg._mp_alloc = ((StgArrWords *)R2.p)->words;
+ arg._mp_d = (mp_limb_t *) (BYTE_ARR_CTS(R2.p));
+ r = RET_STGCALL2(I_,mpz_cmp_si,&arg,R3.i);
+ RET_N(r);
+ FE_
+}
+
+FN_(cmpIntegerzh_fast)
+{
+ /* R1 = s1; R2 = d1; R3 = s2; R4 = d2 */
+ MP_INT arg1, arg2;
+ I_ r;
+ FB_
+ MAYBE_GC(R2_PTR | R4_PTR, cmpIntegerIntzh_fast);
+ arg1._mp_size = R1.i;
+ arg1._mp_alloc= ((StgArrWords *)R2.p)->words;
+ arg1._mp_d = (mp_limb_t *) (BYTE_ARR_CTS(R2.p));
+ arg2._mp_size = R3.i;
+ arg2._mp_alloc= ((StgArrWords *)R4.p)->words;
+ arg2._mp_d = (mp_limb_t *) (BYTE_ARR_CTS(R4.p));
+ r = RET_STGCALL2(I_,mpz_cmp,&arg1,&arg2);
+ RET_N(r);
+ FE_
+}
+
+FN_(integer2Intzh_fast)
+{
+ /* R1 = s; R2 = d */
+ I_ r, s;
+ FB_
+ s = R1.i;
+ if (s == 0)
+ r = 0;
+ else {
+ r = ((mp_limb_t *) (BYTE_ARR_CTS(R2.p)))[0];
+ if (s < 0) r = -r;
+ }
+ RET_N(r);
+ FE_
+}
+
+FN_(integer2Wordzh_fast)
+{
+ /* R1 = s; R2 = d */
+ I_ s;
+ W_ r;
+ FB_
+ s = R1.i;
+ if (s == 0)
+ r = 0;
+ else {
+ r = ((mp_limb_t *) (BYTE_ARR_CTS(R2.p)))[0];
+ if (s < 0) r = -r;
+ }
+ RET_N(r);
+ FE_
+}
+
+
FN_(decodeFloatzh_fast)
{
MP_INT mantissa;
*
* -------------------------------------------------------------------------- */
+FN_(isEmptyMVarzh_fast)
+{
+ /* args: R1 = MVar closure */
+ I_ r;
+ FB_
+ r = (I_)((GET_INFO((StgMVar*)(R1.p))) == &stg_EMPTY_MVAR_info);
+ RET_N(r);
+ FE_
+}
+
+
FN_(newMVarzh_fast)
{
StgMVar *mvar;
RET_P(sn_obj);
}
+
+FN_(makeStablePtrzh_fast)
+{
+ /* Args: R1 = a */
+ StgStablePtr sp;
+ FB_
+ MAYBE_GC(R1_PTR, makeStablePtrzh_fast);
+ sp = RET_STGCALL1(StgStablePtr,getStablePtr,R1.p);
+ RET_N(sp);
+ FE_
+}
+
+FN_(deRefStablePtrzh_fast)
+{
+ /* Args: R1 = the stable ptr */
+ P_ r;
+ StgStablePtr sp;
+ FB_
+ sp = (StgStablePtr)R1.w;
+ r = stable_ptr_table[(StgWord)sp].addr;
+ RET_P(r);
+ FE_
+}
+
/* -----------------------------------------------------------------------------
Bytecode object primitives
------------------------------------------------------------------------- */
projects / ghc-hetmet.git / blobdiff