[project @ 1999-11-16 17:38:54 by sewardj]

Added basic support for MVars: data MVar, and newMVar, putMVar and
getMVar.

diff --git a/ghc/includes/Assembler.h b/ghc/includes/Assembler.h
index 2cc9dd1..ce553f4 100644 (file)
--- a/ghc/includes/Assembler.h
+++ b/ghc/includes/Assembler.h
@@ -1,6 +1,6 @@
 
 /* -----------------------------------------------------------------------------
 
 /* -----------------------------------------------------------------------------

- * $Id: Assembler.h,v 1.10 1999/10/26 17:27:35 sewardj Exp $
+ * $Id: Assembler.h,v 1.11 1999/11/16 17:38:54 sewardj Exp $

  *
  * (c) The GHC Team 1994-1998.
  *
  *
  * (c) The GHC Team 1994-1998.
  *

@@ -104,6 +104,7 @@ typedef enum {
   ALPHA_REP    = 'a',  /* a                        */
   BETA_REP     = 'b',  /* b                       */
   GAMMA_REP    = 'c',  /* c                        */
   ALPHA_REP    = 'a',  /* a                        */
   BETA_REP     = 'b',  /* b                       */
   GAMMA_REP    = 'c',  /* c                        */

+  DELTA_REP    = 'd',  /* d                        */

   BOOL_REP     = 'B',  /* Bool                    */
   IO_REP       = 'i',  /* IO a                    */
   HANDLER_REP  = 'H',  /* Exception -> IO a       */
   BOOL_REP     = 'B',  /* Bool                    */
   IO_REP       = 'i',  /* IO a                    */
   HANDLER_REP  = 'H',  /* Exception -> IO a       */

@@ -111,10 +112,8 @@ typedef enum {
   ARR_REP      = 'X',  /* PrimArray              a */
   REF_REP      = 'R',  /* Ref                  s a */
   MUTARR_REP   = 'M',  /* PrimMutableArray     s a */
   ARR_REP      = 'X',  /* PrimArray              a */
   REF_REP      = 'R',  /* Ref                  s a */
   MUTARR_REP   = 'M',  /* PrimMutableArray     s a */

-#ifdef PROVIDE_CONCURRENT

   THREADID_REP = 'T',  /* ThreadId                 */
   MVAR_REP     = 'r',  /* MVar a                   */
   THREADID_REP = 'T',  /* ThreadId                 */
   MVAR_REP     = 'r',  /* MVar a                   */

-#endif

 
   /* Allegedly used in the IO monad */
   VOID_REP     = 'v'      
 
   /* Allegedly used in the IO monad */
   VOID_REP     = 'v'      

@@ -211,9 +210,10 @@ extern const AsmPrim* asmFindPrimop  ( AsmInstr prefix, AsmInstr op );
 extern AsmSp          asmBeginPrim   ( AsmBCO bco );
 extern void           asmEndPrim     ( AsmBCO bco, const AsmPrim* prim, AsmSp base );
 
 extern AsmSp          asmBeginPrim   ( AsmBCO bco );
 extern void           asmEndPrim     ( AsmBCO bco, const AsmPrim* prim, AsmSp base );
 

-extern AsmBCO asm_BCO_catch ( void );
-extern AsmBCO asm_BCO_raise ( void );
-extern AsmBCO asm_BCO_seq   ( void );
+extern AsmBCO asm_BCO_catch    ( void );
+extern AsmBCO asm_BCO_raise    ( void );
+extern AsmBCO asm_BCO_seq      ( void );
+extern AsmBCO asm_BCO_takeMVar ( void );

 
 
 /* --------------------------------------------------------------------------
 
 
 /* --------------------------------------------------------------------------

diff --git a/ghc/interpreter/lib/Prelude.hs b/ghc/interpreter/lib/Prelude.hs
index 1533c07..5a342ad 100644 (file)
--- a/ghc/interpreter/lib/Prelude.hs
+++ b/ghc/interpreter/lib/Prelude.hs
@@ -103,6 +103,8 @@ module Prelude (
     asTypeOf, error, undefined,
     seq, ($!)
 
     asTypeOf, error, undefined,
     seq, ($!)
 

+    , MVar, newMVar, putMVar, takeMVar
+

     ,trace
     -- Arrrggghhh!!! Help! Help! Help!
     -- What?!  Prelude.hs doesn't even _define_ most of these things!
     ,trace
     -- Arrrggghhh!!! Help! Help! Help!
     -- What?!  Prelude.hs doesn't even _define_ most of these things!

@@ -1774,6 +1776,9 @@ primGetEnv v
 -- ST, IO --------------------------------------------------------------------
 ------------------------------------------------------------------------------
 
 -- ST, IO --------------------------------------------------------------------
 ------------------------------------------------------------------------------
 

+-- Do not change this newtype to a data, or MVars will stop
+-- working.  In general the MVar stuff is pretty fragile: do
+-- not mess with it.

 newtype ST s a = ST (s -> (a,s))
 
 data RealWorld
 newtype ST s a = ST (s -> (a,s))
 
 data RealWorld

@@ -1820,7 +1825,7 @@ unsafeInterleaveIO = unsafeInterleaveST
 
 
 ------------------------------------------------------------------------------
 
 
 ------------------------------------------------------------------------------

--- Word, Addr, StablePtr, Prim*Array -----------------------------------------
+-- Word, Addr, StablePtr, Prim*Array, ThreadId, MVar -------------------------

 ------------------------------------------------------------------------------
 
 data Addr
 ------------------------------------------------------------------------------
 
 data Addr

@@ -1870,6 +1875,41 @@ data Ref                  s a -- mutable variables
 data PrimMutableArray     s a -- mutable arrays with Int indices
 data PrimMutableByteArray s
 
 data PrimMutableArray     s a -- mutable arrays with Int indices
 data PrimMutableByteArray s
 

+data ThreadId
+
+data MVar a
+
+
+newMVar :: IO (MVar a)
+newMVar = primNewMVar
+
+putMVar :: MVar a -> a -> IO ()
+putMVar = primPutMVar
+
+takeMVar :: MVar a -> IO a
+takeMVar m
+   = ST (\world -> primTakeMVar m cont world)
+     where
+        -- cont :: a -> RealWorld -> (a,RealWorld)
+        -- where 'a' is as in the top-level signature
+        cont x world = (x,world)
+
+        -- the type of the handwritten BCO (threesome) primTakeMVar is
+        -- primTakeMVar :: MVar a 
+        --                 -> (a -> RealWorld -> (a,RealWorld)) 
+        --                 -> RealWorld 
+        --                 -> (a,RealWorld)
+        --
+        -- primTakeMVar behaves like this:
+        --
+        -- primTakeMVar (MVar# m#) cont world
+        --    = primTakeMVar_wrk m# cont world
+        --
+        -- primTakeMVar_wrk m# cont world
+        --    = cont (takeMVar# m#) world
+        --
+        -- primTakeMVar_wrk has the special property that it is
+        -- restartable by the scheduler, should the MVar be empty.

 
 
 -- showFloat ------------------------------------------------------------------
 
 
 -- showFloat ------------------------------------------------------------------

diff --git a/ghc/interpreter/link.c b/ghc/interpreter/link.c
index 3ac5f76..9106dcc 100644 (file)
--- a/ghc/interpreter/link.c
+++ b/ghc/interpreter/link.c
@@ -9,8 +9,8 @@
  * included in the distribution.
  *
  * $RCSfile: link.c,v $
  * included in the distribution.
  *
  * $RCSfile: link.c,v $

- * $Revision: 1.12 $
- * $Date: 1999/11/12 17:32:40 $
+ * $Revision: 1.13 $
+ * $Date: 1999/11/16 17:38:55 $

  * ------------------------------------------------------------------------*/
 
 #include "prelude.h"
  * ------------------------------------------------------------------------*/
 
 #include "prelude.h"

@@ -38,16 +38,14 @@ Type typePrimMutableByteArray;
 Type typeFloat;
 Type typeDouble;
 Type typeStable;
 Type typeFloat;
 Type typeDouble;
 Type typeStable;

+Type typeThreadId;
+Type typeMVar;

 #ifdef PROVIDE_WEAK
 Type typeWeak;
 #endif
 #ifdef PROVIDE_FOREIGN
 Type typeForeign;
 #endif
 #ifdef PROVIDE_WEAK
 Type typeWeak;
 #endif
 #ifdef PROVIDE_FOREIGN
 Type typeForeign;
 #endif

-#ifdef PROVIDE_CONCURRENT
-Type typeThreadId;
-Type typeMVar;
-#endif

 
 Type typeList;
 Type typeUnit;
 
 Type typeList;
 Type typeUnit;

@@ -140,6 +138,7 @@ Name nameFlip;
 Name namePrimSeq;
 Name namePrimCatch;
 Name namePrimRaise;
 Name namePrimSeq;
 Name namePrimCatch;
 Name namePrimRaise;

+Name namePrimTakeMVar;

 
 Name nameFromTo;
 Name nameFromThen;
 
 Name nameFromTo;
 Name nameFromThen;

@@ -165,16 +164,14 @@ Name nameMkRef;
 Name nameMkPrimMutableArray;     
 Name nameMkPrimMutableByteArray; 
 Name nameMkStable;                      /* StablePtr# a -> StablePtr a     */
 Name nameMkPrimMutableArray;     
 Name nameMkPrimMutableByteArray; 
 Name nameMkStable;                      /* StablePtr# a -> StablePtr a     */

+Name nameMkThreadId;                    /* ThreadId#    -> ThreadId        */
+Name nameMkPrimMVar;                    /* MVar# a      -> MVar a          */

 #ifdef PROVIDE_WEAK
 Name nameMkWeak;                        /* Weak# a      -> Weak a          */
 #endif
 #ifdef PROVIDE_FOREIGN
 Name nameMkForeign;                     /* ForeignObj#  -> ForeignObj      */
 #endif
 #ifdef PROVIDE_WEAK
 Name nameMkWeak;                        /* Weak# a      -> Weak a          */
 #endif
 #ifdef PROVIDE_FOREIGN
 Name nameMkForeign;                     /* ForeignObj#  -> ForeignObj      */
 #endif

-#ifdef PROVIDE_CONCURRENT
-Name nameMkThreadId;                    /* ThreadId#    -> ThreadId        */
-Name nameMkMVar;                        /* MVar#        -> MVar            */
-#endif

 
 
 
 
 
 

@@ -294,11 +291,8 @@ Void linkPreludeTC(void) {              /* Hook to tycons and classes in   */
 #ifdef PROVIDE_FOREIGN
         typeForeign      = linkTycon("ForeignObj");
 #endif
 #ifdef PROVIDE_FOREIGN
         typeForeign      = linkTycon("ForeignObj");
 #endif

-#ifdef PROVIDE_CONCURRENT

         typeThreadId     = linkTycon("ThreadId");
         typeMVar         = linkTycon("MVar");
         typeThreadId     = linkTycon("ThreadId");
         typeMVar         = linkTycon("MVar");

-#endif
-

         typeBool         = linkTycon("Bool");
         typeST           = linkTycon("ST");
         typeIO           = linkTycon("IO");
         typeBool         = linkTycon("Bool");
         typeST           = linkTycon("ST");
         typeIO           = linkTycon("IO");

@@ -350,10 +344,9 @@ Void linkPreludeTC(void) {              /* Hook to tycons and classes in   */
         nameMkRef                  = addPrimCfunREP(findText("Ref#"),1,0,0);
         nameMkPrimMutableArray     = addPrimCfunREP(findText("PrimMutableArray#"),1,0,0);
         nameMkPrimMutableByteArray = addPrimCfunREP(findText("PrimMutableByteArray#"),1,0,0);
         nameMkRef                  = addPrimCfunREP(findText("Ref#"),1,0,0);
         nameMkPrimMutableArray     = addPrimCfunREP(findText("PrimMutableArray#"),1,0,0);
         nameMkPrimMutableByteArray = addPrimCfunREP(findText("PrimMutableByteArray#"),1,0,0);

-#ifdef PROVIDE_CONCURRENT
-        nameMkThreadId   = addPrimCfun(findTextREP("ThreadId#"),1,0,0);
-        nameMkMVar       = addPrimCfun(findTextREP("MVar#"),1,0,0);
-#endif
+        nameMkThreadId             = addPrimCfunREP(findText("ThreadId#"),1,0,0);
+        nameMkPrimMVar             = addPrimCfunREP(findText("MVar#"),1,0,0);
+

         /* The following primitives are referred to in derived instances and
          * hence require types; the following types are a little more general
          * than we might like, but they are the closest we can get without a
         /* The following primitives are referred to in derived instances and
          * hence require types; the following types are a little more general
          * than we might like, but they are the closest we can get without a

@@ -384,6 +377,12 @@ Void linkPreludeTC(void) {              /* Hook to tycons and classes in   */
         name(namePrimRaise).type
             = primType(MONAD_Id, "E", "a");
 
         name(namePrimRaise).type
             = primType(MONAD_Id, "E", "a");
 

+        /* This is a lie.  For a more accurate type of primTakeMVar
+           see ghc/interpreter/lib/Prelude.hs.
+       */
+        name(namePrimTakeMVar).type
+            = primType(MONAD_Id, "rbc", "d");
+

         for (i=2; i<=NUM_DTUPLES; i++) {/* Add derived instances of tuples */
             addTupInst(classEq,i);
             addTupInst(classOrd,i);
         for (i=2; i<=NUM_DTUPLES; i++) {/* Add derived instances of tuples */
             addTupInst(classEq,i);
             addTupInst(classOrd,i);

@@ -564,6 +563,7 @@ Int what; {
                        pFun(namePrimSeq,        "primSeq");
                        pFun(namePrimCatch,      "primCatch");
                        pFun(namePrimRaise,      "primRaise");
                        pFun(namePrimSeq,        "primSeq");
                        pFun(namePrimCatch,      "primCatch");
                        pFun(namePrimRaise,      "primRaise");

+                       pFun(namePrimTakeMVar,   "primTakeMVar");

                        {
                           StgVar vv = mkStgVar(NIL,NIL);
                           Name n = namePrimSeq;
                        {
                           StgVar vv = mkStgVar(NIL,NIL);
                           Name n = namePrimSeq;

@@ -596,7 +596,16 @@ Int what; {
                           name(n).stgVar = vv;
                           stgGlobals=cons(pair(n,vv),stgGlobals);
                        }
                           name(n).stgVar = vv;
                           stgGlobals=cons(pair(n,vv),stgGlobals);
                        }

-
+                       {
+                          StgVar vv = mkStgVar(NIL,NIL);
+                          Name n = namePrimTakeMVar;
+                          name(n).line = 0;
+                          name(n).arity = 2;
+                          name(n).type = NIL;
+                          stgVarInfo(vv) = mkPtr ( asm_BCO_takeMVar() );
+                          name(n).stgVar = vv;
+                          stgGlobals=cons(pair(n,vv),stgGlobals);
+                       }

                        break;
     }
 }
                        break;
     }
 }

diff --git a/ghc/interpreter/link.h b/ghc/interpreter/link.h
index ce766b4..f52fdeb 100644 (file)
--- a/ghc/interpreter/link.h
+++ b/ghc/interpreter/link.h
@@ -28,16 +28,15 @@ extern Name nameMkPrimByteArray;
 extern Name nameMkRef;                  
 extern Name nameMkPrimMutableArray;     
 extern Name nameMkPrimMutableByteArray; 
 extern Name nameMkRef;                  
 extern Name nameMkPrimMutableArray;     
 extern Name nameMkPrimMutableByteArray; 

+extern Name nameMkThreadId;  
+extern Name nameMkPrimMVar;  

 #ifdef PROVIDE_FOREIGN
 extern Name nameMkForeign;   
 #endif
 #ifdef PROVIDE_WEAK
 extern Name nameMkWeak;
 #endif
 #ifdef PROVIDE_FOREIGN
 extern Name nameMkForeign;   
 #endif
 #ifdef PROVIDE_WEAK
 extern Name nameMkWeak;
 #endif

-#ifdef PROVIDE_CONCURRENT
-extern Name nameMkThreadId;  
-extern Name nameMkMVar;  
-#endif
+

 
 /* For every primitive type provided by the runtime system,
  * we construct a Haskell type using a declaration of the form:
 
 /* For every primitive type provided by the runtime system,
  * we construct a Haskell type using a declaration of the form:

@@ -57,16 +56,14 @@ extern Type typePrimMutableByteArray;
 extern Type typeFloat;
 extern Type typeDouble;
 extern Type typeStable;
 extern Type typeFloat;
 extern Type typeDouble;
 extern Type typeStable;

+extern Type typeThreadId;
+extern Type typeMVar;

 #ifdef PROVIDE_WEAK
 extern Type typeWeak;
 #endif
 #ifdef PROVIDE_FOREIGN
 extern Type typeForeign;
 #endif
 #ifdef PROVIDE_WEAK
 extern Type typeWeak;
 #endif
 #ifdef PROVIDE_FOREIGN
 extern Type typeForeign;
 #endif

-#ifdef PROVIDE_CONCURRENT
-extern Type typeThreadId;
-extern Type typeMVar;
-#endif

 
 /* And a smaller number of types defined in plain Haskell */
 extern Type typeList;
 
 /* And a smaller number of types defined in plain Haskell */
 extern Type typeList;

diff --git a/ghc/interpreter/storage.c b/ghc/interpreter/storage.c
index 90bb906..87f0775 100644 (file)
--- a/ghc/interpreter/storage.c
+++ b/ghc/interpreter/storage.c
@@ -9,8 +9,8 @@
  * included in the distribution.
  *
  * $RCSfile: storage.c,v $
  * included in the distribution.
  *
  * $RCSfile: storage.c,v $

- * $Revision: 1.15 $
- * $Date: 1999/11/12 17:32:46 $
+ * $Revision: 1.16 $
+ * $Date: 1999/11/16 17:38:56 $

  * ------------------------------------------------------------------------*/
 
 #include "prelude.h"
  * ------------------------------------------------------------------------*/
 
 #include "prelude.h"

@@ -529,8 +529,11 @@ Name nameFromStgVar ( StgVar v )
 void* getHugs_AsmObject_for ( char* s )
 {
    StgVar v;
 void* getHugs_AsmObject_for ( char* s )
 {
    StgVar v;

-   Name   n = findName(findText(s));
-   if (isNull(n)) internal("getHugs_AsmObject_for(1)");
+   Text   t = findText(s);
+   Name   n = NIL;
+   for (n = NAMEMIN; n < nameHw; n++)
+      if (name(n).text == t) break;
+   if (n == nameHw) internal("getHugs_AsmObject_for(1)");

    v = name(n).stgVar;
    if (!isStgVar(v) || !isPtr(stgVarInfo(v)))
       internal("getHugs_AsmObject_for(2)");
    v = name(n).stgVar;
    if (!isStgVar(v) || !isPtr(stgVarInfo(v)))
       internal("getHugs_AsmObject_for(2)");

diff --git a/ghc/interpreter/translate.c b/ghc/interpreter/translate.c
index f54cf20..4cac5b0 100644 (file)
--- a/ghc/interpreter/translate.c
+++ b/ghc/interpreter/translate.c
@@ -10,8 +10,8 @@
  * included in the distribution.
  *
  * $RCSfile: translate.c,v $
  * included in the distribution.
  *
  * $RCSfile: translate.c,v $

- * $Revision: 1.15 $
- * $Date: 1999/11/12 17:32:48 $
+ * $Revision: 1.16 $
+ * $Date: 1999/11/16 17:38:58 $

  * ------------------------------------------------------------------------*/
 
 #include "prelude.h"
  * ------------------------------------------------------------------------*/
 
 #include "prelude.h"

@@ -565,29 +565,27 @@ static Cell foreignInboundTy ( Type t )
 static Name repToBox( char c )
 {
     switch (c) {
 static Name repToBox( char c )
 {
     switch (c) {

-    case CHAR_REP:    return nameMkC;
-    case INT_REP:     return nameMkI;
-    case INTEGER_REP: return nameMkInteger;
-    case WORD_REP:    return nameMkW;
-    case ADDR_REP:    return nameMkA;
-    case FLOAT_REP:   return nameMkF;
-    case DOUBLE_REP:  return nameMkD;
-    case ARR_REP:     return nameMkPrimArray;            
-    case BARR_REP:    return nameMkPrimByteArray;
-    case REF_REP:     return nameMkRef;                  
-    case MUTARR_REP:  return nameMkPrimMutableArray;     
-    case MUTBARR_REP: return nameMkPrimMutableByteArray; 
-    case STABLE_REP:  return nameMkStable;
+    case CHAR_REP:     return nameMkC;
+    case INT_REP:      return nameMkI;
+    case INTEGER_REP:  return nameMkInteger;
+    case WORD_REP:     return nameMkW;
+    case ADDR_REP:     return nameMkA;
+    case FLOAT_REP:    return nameMkF;
+    case DOUBLE_REP:   return nameMkD;
+    case ARR_REP:      return nameMkPrimArray;            
+    case BARR_REP:     return nameMkPrimByteArray;
+    case REF_REP:      return nameMkRef;                  
+    case MUTARR_REP:   return nameMkPrimMutableArray;     
+    case MUTBARR_REP:  return nameMkPrimMutableByteArray; 
+    case STABLE_REP:   return nameMkStable;
+    case THREADID_REP: return nameMkThreadId;
+    case MVAR_REP:     return nameMkPrimMVar;

 #ifdef PROVIDE_WEAK
     case WEAK_REP:  return nameMkWeak;
 #endif
 #ifdef PROVIDE_FOREIGN
     case FOREIGN_REP: return nameMkForeign;
 #endif
 #ifdef PROVIDE_WEAK
     case WEAK_REP:  return nameMkWeak;
 #endif
 #ifdef PROVIDE_FOREIGN
     case FOREIGN_REP: return nameMkForeign;
 #endif

-#ifdef PROVIDE_CONCURRENT
-    case THREADID_REP: return nameMkThreadId;
-    case MVAR_REP:     return nameMkMVar;
-#endif

     default: return NIL;
     }
 }
     default: return NIL;
     }
 }

diff --git a/ghc/interpreter/type.c b/ghc/interpreter/type.c
index 69c227f..8f12154 100644 (file)
--- a/ghc/interpreter/type.c
+++ b/ghc/interpreter/type.c
@@ -9,8 +9,8 @@
  * included in the distribution.
  *
  * $RCSfile: type.c,v $
  * included in the distribution.
  *
  * $RCSfile: type.c,v $

- * $Revision: 1.11 $
- * $Date: 1999/11/12 17:32:48 $
+ * $Revision: 1.12 $
+ * $Date: 1999/11/16 17:39:00 $

  * ------------------------------------------------------------------------*/
 
 #include "prelude.h"
  * ------------------------------------------------------------------------*/
 
 #include "prelude.h"

@@ -2488,6 +2488,7 @@ static Type stateVar = NIL;
 static Type alphaVar = NIL;
 static Type betaVar  = NIL;
 static Type gammaVar = NIL;
 static Type alphaVar = NIL;
 static Type betaVar  = NIL;
 static Type gammaVar = NIL;

+static Type deltaVar = NIL;

 static Int  nextVar  = 0;
 
 static Void clearTyVars( void )
 static Int  nextVar  = 0;
 
 static Void clearTyVars( void )

@@ -2496,6 +2497,7 @@ static Void clearTyVars( void )
     alphaVar = NIL;
     betaVar  = NIL;
     gammaVar = NIL;
     alphaVar = NIL;
     betaVar  = NIL;
     gammaVar = NIL;

+    deltaVar = NIL;

     nextVar  = 0;
 }
 
     nextVar  = 0;
 }
 

@@ -2531,6 +2533,14 @@ static Type mkGammaVar( void )
     return gammaVar;
 }
 
     return gammaVar;
 }
 

+static Type mkDeltaVar( void )
+{
+    if (isNull(deltaVar)) {
+        deltaVar = mkOffset(nextVar++);
+    }
+    return deltaVar;
+}
+

 static Type local basicType(k)
 Char k; {
     switch (k) {
 static Type local basicType(k)
 Char k; {
     switch (k) {

@@ -2548,12 +2558,18 @@ Char k; {
             return typeFloat;
     case DOUBLE_REP:
             return typeDouble;
             return typeFloat;
     case DOUBLE_REP:
             return typeDouble;

-    case ARR_REP:     return ap(typePrimArray,mkAlphaVar());            
-    case BARR_REP:    return typePrimByteArray;
-    case REF_REP:     return ap2(typeRef,mkStateVar(),mkAlphaVar());                  
-    case MUTARR_REP:  return ap2(typePrimMutableArray,mkStateVar(),mkAlphaVar());     
-    case MUTBARR_REP: return ap(typePrimMutableByteArray,mkStateVar()); 
-    case STABLE_REP:  return ap(typeStable,mkAlphaVar());
+    case ARR_REP:
+            return ap(typePrimArray,mkAlphaVar());            
+    case BARR_REP:
+            return typePrimByteArray;
+    case REF_REP:
+            return ap2(typeRef,mkStateVar(),mkAlphaVar());                  
+    case MUTARR_REP:
+            return ap2(typePrimMutableArray,mkStateVar(),mkAlphaVar());     
+    case MUTBARR_REP:
+            return ap(typePrimMutableByteArray,mkStateVar()); 
+    case STABLE_REP:
+            return ap(typeStable,mkAlphaVar());

 #ifdef PROVIDE_WEAK
     case WEAK_REP:
             return ap(typeWeak,mkAlphaVar());
 #ifdef PROVIDE_WEAK
     case WEAK_REP:
             return ap(typeWeak,mkAlphaVar());

@@ -2564,12 +2580,10 @@ Char k; {
     case FOREIGN_REP:
             return typeForeign;
 #endif
     case FOREIGN_REP:
             return typeForeign;
 #endif

-#ifdef PROVIDE_CONCURRENT

     case THREADID_REP:
             return typeThreadId;
     case MVAR_REP:
             return ap(typeMVar,mkAlphaVar());
     case THREADID_REP:
             return typeThreadId;
     case MVAR_REP:
             return ap(typeMVar,mkAlphaVar());

-#endif

     case BOOL_REP:
             return typeBool;
     case HANDLER_REP:
     case BOOL_REP:
             return typeBool;
     case HANDLER_REP:

@@ -2582,6 +2596,8 @@ Char k; {
             return mkBetaVar();   /* polymorphic */
     case GAMMA_REP:
             return mkGammaVar();  /* polymorphic */
             return mkBetaVar();   /* polymorphic */
     case GAMMA_REP:
             return mkGammaVar();  /* polymorphic */

+    case DELTA_REP:
+            return mkDeltaVar();  /* polymorphic */

     default:
             printf("Kind: '%c'\n",k);
             internal("basicType");
     default:
             printf("Kind: '%c'\n",k);
             internal("basicType");

diff --git a/ghc/lib/hugs/Prelude.hs b/ghc/lib/hugs/Prelude.hs
index 1533c07..5a342ad 100644 (file)
--- a/ghc/lib/hugs/Prelude.hs
+++ b/ghc/lib/hugs/Prelude.hs
@@ -103,6 +103,8 @@ module Prelude (
     asTypeOf, error, undefined,
     seq, ($!)
 
     asTypeOf, error, undefined,
     seq, ($!)
 

+    , MVar, newMVar, putMVar, takeMVar
+

     ,trace
     -- Arrrggghhh!!! Help! Help! Help!
     -- What?!  Prelude.hs doesn't even _define_ most of these things!
     ,trace
     -- Arrrggghhh!!! Help! Help! Help!
     -- What?!  Prelude.hs doesn't even _define_ most of these things!

@@ -1774,6 +1776,9 @@ primGetEnv v
 -- ST, IO --------------------------------------------------------------------
 ------------------------------------------------------------------------------
 
 -- ST, IO --------------------------------------------------------------------
 ------------------------------------------------------------------------------
 

+-- Do not change this newtype to a data, or MVars will stop
+-- working.  In general the MVar stuff is pretty fragile: do
+-- not mess with it.

 newtype ST s a = ST (s -> (a,s))
 
 data RealWorld
 newtype ST s a = ST (s -> (a,s))
 
 data RealWorld

@@ -1820,7 +1825,7 @@ unsafeInterleaveIO = unsafeInterleaveST
 
 
 ------------------------------------------------------------------------------
 
 
 ------------------------------------------------------------------------------

--- Word, Addr, StablePtr, Prim*Array -----------------------------------------
+-- Word, Addr, StablePtr, Prim*Array, ThreadId, MVar -------------------------

 ------------------------------------------------------------------------------
 
 data Addr
 ------------------------------------------------------------------------------
 
 data Addr

@@ -1870,6 +1875,41 @@ data Ref                  s a -- mutable variables
 data PrimMutableArray     s a -- mutable arrays with Int indices
 data PrimMutableByteArray s
 
 data PrimMutableArray     s a -- mutable arrays with Int indices
 data PrimMutableByteArray s
 

+data ThreadId
+
+data MVar a
+
+
+newMVar :: IO (MVar a)
+newMVar = primNewMVar
+
+putMVar :: MVar a -> a -> IO ()
+putMVar = primPutMVar
+
+takeMVar :: MVar a -> IO a
+takeMVar m
+   = ST (\world -> primTakeMVar m cont world)
+     where
+        -- cont :: a -> RealWorld -> (a,RealWorld)
+        -- where 'a' is as in the top-level signature
+        cont x world = (x,world)
+
+        -- the type of the handwritten BCO (threesome) primTakeMVar is
+        -- primTakeMVar :: MVar a 
+        --                 -> (a -> RealWorld -> (a,RealWorld)) 
+        --                 -> RealWorld 
+        --                 -> (a,RealWorld)
+        --
+        -- primTakeMVar behaves like this:
+        --
+        -- primTakeMVar (MVar# m#) cont world
+        --    = primTakeMVar_wrk m# cont world
+        --
+        -- primTakeMVar_wrk m# cont world
+        --    = cont (takeMVar# m#) world
+        --
+        -- primTakeMVar_wrk has the special property that it is
+        -- restartable by the scheduler, should the MVar be empty.

 
 
 -- showFloat ------------------------------------------------------------------
 
 
 -- showFloat ------------------------------------------------------------------

diff --git a/ghc/rts/Assembler.c b/ghc/rts/Assembler.c
index 74cd9e5..59faa16 100644 (file)
--- a/ghc/rts/Assembler.c
+++ b/ghc/rts/Assembler.c
@@ -5,8 +5,8 @@
  * Copyright (c) 1994-1998.
  *
  * $RCSfile: Assembler.c,v $
  * Copyright (c) 1994-1998.
  *
  * $RCSfile: Assembler.c,v $

- * $Revision: 1.14 $
- * $Date: 1999/11/08 15:30:32 $
+ * $Revision: 1.15 $
+ * $Date: 1999/11/16 17:39:07 $

  *
  * This module provides functions to construct BCOs and other closures
  * required by the bytecode compiler.
  *
  * This module provides functions to construct BCOs and other closures
  * required by the bytecode compiler.

@@ -501,6 +501,7 @@ static StgWord repSizeW( AsmRep rep )
     case ALPHA_REP:    /* a                        */ 
     case BETA_REP:     /* b                       */ 
     case GAMMA_REP:    /* c                       */ 
     case ALPHA_REP:    /* a                        */ 
     case BETA_REP:     /* b                       */ 
     case GAMMA_REP:    /* c                       */ 

+    case DELTA_REP:    /* d                       */ 

     case HANDLER_REP:  /* IOError -> IO a         */ 
     case ERROR_REP:    /* IOError                 */ 
     case ARR_REP    :  /* PrimArray              a */ 
     case HANDLER_REP:  /* IOError -> IO a         */ 
     case ERROR_REP:    /* IOError                 */ 
     case ARR_REP    :  /* PrimArray              a */ 

@@ -508,10 +509,8 @@ static StgWord repSizeW( AsmRep rep )
     case REF_REP    :  /* Ref                  s a */ 
     case MUTARR_REP :  /* PrimMutableArray     s a */ 
     case MUTBARR_REP:  /* PrimMutableByteArray s a */ 
     case REF_REP    :  /* Ref                  s a */ 
     case MUTARR_REP :  /* PrimMutableArray     s a */ 
     case MUTBARR_REP:  /* PrimMutableByteArray s a */ 

-#ifdef PROVIDE_CONCURRENT

     case THREADID_REP: /* ThreadId                 */ 
     case MVAR_REP:     /* MVar a                   */ 
     case THREADID_REP: /* ThreadId                 */ 
     case MVAR_REP:     /* MVar a                   */ 

-#endif

     case PTR_REP:     return sizeofW(StgPtr);
 
     case VOID_REP:    return sizeofW(StgWord);
     case PTR_REP:     return sizeofW(StgPtr);
 
     case VOID_REP:    return sizeofW(StgWord);

@@ -841,6 +840,7 @@ void   asmVar           ( AsmBCO bco, AsmVar v, AsmRep rep )
     case ALPHA_REP:    /* a                        */ 
     case BETA_REP:     /* b                       */
     case GAMMA_REP:    /* c                       */ 
     case ALPHA_REP:    /* a                        */ 
     case BETA_REP:     /* b                       */
     case GAMMA_REP:    /* c                       */ 

+    case DELTA_REP:    /* d                       */ 

     case HANDLER_REP:  /* IOError -> IO a         */
     case ERROR_REP:    /* IOError                 */
     case ARR_REP    :  /* PrimArray              a */
     case HANDLER_REP:  /* IOError -> IO a         */
     case ERROR_REP:    /* IOError                 */
     case ARR_REP    :  /* PrimArray              a */

@@ -848,10 +848,8 @@ void   asmVar           ( AsmBCO bco, AsmVar v, AsmRep rep )
     case REF_REP    :  /* Ref                  s a */
     case MUTARR_REP :  /* PrimMutableArray     s a */
     case MUTBARR_REP:  /* PrimMutableByteArray s a */
     case REF_REP    :  /* Ref                  s a */
     case MUTARR_REP :  /* PrimMutableArray     s a */
     case MUTBARR_REP:  /* PrimMutableByteArray s a */

-#ifdef PROVIDE_CONCURRENT

     case THREADID_REP: /* ThreadId                */
     case MVAR_REP:     /* MVar a                  */
     case THREADID_REP: /* ThreadId                */
     case MVAR_REP:     /* MVar a                  */

-#endif

     case PTR_REP:
             emit_i_VAR(bco,offset);
             break;
     case PTR_REP:
             emit_i_VAR(bco,offset);
             break;

@@ -1409,13 +1407,13 @@ const AsmPrim asmPrimOps[] = {
     , { "primFork",                  "a", "T",   MONAD_IO, i_PRIMOP2, i_fork }
     , { "primKillThread",            "T", "",    MONAD_IO, i_PRIMOP2, i_killThread }
     , { "primSameMVar",              "rr", "B",  MONAD_Id, i_PRIMOP2, i_sameMVar }
     , { "primFork",                  "a", "T",   MONAD_IO, i_PRIMOP2, i_fork }
     , { "primKillThread",            "T", "",    MONAD_IO, i_PRIMOP2, i_killThread }
     , { "primSameMVar",              "rr", "B",  MONAD_Id, i_PRIMOP2, i_sameMVar }

-    , { "primNewMVar",               "",  "r",   MONAD_IO, i_PRIMOP2, i_newMVar }
-    , { "primTakeMVar",              "r", "a",   MONAD_IO, i_PRIMOP2, i_takeMVar }
-    , { "primPutMVar",               "ra", "",   MONAD_IO, i_PRIMOP2, i_putMVar } 

     , { "primDelay",                 "I", "",    MONAD_IO, i_PRIMOP2, i_delay }
     , { "primWaitRead",              "I", "",    MONAD_IO, i_PRIMOP2, i_waitRead }
     , { "primWaitWrite",             "I", "",    MONAD_IO, i_PRIMOP2, i_waitWrite }
 #endif
     , { "primDelay",                 "I", "",    MONAD_IO, i_PRIMOP2, i_delay }
     , { "primWaitRead",              "I", "",    MONAD_IO, i_PRIMOP2, i_waitRead }
     , { "primWaitWrite",             "I", "",    MONAD_IO, i_PRIMOP2, i_waitWrite }
 #endif

+    , { "primNewMVar",               "",  "r",   MONAD_IO, i_PRIMOP2, i_newMVar }
+      /* primTakeMVar is handwritten bytecode */
+    , { "primPutMVar",               "ra", "",   MONAD_IO, i_PRIMOP2, i_putMVar } 

 
     /* Ccall is polyadic - so it's excluded from this table */
 
 
     /* Ccall is polyadic - so it's excluded from this table */
 

@@ -1485,7 +1483,7 @@ AsmBCO asm_BCO_seq ( void )
    AsmBCO eval, cont;
 
    cont = asmBeginBCO(0 /*NIL*/);
    AsmBCO eval, cont;
 
    cont = asmBeginBCO(0 /*NIL*/);

-   emiti_8(cont,i_ARG_CHECK,2);
+   emiti_8(cont,i_ARG_CHECK,2);   /* should never fail */

    emit_i_VAR(cont,1);
    emit_i_SLIDE(cont,1,2);
    emiti_(cont,i_ENTER);
    emit_i_VAR(cont,1);
    emit_i_SLIDE(cont,1,2);
    emiti_(cont,i_ENTER);

@@ -1506,6 +1504,46 @@ AsmBCO asm_BCO_seq ( void )
    return eval;
 }
 
    return eval;
 }
 

+AsmBCO asm_BCO_takeMVar ( void )
+{
+   AsmBCO kase, casecont, take;
+
+   take = asmBeginBCO(0 /*NIL*/);
+   emit_i_VAR(take,0);
+   emiti_8(take,i_PRIMOP2,i_takeMVar);
+   emit_i_VAR(take,3);
+   emit_i_VAR(take,1);
+   emit_i_VAR(take,4);
+   emit_i_SLIDE(take,3,4);
+   emiti_(take,i_ENTER);
+   incSp(take,20);
+   asmEndBCO(take);
+
+   casecont = asmBeginBCO(0 /*NIL*/);
+   emiti_(casecont,i_UNPACK);
+   emit_i_VAR(casecont,4);
+   emit_i_VAR(casecont,4);
+   emit_i_VAR(casecont,2);
+   emit_i_CONST(casecont,casecont->object.ptrs.len);
+   asmPtr(casecont,&(take->object));
+   emit_i_SLIDE(casecont,4,5);
+   emiti_(casecont,i_ENTER);
+   incSp(casecont,20);
+   asmEndBCO(casecont);
+
+   kase = asmBeginBCO(0 /*NIL*/);
+   emiti_8(kase,i_ARG_CHECK,3);
+   emit_i_RETADDR(kase,kase->object.ptrs.len);
+   asmPtr(kase,&(casecont->object));
+   emit_i_VAR(kase,2);
+   emiti_(kase,i_ENTER);
+   incSp(kase,20);
+   asmEndBCO(kase);
+
+   return kase;
+}
+
+

 /* --------------------------------------------------------------------------
  * Heap manipulation
  * ------------------------------------------------------------------------*/
 /* --------------------------------------------------------------------------
  * Heap manipulation
  * ------------------------------------------------------------------------*/

diff --git a/ghc/rts/Bytecodes.h b/ghc/rts/Bytecodes.h
index ecb53b5..7f4e985 100644 (file)
--- a/ghc/rts/Bytecodes.h
+++ b/ghc/rts/Bytecodes.h
@@ -1,6 +1,6 @@
 
 /* -----------------------------------------------------------------------------
 
 /* -----------------------------------------------------------------------------

- * $Id: Bytecodes.h,v 1.10 1999/11/01 18:19:39 sewardj Exp $
+ * $Id: Bytecodes.h,v 1.11 1999/11/16 17:39:09 sewardj Exp $

  *
  * (c) The GHC Team, 1998-1999
  *
  *
  * (c) The GHC Team, 1998-1999
  *

@@ -422,13 +422,13 @@ typedef enum
     , i_fork
     , i_killThread
     , i_sameMVar
     , i_fork
     , i_killThread
     , i_sameMVar

-    , i_newMVar
-    , i_takeMVar
-    , i_putMVar

     , i_delay
     , i_waitRead
     , i_waitWrite
 #endif
     , i_delay
     , i_waitRead
     , i_waitWrite
 #endif

+    , i_newMVar
+    , i_takeMVar
+    , i_putMVar

 
     /* CCall! */
     , i_ccall_ccall_Id
 
     /* CCall! */
     , i_ccall_ccall_Id

diff --git a/ghc/rts/Disassembler.c b/ghc/rts/Disassembler.c
index 5fcdb08..4a4d99b 100644 (file)
--- a/ghc/rts/Disassembler.c
+++ b/ghc/rts/Disassembler.c
@@ -5,8 +5,8 @@
  * Copyright (c) 1994-1998.
  *
  * $RCSfile: Disassembler.c,v $
  * Copyright (c) 1994-1998.
  *
  * $RCSfile: Disassembler.c,v $

- * $Revision: 1.10 $
- * $Date: 1999/11/01 18:19:40 $
+ * $Revision: 1.11 $
+ * $Date: 1999/11/16 17:39:10 $

  * ---------------------------------------------------------------------------*/
 
 #include "Rts.h"
  * ---------------------------------------------------------------------------*/
 
 #include "Rts.h"

@@ -381,6 +381,8 @@ InstrPtr disInstr( StgBCO *bco, InstrPtr pc )
                     return disNone(bco,pc,"ccall_stdcall_IO");
             case i_raise:
                     return disNone(bco,pc,"primRaise");
                     return disNone(bco,pc,"ccall_stdcall_IO");
             case i_raise:
                     return disNone(bco,pc,"primRaise");

+            case i_takeMVar:
+                    return disNone(bco,pc,"primTakeMVar");

             default:
                 {
                     const AsmPrim* p = asmFindPrimop(i_PRIMOP2,op);
             default:
                 {
                     const AsmPrim* p = asmFindPrimop(i_PRIMOP2,op);

diff --git a/ghc/rts/Evaluator.c b/ghc/rts/Evaluator.c
index aece2e3..cfe90ea 100644 (file)
--- a/ghc/rts/Evaluator.c
+++ b/ghc/rts/Evaluator.c
@@ -5,8 +5,8 @@
  * Copyright (c) 1994-1998.
  *
  * $RCSfile: Evaluator.c,v $
  * Copyright (c) 1994-1998.
  *
  * $RCSfile: Evaluator.c,v $

- * $Revision: 1.26 $
- * $Date: 1999/11/12 17:50:04 $
+ * $Revision: 1.27 $
+ * $Date: 1999/11/16 17:39:10 $

  * ---------------------------------------------------------------------------*/
 
 #include "Rts.h"
  * ---------------------------------------------------------------------------*/
 
 #include "Rts.h"

@@ -1157,7 +1157,6 @@ StgThreadReturnCode enter( Capability* cap, StgClosure* obj0 )
                 }
             Case(i_PRIMOP2):
                 {
                 }
             Case(i_PRIMOP2):
                 {

-                 /* Remember to save  */

                     int      i, trc, pc_saved;
                     void*    p;
                     StgBCO*  bco_tmp;
                     int      i, trc, pc_saved;
                     void*    p;
                     StgBCO*  bco_tmp;

@@ -1175,8 +1174,8 @@ StgThreadReturnCode enter( Capability* cap, StgClosure* obj0 )
                           /* we want to enter p */
                           obj = p; goto enterLoop;
                        } else {
                           /* we want to enter p */
                           obj = p; goto enterLoop;
                        } else {

-                          /* p is the the StgThreadReturnCode for this thread */
-                          RETURN((StgThreadReturnCode)p);
+                          /* trc is the the StgThreadReturnCode for this thread */
+                          RETURN((StgThreadReturnCode)trc);

                        };
                     }
                     Continue;
                        };
                     }
                     Continue;

@@ -1731,7 +1730,7 @@ static inline StgClosure* raiseAnError ( StgClosure* errObj )
      */
     raise_closure = (StgClosure *)allocate(sizeofW(StgClosure)+1);
     raise_closure->header.info = &raise_info;
      */
     raise_closure = (StgClosure *)allocate(sizeofW(StgClosure)+1);
     raise_closure->header.info = &raise_info;

-    raise_closure->payload[0] = 0xdeadbeef; /*R1.cl;*/
+    raise_closure->payload[0] = (StgPtr)0xdead10c6; /*R1.cl;*/

 
     while (1) {
         switch (get_itbl(gSu)->type) {
 
     while (1) {
         switch (get_itbl(gSu)->type) {

@@ -2760,7 +2759,7 @@ static void* enterBCO_primop2 ( int primop2code,
                 break; 
             }
 
                 break; 
             }
 

-        /* Most of these generate alignment warnings on gSparcs and similar architectures.
+        /* Most of these generate alignment warnings on Sparcs and similar architectures.

          * These are harmless and are caused by the cast to C* in BYTE_ARR_CTS.
          */
         case i_indexCharArray:   
          * These are harmless and are caused by the cast to C* in BYTE_ARR_CTS.
          */
         case i_indexCharArray:   

@@ -2915,6 +2914,84 @@ static void* enterBCO_primop2 ( int primop2code,
                 break;
             }
 
                 break;
             }
 

+        case i_newMVar:
+            {
+                StgMVar *mvar = stgCast(StgMVar*,allocate(sizeofW(StgMVar)));
+                SET_INFO(mvar,&EMPTY_MVAR_info);
+                mvar->head = mvar->tail = (StgTSO *)&END_TSO_QUEUE_closure;
+                mvar->value = stgCast(StgClosure*,&END_TSO_QUEUE_closure);
+                PushPtr(stgCast(StgPtr,mvar));
+                break;
+            }
+        case i_takeMVar:
+            {
+                StgMVar *mvar = (StgMVar*)PopCPtr();
+                if (GET_INFO(mvar) == &EMPTY_MVAR_info) {
+
+                    /* The MVar is empty.  Attach ourselves to the TSO's 
+                       blocking queue.
+                    */
+                    if (mvar->head == (StgTSO *)&END_TSO_QUEUE_closure) {
+                        mvar->head = cap->rCurrentTSO;
+                    } else {
+                        mvar->tail->link = cap->rCurrentTSO;
+                    }
+                    cap->rCurrentTSO->link = (StgTSO *)&END_TSO_QUEUE_closure;
+                    cap->rCurrentTSO->why_blocked = BlockedOnMVar;
+                    cap->rCurrentTSO->block_info.closure = (StgClosure *)mvar;
+                    mvar->tail = cap->rCurrentTSO;
+
+                    /* At this point, the top-of-stack holds the MVar,
+                       and underneath is the world token ().  So the 
+                       stack is in the same state as when primTakeMVar
+                       was entered (primTakeMVar is handwritten bytecode).
+                       Push obj, which is this BCO, and return to the
+                       scheduler.  When the MVar is filled, the scheduler
+                       will re-enter primTakeMVar, with the args still on
+                       the top of the stack. 
+                    */
+                    PushCPtr(*bco);
+                    *return2 = ThreadBlocked;
+                    return (void*)(1+(NULL));
+
+                } else {
+                    PushCPtr(mvar->value);
+                    mvar->value = (StgClosure *)&END_TSO_QUEUE_closure;
+                    SET_INFO(mvar,&EMPTY_MVAR_info);
+                }
+                break;
+            }
+        case i_putMVar:
+            {
+                StgMVar*    mvar  = stgCast(StgMVar*,PopPtr());
+                StgClosure* value = PopCPtr();
+                if (GET_INFO(mvar) == &FULL_MVAR_info) {
+                    return (makeErrorCall("putMVar {full MVar}"));
+                } else {
+                    /* wake up the first thread on the
+                     * queue, it will continue with the
+                     * takeMVar operation and mark the
+                     * MVar empty again.  
+                     */
+                    mvar->value = value;
+
+                    if (mvar->head != (StgTSO *)&END_TSO_QUEUE_closure) {
+                       ASSERT(mvar->head->why_blocked == BlockedOnMVar);
+                       mvar->head = unblockOne(mvar->head);
+                       if (mvar->head == (StgTSO *)&END_TSO_QUEUE_closure) {
+                          mvar->tail = (StgTSO *)&END_TSO_QUEUE_closure;
+                       }
+                    }
+
+                    /* unlocks the MVar in the SMP case */
+                    SET_INFO(mvar,&FULL_MVAR_info);
+
+                    /* yield for better communication performance */
+                    context_switch = 1;
+                }
+                break;
+            }
+

 #ifdef PROVIDE_CONCURRENT
         case i_fork:
             {
 #ifdef PROVIDE_CONCURRENT
         case i_fork:
             {

@@ -2951,16 +3028,7 @@ static void* enterBCO_primop2 ( int primop2code,
                 PushTaggedBool(x==y);
                 break;
             }
                 PushTaggedBool(x==y);
                 break;
             }

-        case i_newMVar:
-            {
-                StgMVar *mvar = stgCast(StgMVar*,allocate(sizeofW(StgMVar)));
-                SET_INFO(mvar,&EMPTY_MVAR_info);
-                mvar->head = mvar->tail = EndTSOQueue;
-                /* ToDo: this is a little strange */
-                mvar->value = stgCast(StgClosure*,&END_TSO_QUEUE_closure);
-                PushPtr(stgCast(StgPtr,mvar));
-                break;
-            }
+

 #if 1
 #if 0
 ToDo: another way out of the problem might be to add an explicit
 #if 1
 #if 0
 ToDo: another way out of the problem might be to add an explicit

@@ -2968,94 +3036,7 @@ continuation to primTakeMVar: takeMVar v = primTakeMVar v takeMVar.
 The problem with this plan is that now I dont know how much to chop
 off the stack.
 #endif
 The problem with this plan is that now I dont know how much to chop
 off the stack.
 #endif

-        case i_takeMVar:
-            {
-                StgMVar *mvar = stgCast(StgMVar*,PopPtr());
-                /* If the MVar is empty, put ourselves
-                 * on its blocking queue, and wait
-                 * until we're woken up.  
-                 */
-                if (GET_INFO(mvar) != &FULL_MVAR_info) {
-                    if (mvar->head == EndTSOQueue) {
-                        mvar->head = cap->rCurrentTSO;
-                    } else {
-                        mvar->tail->link = cap->rCurrentTSO;
-                    }
-                    cap->rCurrentTSO->link = EndTSOQueue;
-                    mvar->tail = cap->rCurrentTSO;
-
-                    /* Hack, hack, hack.
-                     * When we block, we push a restart closure
-                     * on the stack - but which closure?
-                     * We happen to know that the BCO we're
-                     * executing looks like this:
-                     *
-                     *  0:      STK_CHECK 4
-                     *  2:      HP_CHECK 3
-                     *  4:      TEST 0 29
-                     *  7:      UNPACK
-                     *  8:      VAR 3
-                     *  10:     VAR 1
-                     *  12:     primTakeMVar
-                     *  14:     ALLOC_CONSTR 0x8213a80
-                     *  16:     VAR 2
-                     *  18:     VAR 2
-                     *  20:     PACK 2
-                     *  22:     VAR 0
-                     *  24:     SLIDE 1 7
-                     *  27:     ENTER
-                     *  28:     PANIC
-                     *  29:     PANIC
-                     *
-                     * so we rearrange the stack to look the
-                     * way it did when we entered this BCO
-                                    * and push ths BCO.
-                     * What a disgusting hack!
-                     */
-
-                    PopPtr();
-                    PopPtr();
-                    PushCPtr(obj);
-                    *return2 = ThreadBlocked;
-                    return (void*)(1+(NULL));
-
-                } else {
-                    PushCPtr(mvar->value);
-                    SET_INFO(mvar,&EMPTY_MVAR_info);
-                    /* ToDo: this is a little strange */
-                    mvar->value = (StgClosure*)&END_TSO_QUEUE_closure;
-                }
-                break;
-            }

 #endif
 #endif

-        case i_putMVar:
-            {
-                StgMVar*    mvar  = stgCast(StgMVar*,PopPtr());
-                StgClosure* value = PopCPtr();
-                if (GET_INFO(mvar) == &FULL_MVAR_info) {
-                    return (raisePrim("putMVar {full MVar}"));
-                } else {
-                    /* wake up the first thread on the
-                     * queue, it will continue with the
-                     * takeMVar operation and mark the
-                     * MVar empty again.  
-                     */
-                    StgTSO* tso = mvar->head;
-                    SET_INFO(mvar,&FULL_MVAR_info);
-                    mvar->value = value;
-                    if (tso != EndTSOQueue) {
-                        PUSH_ON_RUN_QUEUE(tso);
-                        mvar->head = tso->link;
-                        tso->link = EndTSOQueue;
-                        if (mvar->head == EndTSOQueue) {
-                            mvar->tail = EndTSOQueue;
-                        }
-                    }
-                }
-                /* yield for better communication performance */
-                context_switch = 1;
-                break;
-            }

         case i_delay:
         case i_waitRead:
         case i_waitWrite:
         case i_delay:
         case i_waitRead:
         case i_waitWrite:

@@ -3063,6 +3044,7 @@ off the stack.
                 ASSERT(0);
                 break;
 #endif /* PROVIDE_CONCURRENT */
                 ASSERT(0);
                 break;
 #endif /* PROVIDE_CONCURRENT */

+

         case i_ccall_ccall_Id:
         case i_ccall_ccall_IO:
         case i_ccall_stdcall_Id:
         case i_ccall_ccall_Id:
         case i_ccall_ccall_IO:
         case i_ccall_stdcall_Id: