[project @ 1999-11-18 16:02:17 by sewardj]

Minor bugfixes for concurrency support in Hugs.

Evaluator.c: correctly handle case of entering a black hole.
Prelude.hs:  better exception catching in forkIO and primRunIO
GC.c:        (revert_dead_CAFs): don't ASSERT(0) on a dead CAF
             (I don't know why this assert was there)

diff --git a/ghc/interpreter/lib/Prelude.hs b/ghc/interpreter/lib/Prelude.hs
index 77e7883..e2261b0 100644 (file)
--- a/ghc/interpreter/lib/Prelude.hs
+++ b/ghc/interpreter/lib/Prelude.hs
@@ -1818,12 +1818,15 @@ instance Monad (ST s) where
 -- used when Hugs invokes top level function
 primRunIO :: IO () -> ()
 primRunIO m
-   = protect (fst (unST m realWorld))
+   = protect 5 (fst (unST m realWorld))
      where
         realWorld = error "primRunIO: entered the RealWorld"
-        protect :: () -> ()
-        protect comp 
-           = primCatch comp (\e -> fst (unST (putStr (show e ++ "\n")) realWorld))
+        protect :: Int -> () -> ()
+        protect 0 comp
+           = comp
+        protect n comp
+           = primCatch (protect (n-1) comp)
+                       (\e -> fst (unST (putStr (show e ++ "\n")) realWorld))
 
 trace, trace_quiet :: String -> a -> a
 trace s x

diff --git a/ghc/lib/hugs/Prelude.hs b/ghc/lib/hugs/Prelude.hs
index 77e7883..e2261b0 100644 (file)
--- a/ghc/lib/hugs/Prelude.hs
+++ b/ghc/lib/hugs/Prelude.hs
@@ -1818,12 +1818,15 @@ instance Monad (ST s) where
 -- used when Hugs invokes top level function
 primRunIO :: IO () -> ()
 primRunIO m
-   = protect (fst (unST m realWorld))
+   = protect 5 (fst (unST m realWorld))
      where
         realWorld = error "primRunIO: entered the RealWorld"
-        protect :: () -> ()
-        protect comp 
-           = primCatch comp (\e -> fst (unST (putStr (show e ++ "\n")) realWorld))
+        protect :: Int -> () -> ()
+        protect 0 comp
+           = comp
+        protect n comp
+           = primCatch (protect (n-1) comp)
+                       (\e -> fst (unST (putStr (show e ++ "\n")) realWorld))
 
 trace, trace_quiet :: String -> a -> a
 trace s x

diff --git a/ghc/rts/Evaluator.c b/ghc/rts/Evaluator.c
index e27447b..1ef92e1 100644 (file)
--- a/ghc/rts/Evaluator.c
+++ b/ghc/rts/Evaluator.c
@@ -5,8 +5,8 @@
  * Copyright (c) 1994-1998.
  *
  * $RCSfile: Evaluator.c,v $
- * $Revision: 1.28 $
- * $Date: 1999/11/18 12:10:26 $
+ * $Revision: 1.29 $
+ * $Date: 1999/11/18 16:02:18 $
  * ---------------------------------------------------------------------------*/
 
 #include "Rts.h"
@@ -1326,14 +1326,10 @@ StgThreadReturnCode enter( Capability* cap, StgClosure* obj0 )
     case CAF_BLACKHOLE:
     case SE_CAF_BLACKHOLE:
         {
-           /*was StgBlackHole* */
-            StgBlockingQueue* bh = (StgBlockingQueue*)obj;
-            /* Put ourselves on the blocking queue for this black hole and block */
-            cap->rCurrentTSO->link = bh->blocking_queue;
-            bh->blocking_queue = cap->rCurrentTSO;
-            xPushCPtr(obj); /* code to restart with */
-            barf("enter: CAF_BLACKHOLE unexpected!");
-            RETURN(ThreadBlocked);
+            /* Let the scheduler figure out what to do :-) */
+            cap->rCurrentTSO->whatNext = ThreadEnterGHC;
+            xPushCPtr(obj);
+            RETURN(ThreadYielding);
         }
     case AP_UPD:
         {

diff --git a/ghc/rts/GC.c b/ghc/rts/GC.c
index a5dc85d..ca0fbd1 100644 (file)
--- a/ghc/rts/GC.c
+++ b/ghc/rts/GC.c
@@ -1,5 +1,5 @@
 /* -----------------------------------------------------------------------------
- * $Id: GC.c,v 1.66 1999/11/09 15:46:49 simonmar Exp $
+ * $Id: GC.c,v 1.67 1999/11/18 16:02:21 sewardj Exp $
  *
  * (c) The GHC Team 1998-1999
  *
@@ -2655,7 +2655,7 @@ void revert_dead_CAFs(void)
            new->link = enteredCAFs;
            enteredCAFs = new;
         } else {
-           ASSERT(0);
+           /* ASSERT(0); */
            SET_INFO(caf,&CAF_UNENTERED_info);
            caf->value = (StgClosure*)0xdeadbeef;
            caf->link  = (StgCAF*)0xdeadbeef;