X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Frts%2FPrimOps.hc;h=364e20ab6f8150168ced04fcbf5656ba0d081c06;hb=1b9f74f630130480a4f260f506015af846ef726d;hp=8c5c55e6e9f6efce10b2b0aaa4483116c1e4e855;hpb=50027272414438955dbc41696541cbd25da55883;p=ghc-hetmet.git

diff --git a/ghc/rts/PrimOps.hc b/ghc/rts/PrimOps.hc
index 8c5c55e..364e20a 100644
--- a/ghc/rts/PrimOps.hc
+++ b/ghc/rts/PrimOps.hc
@@ -1,5 +1,5 @@
 /* -----------------------------------------------------------------------------
- * $Id: PrimOps.hc,v 1.75 2001/03/23 16:36:21 simonmar Exp $
+ * $Id: PrimOps.hc,v 1.83 2001/08/08 10:50:37 simonmar Exp $
  *
  * (c) The GHC Team, 1998-2000
  *
@@ -263,6 +263,24 @@ FN_(newByteArrayzh_fast)				\
    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;
@@ -595,7 +613,7 @@ FN_(word64ToIntegerzh_fast)
 }
 
 
-#endif /* HAVE_LONG_LONG */
+#endif /* SUPPORT_LONG_LONGS */
 
 /* ToDo: this is shockingly inefficient */
 
@@ -808,6 +826,38 @@ FN_(yieldzh_fast)
   FE_
 }
 
+/* -----------------------------------------------------------------------------
+ * MVar primitives
+ *
+ * take & putMVar work as follows.  Firstly, an important invariant:
+ *
+ *    If the MVar is full, then the blocking queue contains only
+ *    threads blocked on putMVar, and if the MVar is empty then the
+ *    blocking queue contains only threads blocked on takeMVar.
+ *
+ * takeMvar:
+ *    MVar empty : then add ourselves to the blocking queue
+ *    MVar full  : remove the value from the MVar, and
+ *                 blocking queue empty     : return
+ *                 blocking queue non-empty : perform the first blocked putMVar
+ *                                            from the queue, and wake up the
+ *                                            thread (MVar is now full again)
+ *
+ * putMVar is just the dual of the above algorithm.
+ *
+ * How do we "perform a putMVar"?  Well, we have to fiddle around with
+ * the stack of the thread waiting to do the putMVar.  See
+ * stg_block_putmvar and stg_block_takemvar in HeapStackCheck.c for
+ * the stack layout, and the PerformPut and PerformTake macros below.
+ *
+ * It is important that a blocked take or put is woken up with the
+ * take/put already performed, because otherwise there would be a
+ * small window of vulnerability where the thread could receive an
+ * exception and never perform its take or put, and we'd end up with a
+ * deadlock.
+ *
+ * -------------------------------------------------------------------------- */
+
 FN_(newMVarzh_fast)
 {
   StgMVar *mvar;
@@ -830,6 +880,18 @@ FN_(newMVarzh_fast)
   FE_
 }
 
+#define PerformTake(tso, value) ({			\
+    (tso)->sp[1] = (W_)value;				\
+    (tso)->sp[0] = (W_)&stg_gc_unpt_r1_ret_info;	\
+  })
+
+#define PerformPut(tso) ({				\
+    StgClosure *val = (StgClosure *)(tso)->sp[2];	\
+    (tso)->sp[2] = (W_)&stg_gc_noregs_ret_info;		\
+    (tso)->sp += 2;					\
+    val;						\
+  })
+
 FN_(takeMVarzh_fast)
 {
   StgMVar *mvar;
@@ -865,16 +927,21 @@ FN_(takeMVarzh_fast)
     /* unlock the MVar */
     mvar->header.info = &stg_EMPTY_MVAR_info;
 #endif
-    BLOCK(R1_PTR, takeMVarzh_fast);
+    JMP_(stg_block_takemvar);
   }
 
+  /* we got the value... */
   val = mvar->value;
-  mvar->value = (StgClosure *)&stg_END_TSO_QUEUE_closure;
 
-  /* wake up the first thread on the queue
-   */
   if (mvar->head != (StgTSO *)&stg_END_TSO_QUEUE_closure) {
+      /* There are putMVar(s) waiting... 
+       * wake up the first thread on the queue
+       */
       ASSERT(mvar->head->why_blocked == BlockedOnMVar);
+
+      /* actually perform the putMVar for the thread that we just woke up */
+      mvar->value = PerformPut(mvar->head);
+
 #if defined(GRAN) || defined(PAR)
       /* ToDo: check 2nd arg (mvar) is right */
       mvar->head = RET_STGCALL2(StgTSO *,unblockOne,mvar->head,mvar);
@@ -884,15 +951,23 @@ FN_(takeMVarzh_fast)
       if (mvar->head == (StgTSO *)&stg_END_TSO_QUEUE_closure) {
 	  mvar->tail = (StgTSO *)&stg_END_TSO_QUEUE_closure;
       }
+#ifdef SMP
+      /* 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 */
+
+      /* 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);
   }
-
-  /* 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);
-
-  TICK_RET_UNBOXED_TUP(1);
-  RET_P(val);
   FE_
 }
 
@@ -916,21 +991,28 @@ FN_(tryTakeMVarzh_fast)
   if (info == &stg_EMPTY_MVAR_info) {
 
 #ifdef SMP
-    /* unlock the MVar */
-    mvar->header.info = &stg_EMPTY_MVAR_info;
+      /* unlock the MVar */
+      SET_INFO(mvar,&stg_EMPTY_MVAR_info);
 #endif
 
-    /* HACK: we need a pointer to pass back, so we abuse NO_FINALIZER_closure */
-    RET_NP(0, &stg_NO_FINALIZER_closure);
+      /* HACK: we need a pointer to pass back, 
+       * so we abuse NO_FINALIZER_closure
+       */
+      RET_NP(0, &stg_NO_FINALIZER_closure);
   }
 
+  /* we got the value... */
   val = mvar->value;
-  mvar->value = (StgClosure *)&stg_END_TSO_QUEUE_closure;
 
-  /* wake up the first thread on the queue
-   */
   if (mvar->head != (StgTSO *)&stg_END_TSO_QUEUE_closure) {
+      /* There are putMVar(s) waiting... 
+       * wake up the first thread on the queue
+       */
       ASSERT(mvar->head->why_blocked == BlockedOnMVar);
+
+      /* actually perform the putMVar for the thread that we just woke up */
+      mvar->value = PerformPut(mvar->head);
+
 #if defined(GRAN) || defined(PAR)
       /* ToDo: check 2nd arg (mvar) is right */
       mvar->head = RET_STGCALL2(StgTSO *,unblockOne,mvar->head,mvar);
@@ -940,15 +1022,23 @@ FN_(tryTakeMVarzh_fast)
       if (mvar->head == (StgTSO *)&stg_END_TSO_QUEUE_closure) {
 	  mvar->tail = (StgTSO *)&stg_END_TSO_QUEUE_closure;
       }
+#ifdef SMP
+      /* 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 */
+
+      /* 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);
   }
-
-  /* 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);
-
-  TICK_RET_UNBOXED_TUP(1);
-  RET_NP(1,val);
   FE_
 }
 
@@ -981,34 +1071,42 @@ FN_(putMVarzh_fast)
 
 #ifdef SMP
     /* unlock the MVar */
-    mvar->header.info = &stg_FULL_MVAR_info;
+    SET_INFO(mvar,&stg_FULL_MVAR_info);
 #endif
-    BLOCK( R1_PTR | R2_PTR, putMVarzh_fast );
+    JMP_(stg_block_putmvar);
   }
   
-  mvar->value = R2.cl;
-
-  /* wake up the first thread on the queue, it will continue with the
-   * takeMVar operation and mark the MVar empty again.
-   */
   if (mvar->head != (StgTSO *)&stg_END_TSO_QUEUE_closure) {
-    ASSERT(mvar->head->why_blocked == BlockedOnMVar);
+      /* There are takeMVar(s) waiting: wake up the first one
+       */
+      ASSERT(mvar->head->why_blocked == BlockedOnMVar);
+
+      /* actually perform the takeMVar */
+      PerformTake(mvar->head, R2.cl);
+      
 #if defined(GRAN) || defined(PAR)
-    /* ToDo: check 2nd arg (mvar) is right */
-    mvar->head = RET_STGCALL2(StgTSO *,unblockOne,mvar->head,mvar);
+      /* ToDo: check 2nd arg (mvar) is right */
+      mvar->head = RET_STGCALL2(StgTSO *,unblockOne,mvar->head,mvar);
 #else
-    mvar->head = RET_STGCALL1(StgTSO *,unblockOne,mvar->head);
+      mvar->head = RET_STGCALL1(StgTSO *,unblockOne,mvar->head);
 #endif
-    if (mvar->head == (StgTSO *)&stg_END_TSO_QUEUE_closure) {
-      mvar->tail = (StgTSO *)&stg_END_TSO_QUEUE_closure;
-    }
+      if (mvar->head == (StgTSO *)&stg_END_TSO_QUEUE_closure) {
+	  mvar->tail = (StgTSO *)&stg_END_TSO_QUEUE_closure;
+      }
+#ifdef SMP
+      /* unlocks the MVar in the SMP case */
+      SET_INFO(mvar,&stg_EMPTY_MVAR_info);
+#endif
+      JMP_(ENTRY_CODE(Sp[0]));
+  } else {
+      /* No further takes, the MVar is now full. */
+      mvar->value = R2.cl;
+      /* unlocks the MVar in the SMP case */
+      SET_INFO(mvar,&stg_FULL_MVAR_info);
+      JMP_(ENTRY_CODE(Sp[0]));
   }
 
-  /* unlocks the MVar in the SMP case */
-  SET_INFO(mvar,&stg_FULL_MVAR_info);
-
-  /* ToDo: yield here for better communication performance? */
-  JMP_(ENTRY_CODE(Sp[0]));
+  /* ToDo: yield afterward for better communication performance? */
   FE_
 }
 
@@ -1035,33 +1133,40 @@ FN_(tryPutMVarzh_fast)
     mvar->header.info = &stg_FULL_MVAR_info;
 #endif
 
-    /* HACK: we need a pointer to pass back, so we abuse NO_FINALIZER_closure */
     RET_N(0);
   }
   
-  mvar->value = R2.cl;
-
-  /* wake up the first thread on the queue, it will continue with the
-   * takeMVar operation and mark the MVar empty again.
-   */
   if (mvar->head != (StgTSO *)&stg_END_TSO_QUEUE_closure) {
-    ASSERT(mvar->head->why_blocked == BlockedOnMVar);
+      /* There are takeMVar(s) waiting: wake up the first one
+       */
+      ASSERT(mvar->head->why_blocked == BlockedOnMVar);
+
+      /* actually perform the takeMVar */
+      PerformTake(mvar->head, R2.cl);
+      
 #if defined(GRAN) || defined(PAR)
-    /* ToDo: check 2nd arg (mvar) is right */
-    mvar->head = RET_STGCALL2(StgTSO *,unblockOne,mvar->head,mvar);
+      /* ToDo: check 2nd arg (mvar) is right */
+      mvar->head = RET_STGCALL2(StgTSO *,unblockOne,mvar->head,mvar);
 #else
-    mvar->head = RET_STGCALL1(StgTSO *,unblockOne,mvar->head);
+      mvar->head = RET_STGCALL1(StgTSO *,unblockOne,mvar->head);
 #endif
-    if (mvar->head == (StgTSO *)&stg_END_TSO_QUEUE_closure) {
-      mvar->tail = (StgTSO *)&stg_END_TSO_QUEUE_closure;
-    }
+      if (mvar->head == (StgTSO *)&stg_END_TSO_QUEUE_closure) {
+	  mvar->tail = (StgTSO *)&stg_END_TSO_QUEUE_closure;
+      }
+#ifdef SMP
+      /* unlocks the MVar in the SMP case */
+      SET_INFO(mvar,&stg_EMPTY_MVAR_info);
+#endif
+      JMP_(ENTRY_CODE(Sp[0]));
+  } else {
+      /* No further takes, the MVar is now full. */
+      mvar->value = R2.cl;
+      /* unlocks the MVar in the SMP case */
+      SET_INFO(mvar,&stg_FULL_MVAR_info);
+      JMP_(ENTRY_CODE(Sp[0]));
   }
 
-  /* unlocks the MVar in the SMP case */
-  SET_INFO(mvar,&stg_FULL_MVAR_info);
-
-  /* ToDo: yield here for better communication performance? */
-  RET_N(1);
+  /* ToDo: yield afterward for better communication performance? */
   FE_
 }
 
@@ -1085,7 +1190,7 @@ FN_(makeStableNamezh_fast)
   /* Is there already a StableName for this heap object? */
   if (stable_ptr_table[index].sn_obj == NULL) {
     sn_obj = (StgStableName *) (Hp - sizeofW(StgStableName) + 1);
-    sn_obj->header.info = &stg_STABLE_NAME_info;
+    SET_HDR(sn_obj,&stg_STABLE_NAME_info,CCCS);
     sn_obj->sn = index;
     stable_ptr_table[index].sn_obj = (StgClosure *)sn_obj;
   } else {