X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Frts%2FPrimOps.hc;h=134ed1bc0d83c08a89355df53ead97e1b700d95f;hb=d28ae8e1a272c7827622b2b83f1d779402732103;hp=f39768c707bc38c688e68730a60a0a002cc614a1;hpb=3aa14dd83b4fdb99e68f428616c2a9207286b275;p=ghc-hetmet.git

diff --git a/ghc/rts/PrimOps.hc b/ghc/rts/PrimOps.hc
index f39768c..134ed1b 100644
--- a/ghc/rts/PrimOps.hc
+++ b/ghc/rts/PrimOps.hc
@@ -1,5 +1,5 @@
 /* -----------------------------------------------------------------------------
- * $Id: PrimOps.hc,v 1.109 2003/07/12 00:08:28 sof Exp $
+ * $Id: PrimOps.hc,v 1.116 2004/01/08 15:26:44 simonmar Exp $
  *
  * (c) The GHC Team, 1998-2002
  *
@@ -188,7 +188,7 @@ StgWord GHC_ZCCReturnable_static_info[1];
 #define PUSHED(m)   Sp -= (m); JMP_(ENTRY_CODE(Sp[m]));
 
 # define RET_P(a)     PUSH(1,a); PUSHED(1)
-# define RET_N(a)     PUSH(1,a); PUSHED(2)
+# define RET_N(a)     PUSH(1,a); PUSHED(1)
 
 # define RET_PP(a,b)   PUSH(2,a); PUSH(1,b); PUSHED(2)
 # define RET_NN(a,b)   PUSH(2,a); PUSH(1,b); PUSHED(2)
@@ -402,7 +402,22 @@ FN_(unsafeThawArrayzh_fast)
 {
   FB_
   SET_INFO((StgClosure *)R1.cl,&stg_MUT_ARR_PTRS_info);
-  recordMutable((StgMutClosure*)R1.cl);
+
+  // SUBTLETY TO DO WITH THE OLD GEN MUTABLE LIST
+  //
+  // A MUT_ARR_PTRS lives on the mutable list, but a MUT_ARR_PTRS_FROZEN 
+  // normally doesn't.  However, when we freeze a MUT_ARR_PTRS, we leave
+  // it on the mutable list for the GC to remove (removing something from
+  // the mutable list is not easy, because the mut_list is only singly-linked).
+  // 
+  // So, when we thaw a MUT_ARR_PTRS_FROZEN, we must cope with two cases:
+  // either it is on a mut_list, or it isn't.  We adopt the convention that
+  // the mut_link field is NULL if it isn't on a mut_list, and the GC
+  // maintains this invariant.
+  //
+  if (((StgMutArrPtrs *)R1.cl)->mut_link == NULL) {
+	recordMutable((StgMutClosure*)R1.cl);
+  }
 
   TICK_RET_UNBOXED_TUP(1);
   RET_P(R1.p);
@@ -1053,20 +1068,6 @@ FN_(forkzh_fast)
   FE_
 }
 
-FN_(forkProcesszh_fast)
-{
-  pid_t pid;
-
-  FB_
-  /* args: none */
-  /* result: Pid */
-
-  R1.i = RET_STGCALL1(StgInt, forkProcess, CurrentTSO);
-
-  RET_N(R1.i);
-  FE_
-}
-
 FN_(yieldzh_fast)
 {
   FB_
@@ -1095,6 +1096,15 @@ FN_(labelThreadzh_fast)
   FE_
 }
 
+FN_(isCurrentThreadBoundzh_fast)
+{
+  /* no args */
+  I_ r;
+  FB_
+  r = (I_)(RET_STGCALL1(StgBool, isThreadBound, CurrentTSO));
+  RET_N(r);
+  FE_
+}
 
 /* -----------------------------------------------------------------------------
  * MVar primitives
@@ -1627,14 +1637,14 @@ FN_(delayzh_fast)
   nat target;
 #endif
   FB_
-    /* args: R1.i */
+    /* args: R1.i (microsecond delay amount) */
     ASSERT(CurrentTSO->why_blocked == NotBlocked);
     CurrentTSO->why_blocked = BlockedOnDelay;
 
     ACQUIRE_LOCK(&sched_mutex);
 #ifdef mingw32_TARGET_OS
     /* could probably allocate this on the heap instead */
-    ares = (StgAsyncIOResult*)RET_STGCALL2(P_,stgMallocBytes,sizeof(StgAsyncIOResult), "asyncWritezh_fast");
+    ares = (StgAsyncIOResult*)RET_STGCALL2(P_,stgMallocBytes,sizeof(StgAsyncIOResult), "delayzh_fast");
     reqID = RET_STGCALL1(W_,addDelayRequest,R1.i);
     ares->reqID   = reqID;
     ares->len     = 0;
@@ -1646,7 +1656,7 @@ FN_(delayzh_fast)
     CurrentTSO->why_blocked = BlockedOnDoProc;
     APPEND_TO_BLOCKED_QUEUE(CurrentTSO);
 #else
-    target = (R1.i / (TICK_MILLISECS*1000)) + getourtimeofday();
+    target = ((R1.i + TICK_MILLISECS*1000-1) / (TICK_MILLISECS*1000)) + getourtimeofday();
     CurrentTSO->block_info.target = target;
 
     /* Insert the new thread in the sleeping queue. */
@@ -1736,3 +1746,4 @@ FN_(asyncDoProczh_fast)
   FE_
 }
 #endif
+