[project @ 2002-06-19 20:45:14 by sof]

When handling external call-ins (via the RTS API) in
the multi-threaded case, add the StgMainThread that
the external thread is going to block waiting on
to the main_threads list prior to scheduling the new
worker thread.

Do this by having the scheduler provide a new entry
point, scheduleWaitThread().

Fixes a bug/race condition spotted by Wolfgang Thaller
(see scheduleWaitThread() comment) + enables a little
tidier interface between RtsAPI and Schedule.

diff --git a/ghc/includes/SchedAPI.h b/ghc/includes/SchedAPI.h
index cff2325..565ed20 100644 (file)
--- a/ghc/includes/SchedAPI.h
+++ b/ghc/includes/SchedAPI.h
@@ -1,5 +1,5 @@
 /* -----------------------------------------------------------------------------
- * $Id: SchedAPI.h,v 1.14 2002/02/15 07:37:55 sof Exp $
+ * $Id: SchedAPI.h,v 1.15 2002/06/19 20:45:17 sof Exp $
  *
  * (c) The GHC Team 1998
  *
@@ -30,7 +30,7 @@ extern StgTSO *createThread(nat stack_size);
 extern void taskStart(void);
 #endif
 extern void scheduleThread(StgTSO *tso);
-extern void scheduleExtThread(StgTSO *tso);
+extern SchedulerStatus scheduleWaitThread(StgTSO *tso, /*out*/HaskellObj* ret);
 
 static inline void pushClosure   (StgTSO *tso, StgClosure *c) {
   tso->sp--;

diff --git a/ghc/rts/RtsAPI.c b/ghc/rts/RtsAPI.c
index cd0ef4c..e144e84 100644 (file)
--- a/ghc/rts/RtsAPI.c
+++ b/ghc/rts/RtsAPI.c
@@ -1,5 +1,5 @@
 /* ----------------------------------------------------------------------------
- * $Id: RtsAPI.c,v 1.34 2002/04/13 05:28:04 sof Exp $
+ * $Id: RtsAPI.c,v 1.35 2002/06/19 20:45:14 sof Exp $
  *
  * (c) The GHC Team, 1998-2001
  *
@@ -18,14 +18,6 @@
 #include "OSThreads.h"
 #include "Schedule.h"
 
-#if defined(THREADED_RTS)
-#define WAIT_MAIN_THREAD(tso,ret) waitThread_(tso,ret,rtsFalse)
-#define WAIT_EXT_THREAD(tso,ret) waitThread_(tso,ret,rtsTrue)
-#else
-#define WAIT_MAIN_THREAD(tso,ret) waitThread(tso,ret)
-#define WAIT_EXT_THREAD(tso,ret) waitThread(tso,ret)
-#endif
-
 #if defined(RTS_SUPPORTS_THREADS)
 /* Cheesy locking scheme while waiting for the 
  * RTS API to change.
@@ -455,8 +447,7 @@ rts_eval (HaskellObj p, /*out*/HaskellObj *ret)
 
     tso = createGenThread(RtsFlags.GcFlags.initialStkSize, p);
     releaseAllocLock();
-    scheduleExtThread(tso);
-    return WAIT_EXT_THREAD(tso, ret);
+    return scheduleWaitThread(tso,ret);
 }
 
 SchedulerStatus
@@ -466,8 +457,7 @@ rts_eval_ (HaskellObj p, unsigned int stack_size, /*out*/HaskellObj *ret)
     
     tso = createGenThread(stack_size, p);
     releaseAllocLock();
-    scheduleExtThread(tso);
-    return WAIT_EXT_THREAD(tso, ret);
+    return scheduleWaitThread(tso,ret);
 }
 
 /*
@@ -481,8 +471,7 @@ rts_evalIO (HaskellObj p, /*out*/HaskellObj *ret)
     
     tso = createStrictIOThread(RtsFlags.GcFlags.initialStkSize, p);
     releaseAllocLock();
-    scheduleExtThread(tso);
-    return WAIT_EXT_THREAD(tso, ret);
+    return scheduleWaitThread(tso,ret);
 }
 
 /*
@@ -497,7 +486,7 @@ rts_mainEvalIO(HaskellObj p, /*out*/HaskellObj *ret)
     tso = createStrictIOThread(RtsFlags.GcFlags.initialStkSize, p);
     releaseAllocLock();
     scheduleThread(tso);
-    return WAIT_MAIN_THREAD(tso, ret);
+    return waitThread(tso, ret);
 }
 
 /*
@@ -516,8 +505,7 @@ rts_evalStableIO (HsStablePtr s, /*out*/HsStablePtr *ret)
     p = (StgClosure *)deRefStablePtr(s);
     tso = createStrictIOThread(RtsFlags.GcFlags.initialStkSize, p);
     releaseAllocLock();
-    scheduleExtThread(tso);
-    stat = WAIT_EXT_THREAD(tso, &r);
+    stat = scheduleWaitThread(tso,&r);
 
     if (stat == Success) {
        ASSERT(r != NULL);
@@ -537,8 +525,7 @@ rts_evalLazyIO (HaskellObj p, unsigned int stack_size, /*out*/HaskellObj *ret)
 
     tso = createIOThread(stack_size, p);
     releaseAllocLock();
-    scheduleExtThread(tso);
-    return WAIT_EXT_THREAD(tso, ret);
+    return scheduleWaitThread(tso,ret);
 }
 
 /* Convenience function for decoding the returned status. */

diff --git a/ghc/rts/Schedule.c b/ghc/rts/Schedule.c
index 3cf6d21..7e281e9 100644 (file)
--- a/ghc/rts/Schedule.c
+++ b/ghc/rts/Schedule.c
@@ -1,5 +1,5 @@
 /* ---------------------------------------------------------------------------
- * $Id: Schedule.c,v 1.144 2002/05/18 05:28:15 ken Exp $
+ * $Id: Schedule.c,v 1.145 2002/06/19 20:45:15 sof Exp $
  *
  * (c) The GHC Team, 1998-2000
  *
@@ -1908,6 +1908,13 @@ activateSpark (rtsSpark spark)
 }
 #endif
 
+static SchedulerStatus waitThread_(/*out*/StgMainThread* m
+#if defined(THREADED_RTS)
+                                  , rtsBool blockWaiting
+#endif
+                                  );
+
+
 /* ---------------------------------------------------------------------------
  * scheduleThread()
  *
@@ -1954,12 +1961,48 @@ scheduleThread_(StgTSO *tso
 
 void scheduleThread(StgTSO* tso)
 {
-  return scheduleThread_(tso, rtsFalse);
+  scheduleThread_(tso, rtsFalse);
 }
 
-void scheduleExtThread(StgTSO* tso)
+SchedulerStatus
+scheduleWaitThread(StgTSO* tso, /*[out]*/HaskellObj* ret)
 {
-  return scheduleThread_(tso, rtsTrue);
+  StgMainThread *m;
+
+  m = stgMallocBytes(sizeof(StgMainThread), "waitThread");
+  m->tso = tso;
+  m->ret = ret;
+  m->stat = NoStatus;
+#if defined(RTS_SUPPORTS_THREADS)
+  initCondition(&m->wakeup);
+#endif
+
+  /* Put the thread on the main-threads list prior to scheduling the TSO.
+     Failure to do so introduces a race condition in the MT case (as
+     identified by Wolfgang Thaller), whereby the new task/OS thread 
+     created by scheduleThread_() would complete prior to the thread
+     that spawned it managed to put 'itself' on the main-threads list.
+     The upshot of it all being that the worker thread wouldn't get to
+     signal the completion of the its work item for the main thread to
+     see (==> it got stuck waiting.)    -- sof 6/02.
+  */
+  ACQUIRE_LOCK(&sched_mutex);
+  IF_DEBUG(scheduler, sched_belch("== scheduler: waiting for thread (%d)\n", tso->id));
+  
+  m->link = main_threads;
+  main_threads = m;
+
+  /* Inefficient (scheduleThread_() acquires it again right away),
+   * but obviously correct.
+   */
+  RELEASE_LOCK(&sched_mutex);
+
+  scheduleThread_(tso, rtsTrue);
+#if defined(THREADED_RTS)
+  return waitThread_(m, rtsTrue);
+#else
+  return waitThread_(m);
+#endif
 }
 
 /* ---------------------------------------------------------------------------
@@ -2143,40 +2186,41 @@ finishAllThreads ( void )
 SchedulerStatus
 waitThread(StgTSO *tso, /*out*/StgClosure **ret)
 { 
+  StgMainThread *m;
+
+  m = stgMallocBytes(sizeof(StgMainThread), "waitThread");
+  m->tso = tso;
+  m->ret = ret;
+  m->stat = NoStatus;
+#if defined(RTS_SUPPORTS_THREADS)
+  initCondition(&m->wakeup);
+#endif
+
+  /* see scheduleWaitThread() comment */
+  ACQUIRE_LOCK(&sched_mutex);
+  IF_DEBUG(scheduler, sched_belch("== scheduler: waiting for thread (%d)\n", tso->id));
+  m->link = main_threads;
+  main_threads = m;
+  RELEASE_LOCK(&sched_mutex);
+
   IF_DEBUG(scheduler, sched_belch("== scheduler: waiting for thread (%d)\n", tso->id));
 #if defined(THREADED_RTS)
-  return waitThread_(tso,ret, rtsFalse);
+  return waitThread_(m, rtsFalse);
 #else
-  return waitThread_(tso,ret);
+  return waitThread_(m);
 #endif
 }
 
+static
 SchedulerStatus
-waitThread_(StgTSO *tso,
-           /*out*/StgClosure **ret
+waitThread_(StgMainThread* m
 #if defined(THREADED_RTS)
            , rtsBool blockWaiting
 #endif
           )
 {
-  StgMainThread *m;
   SchedulerStatus stat;
 
-  ACQUIRE_LOCK(&sched_mutex);
-  IF_DEBUG(scheduler, sched_belch("== scheduler: waiting for thread (%d)\n", tso->id));
-  
-  m = stgMallocBytes(sizeof(StgMainThread), "waitThread");
-
-  m->tso = tso;
-  m->ret = ret;
-  m->stat = NoStatus;
-#if defined(RTS_SUPPORTS_THREADS)
-  initCondition(&m->wakeup);
-#endif
-
-  m->link = main_threads;
-  main_threads = m;
-
   IF_DEBUG(scheduler, sched_belch("== scheduler: new main thread (%d)\n", m->tso->id));
 
 #if defined(RTS_SUPPORTS_THREADS)
@@ -2187,12 +2231,12 @@ waitThread_(StgTSO *tso,
      * gets to enter the RTS directly without going via another
      * task/thread.
      */
-    RELEASE_LOCK(&sched_mutex);
     schedule();
     ASSERT(m->stat != NoStatus);
   } else 
 # endif
   {
+    ACQUIRE_LOCK(&sched_mutex);
     do {
       waitCondition(&m->wakeup, &sched_mutex);
     } while (m->stat == NoStatus);

diff --git a/ghc/rts/Schedule.h b/ghc/rts/Schedule.h
index 5ea4c5c..0ddf00f 100644 (file)
--- a/ghc/rts/Schedule.h
+++ b/ghc/rts/Schedule.h
@@ -1,5 +1,5 @@
 /* -----------------------------------------------------------------------------
- * $Id: Schedule.h,v 1.33 2002/04/13 05:33:03 sof Exp $
+ * $Id: Schedule.h,v 1.34 2002/06/19 20:45:15 sof Exp $
  *
  * (c) The GHC Team 1998-1999
  *
@@ -138,14 +138,6 @@ extern nat         rts_n_waiting_tasks;
 
 StgInt forkProcess(StgTSO *tso);
 
-/* Sigh, RTS-internal versions of waitThread(), scheduleThread(), and
-   rts_evalIO() for the use by main() only. ToDo: better. */
-extern SchedulerStatus waitThread_(StgTSO *tso,
-                                  /*out*/StgClosure **ret
-#if defined(THREADED_RTS)
-                                  , rtsBool blockWaiting
-#endif
-                                  );
 extern SchedulerStatus rts_mainEvalIO(HaskellObj p, /*out*/HaskellObj *ret);