[project @ 2002-04-10 11:43:43 by stolz]

[ghc-hetmet.git] / ghc / rts / PrimOps.hc

diff --git a/ghc/rts/PrimOps.hc b/ghc/rts/PrimOps.hc
index 76159ff..d31e842 100644 (file)
--- a/ghc/rts/PrimOps.hc
+++ b/ghc/rts/PrimOps.hc
@@ -1,5 +1,5 @@
 /* -----------------------------------------------------------------------------
- * $Id: PrimOps.hc,v 1.90 2002/01/29 14:41:52 simonmar Exp $
+ * $Id: PrimOps.hc,v 1.95 2002/04/10 11:43:45 stolz Exp $
  *
  * (c) The GHC Team, 1998-2000
  *
@@ -774,11 +774,14 @@ FN_(gcdIntzh_fast)
 {
   /* R1 = the first Int#; R2 = the second Int# */
   mp_limb_t aa;
-  I_        r;
+  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);
+
+  R1.i = r;
+  /* Result parked in R1, return via info-pointer at TOS */
+  JMP_(ENTRY_CODE(Sp[0]));
   FE_
 }
 
@@ -787,42 +790,99 @@ 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);
+  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 */
-  MP_INT arg;
-  I_ r;
+  I_ usize;
+  I_ vsize;
+  I_ v_digit;
+  mp_limb_t u_digit;
   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);
+
+  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 */
-  MP_INT arg1, arg2;
-  I_ r;
+  I_ usize;
+  I_ vsize;
+  I_ size;
+  StgPtr up, vp;
+  int cmp;
   FB_
-  MAYBE_GC(R2_PTR | R4_PTR, cmpIntegerzh_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);
+
+  // 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_
 }
 
@@ -838,7 +898,9 @@ FN_(integer2Intzh_fast)
     r = ((mp_limb_t *) (BYTE_ARR_CTS(R2.p)))[0];
     if (s < 0) r = -r;
   }
-  RET_N(r);
+  /* Result parked in R1, return via info-pointer at TOS */
+  R1.i = r;
+  JMP_(ENTRY_CODE(Sp[0]));
   FE_
 }
 
@@ -855,7 +917,9 @@ FN_(integer2Wordzh_fast)
     r = ((mp_limb_t *) (BYTE_ARR_CTS(R2.p)))[0];
     if (s < 0) r = -r;
   }
-  RET_N(r);
+  /* Result parked in R1, return via info-pointer at TOS */
+  R1.w = r;
+  JMP_(ENTRY_CODE(Sp[0]));
   FE_
 }
 
@@ -935,13 +999,28 @@ 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;
   
+  RET_P(R1.t);
+  FE_
+}
+
+FN_(forkProcesszh_fast)
+{
+  pid_t pid;
+
+  FB_
+  /* args: none */
+  /* result: Pid */
+
+  R1.i = RET_STGCALL1(StgInt, forkProcess, CurrentTSO);
+
   JMP_(ENTRY_CODE(Sp[0]));
+
   FE_
 }
 
@@ -952,6 +1031,25 @@ FN_(yieldzh_fast)
   FE_
 }
 
+FN_(myThreadIdzh_fast)
+{
+  /* no args. */
+  FB_
+  RET_P((P_)CurrentTSO);
+  FE_
+}
+
+FN_(labelThreadzh_fast)
+{
+  FB_
+  /* args: R1.p = Addr# */
+#ifdef DEBUG
+  STGCALL2(labelThread,CurrentTSO,(char *)R1.p);
+#endif
+  FE_
+}
+
+
 /* -----------------------------------------------------------------------------
  * MVar primitives
  *
@@ -1017,10 +1115,19 @@ FN_(newMVarzh_fast)
   FE_
 }
 
-#define PerformTake(tso, value) ({                     \
-    (tso)->sp[1] = (W_)value;                          \
+/* 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];      \