X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Frts%2FPrimOps.hc;h=b948f1f38752ffefa23cd05487faada74d5e1ccd;hb=042f30fe101324186002581902ea2989345c62c5;hp=364e20ab6f8150168ced04fcbf5656ba0d081c06;hpb=52c078343e70a170441fed71480ba8569475c4cd;p=ghc-hetmet.git

diff --git a/ghc/rts/PrimOps.hc b/ghc/rts/PrimOps.hc
index 364e20a..b948f1f 100644
--- a/ghc/rts/PrimOps.hc
+++ b/ghc/rts/PrimOps.hc
@@ -1,5 +1,5 @@
 /* -----------------------------------------------------------------------------
- * $Id: PrimOps.hc,v 1.83 2001/08/08 10:50:37 simonmar Exp $
+ * $Id: PrimOps.hc,v 1.94 2002/03/02 17:40:24 sof Exp $
  *
  * (c) The GHC Team, 1998-2000
  *
@@ -18,7 +18,6 @@
 #include "Storage.h"
 #include "BlockAlloc.h" /* tmp */
 #include "StablePriv.h"
-#include "HeapStackCheck.h"
 #include "StgRun.h"
 #include "Itimer.h"
 #include "Prelude.h"
@@ -330,7 +329,6 @@ FN_(newMutVarzh_fast)
 
 /* -----------------------------------------------------------------------------
    Foreign Object Primitives
-
    -------------------------------------------------------------------------- */
 
 FN_(mkForeignObjzh_fast)
@@ -421,7 +419,25 @@ FN_(finalizzeWeakzh_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;
 
@@ -434,6 +450,25 @@ FN_(finalizzeWeakzh_fast)
   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.
    -------------------------------------------------------------------------- */
@@ -734,6 +769,161 @@ GMP_TAKE1_RET1(complementIntegerzh_fast, mpz_com);
 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));
+
+  R1.i = r;
+  /* Result parked in R1, return via info-pointer at TOS */
+  JMP_(ENTRY_CODE(Sp[0]));
+  FE_
+}
+
+FN_(gcdIntegerIntzh_fast)
+{
+  /* R1 = s1; R2 = d1; R3 = the int */
+  I_ r;
+  FB_
+  r = RET_STGCALL3(StgInt,mpn_gcd_1,(mp_limb_t *)(BYTE_ARR_CTS(R2.p)), R1.i, R3.i);
+
+  R1.i = r;
+  /* Result parked in R1, return via info-pointer at TOS */
+  JMP_(ENTRY_CODE(Sp[0]));
+  FE_
+}
+
+FN_(cmpIntegerIntzh_fast)
+{
+  /* R1 = s1; R2 = d1; R3 = the int */
+  I_ usize;
+  I_ vsize;
+  I_ v_digit;
+  mp_limb_t u_digit;
+  FB_
+
+  usize = R1.i;
+  vsize = 0;
+  v_digit = R3.i;
+
+  // paraphrased from mpz_cmp_si() in the GMP sources
+  if (v_digit > 0) {
+      vsize = 1;
+  } else if (v_digit < 0) {
+      vsize = -1;
+      v_digit = -v_digit;
+  }
+
+  if (usize != vsize) {
+    R1.i = usize - vsize; JMP_(ENTRY_CODE(Sp[0]));
+  }
+
+  if (usize == 0) {
+    R1.i = 0; JMP_(ENTRY_CODE(Sp[0]));
+  }
+
+  u_digit = *(mp_limb_t *)(BYTE_ARR_CTS(R2.p));
+
+  if (u_digit == (mp_limb_t) (unsigned long) v_digit) {
+    R1.i = 0; JMP_(ENTRY_CODE(Sp[0]));
+  }
+
+  if (u_digit > (mp_limb_t) (unsigned long) v_digit) {
+    R1.i = usize; 
+  } else {
+    R1.i = -usize; 
+  }
+
+  JMP_(ENTRY_CODE(Sp[0]));
+  FE_
+}
+
+FN_(cmpIntegerzh_fast)
+{
+  /* R1 = s1; R2 = d1; R3 = s2; R4 = d2 */
+  I_ usize;
+  I_ vsize;
+  I_ size;
+  StgPtr up, vp;
+  int cmp;
+  FB_
+
+  // paraphrased from mpz_cmp() in the GMP sources
+  usize = R1.i;
+  vsize = R3.i;
+
+  if (usize != vsize) {
+    R1.i = usize - vsize; JMP_(ENTRY_CODE(Sp[0]));
+  }
+
+  if (usize == 0) {
+    R1.i = 0; JMP_(ENTRY_CODE(Sp[0]));
+  }
+
+  size = abs(usize);
+
+  up = BYTE_ARR_CTS(R2.p);
+  vp = BYTE_ARR_CTS(R4.p);
+
+  cmp = RET_STGCALL3(I_, mpn_cmp, (mp_limb_t *)up, (mp_limb_t *)vp, size);
+
+  if (cmp == 0) {
+    R1.i = 0; JMP_(ENTRY_CODE(Sp[0]));
+  }
+
+  if ((cmp < 0) == (usize < 0)) {
+    R1.i = 1;
+  } else {
+    R1.i = (-1); 
+  }
+  /* Result parked in R1, return via info-pointer at TOS */
+  JMP_(ENTRY_CODE(Sp[0]));
+  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;
+  }
+  /* Result parked in R1, return via info-pointer at TOS */
+  R1.i = r;
+  JMP_(ENTRY_CODE(Sp[0]));
+  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;
+  }
+  /* Result parked in R1, return via info-pointer at TOS */
+  R1.w = r;
+  JMP_(ENTRY_CODE(Sp[0]));
+  FE_
+}
+
+
 FN_(decodeFloatzh_fast)
 { 
   MP_INT mantissa;
@@ -809,13 +999,13 @@ FN_(forkzh_fast)
 
   /* create it right now, return ThreadID in R1 */
   R1.t = RET_STGCALL2(StgTSO *, createIOThread, 
-		      RtsFlags.GcFlags.initialStkSize, R1.cl);
+		     RtsFlags.GcFlags.initialStkSize, R1.cl);
   STGCALL1(scheduleThread, R1.t);
       
   /* switch at the earliest opportunity */ 
   context_switch = 1;
   
-  JMP_(ENTRY_CODE(Sp[0]));
+  RET_P(R1.t);
   FE_
 }
 
@@ -826,6 +1016,17 @@ FN_(yieldzh_fast)
   FE_
 }
 
+FN_(myThreadIdzh_fast)
+{
+  /* no args. */
+  FB_
+  RET_P((P_)CurrentTSO);
+  FE_
+}
+
+
+
+
 /* -----------------------------------------------------------------------------
  * MVar primitives
  *
@@ -858,6 +1059,17 @@ FN_(yieldzh_fast)
  *
  * -------------------------------------------------------------------------- */
 
+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;
@@ -880,14 +1092,23 @@ FN_(newMVarzh_fast)
   FE_
 }
 
-#define PerformTake(tso, value) ({			\
-    (tso)->sp[1] = (W_)value;				\
-    (tso)->sp[0] = (W_)&stg_gc_unpt_r1_ret_info;	\
+/* If R1 isn't available, pass it on the stack */
+#ifdef REG_R1
+#define PerformTake(tso, value) ({		\
+    (tso)->sp[1] = (W_)value;			\
+    (tso)->sp[0] = (W_)&stg_gc_unpt_r1_info;	\
+  })
+#else
+#define PerformTake(tso, value) ({		\
+    (tso)->sp[1] = (W_)value;			\
+    (tso)->sp[0] = (W_)&stg_ut_1_0_unreg_info;	\
   })
+#endif
+
 
 #define PerformPut(tso) ({				\
     StgClosure *val = (StgClosure *)(tso)->sp[2];	\
-    (tso)->sp[2] = (W_)&stg_gc_noregs_ret_info;		\
+    (tso)->sp[2] = (W_)&stg_gc_noregs_info;		\
     (tso)->sp += 2;					\
     val;						\
   })
@@ -1026,19 +1247,18 @@ FN_(tryTakeMVarzh_fast)
       /* unlock in the SMP case */
       SET_INFO(mvar,&stg_FULL_MVAR_info);
 #endif
-      TICK_RET_UNBOXED_TUP(1);
-      RET_P(val);
   } else {
       /* No further putMVars, MVar is now empty */
+      mvar->value = (StgClosure *)&stg_END_TSO_QUEUE_closure;
 
       /* do this last... we might have locked the MVar in the SMP case,
        * and writing the info pointer will unlock it.
        */
       SET_INFO(mvar,&stg_EMPTY_MVAR_info);
-      mvar->value = (StgClosure *)&stg_END_TSO_QUEUE_closure;
-      TICK_RET_UNBOXED_TUP(1);
-      RET_P(val);
   }
+
+  TICK_RET_UNBOXED_TUP(1);
+  RET_NP((I_)1, val);
   FE_
 }
 
@@ -1201,6 +1421,30 @@ FN_(makeStableNamezh_fast)
   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
    -------------------------------------------------------------------------  */