[project @ 2005-05-09 10:10:33 by simonmar]

[ghc-hetmet.git] / ghc / rts / Schedule.c

diff --git a/ghc/rts/Schedule.c b/ghc/rts/Schedule.c
index ed76cb0..ad27b74 100644 (file)
--- a/ghc/rts/Schedule.c
+++ b/ghc/rts/Schedule.c
@@ -174,6 +174,9 @@ static StgTSO *suspended_ccalling_threads;
 /* flag set by signal handler to precipitate a context switch */
 int context_switch = 0;
 
+/* flag that tracks whether we have done any execution in this time slice. */
+nat recent_activity = ACTIVITY_YES;
+
 /* if this flag is set as well, give up execution */
 rtsBool interrupted = rtsFalse;
 
@@ -473,6 +476,15 @@ schedule( StgMainThread *mainThread USED_WHEN_RTS_SUPPORTS_THREADS,
 
       // We now have a capability...
 #endif
+      
+#if 0 /* extra sanity checking */
+      { 
+         StgMainThread *m;
+         for (m = main_threads; m != NULL; m = m->link) {
+             ASSERT(get_itbl(m->tso)->type == TSO);
+         }
+      }
+#endif
 
     // Check whether we have re-entered the RTS from Haskell without
     // going via suspendThread()/resumeThread (i.e. a 'safe' foreign
@@ -668,6 +680,8 @@ run_thread:
     errno = t->saved_errno;
     cap->r.rInHaskell = rtsTrue;
 
+    recent_activity = ACTIVITY_YES;
+
     switch (prev_what_next) {
 
     case ThreadKilled:
@@ -850,6 +864,12 @@ scheduleCheckBlackHoles( void )
 static void
 scheduleDetectDeadlock(void)
 {
+
+#if defined(PARALLEL_HASKELL)
+    // ToDo: add deadlock detection in GUM (similar to SMP) -- HWL
+    return;
+#endif
+
     /* 
      * Detect deadlock: when we have no threads to run, there are no
      * threads blocked, waiting for I/O, or sleeping, and all the
@@ -858,7 +878,16 @@ scheduleDetectDeadlock(void)
      */
     if ( EMPTY_THREAD_QUEUES() )
     {
-#if !defined(PARALLEL_HASKELL) && !defined(RTS_SUPPORTS_THREADS)
+#if defined(RTS_SUPPORTS_THREADS)
+       /* 
+        * In the threaded RTS, we only check for deadlock if there
+        * has been no activity in a complete timeslice.  This means
+        * we won't eagerly start a full GC just because we don't have
+        * any threads to run currently.
+        */
+       if (recent_activity != ACTIVITY_INACTIVE) return;
+#endif
+
        IF_DEBUG(scheduler, sched_belch("deadlocked, forcing major GC..."));
 
        // Garbage collection can release some new threads due to
@@ -867,9 +896,10 @@ scheduleDetectDeadlock(void)
        // exception.  Any threads thus released will be immediately
        // runnable.
        GarbageCollect(GetRoots,rtsTrue);
+       recent_activity = ACTIVITY_DONE_GC;
        if ( !EMPTY_RUN_QUEUE() ) return;
 
-#if defined(RTS_USER_SIGNALS)
+#if defined(RTS_USER_SIGNALS) && !defined(RTS_SUPPORTS_THREADS)
        /* If we have user-installed signal handlers, then wait
         * for signals to arrive rather then bombing out with a
         * deadlock.
@@ -891,6 +921,7 @@ scheduleDetectDeadlock(void)
        }
 #endif
 
+#if !defined(RTS_SUPPORTS_THREADS)
        /* Probably a real deadlock.  Send the current main thread the
         * Deadlock exception (or in the SMP build, send *all* main
         * threads the deadlock exception, since none of them can make
@@ -910,11 +941,6 @@ scheduleDetectDeadlock(void)
                barf("deadlock: main thread blocked in a strange way");
            }
        }
-
-#elif defined(RTS_SUPPORTS_THREADS)
-    // ToDo: add deadlock detection in threaded RTS
-#elif defined(PARALLEL_HASKELL)
-    // ToDo: add deadlock detection in GUM (similar to SMP) -- HWL
 #endif
     }
 }
@@ -1802,6 +1828,7 @@ scheduleHandleThreadFinished( StgMainThread *mainThread
          removeThreadLabel((StgWord)mainThread->tso->id);
 #endif
          if (mainThread->prev == NULL) {
+             ASSERT(mainThread == main_threads);
              main_threads = mainThread->link;
          } else {
              mainThread->prev->link = mainThread->link;
@@ -1958,7 +1985,7 @@ scheduleDoGC( Capability *cap STG_UNUSED )
 StgBool
 rtsSupportsBoundThreads(void)
 {
-#ifdef THREADED_RTS
+#if defined(RTS_SUPPORTS_THREADS)
   return rtsTrue;
 #else
   return rtsFalse;
@@ -1972,7 +1999,7 @@ rtsSupportsBoundThreads(void)
 StgBool
 isThreadBound(StgTSO* tso USED_IN_THREADED_RTS)
 {
-#ifdef THREADED_RTS
+#if defined(RTS_SUPPORTS_THREADS)
   return (tso->main != NULL);
 #endif
   return rtsFalse;
@@ -2066,8 +2093,12 @@ deleteAllThreads ( void )
   StgTSO* t, *next;
   IF_DEBUG(scheduler,sched_belch("deleting all threads"));
   for (t = all_threads; t != END_TSO_QUEUE; t = next) {
-      next = t->global_link;
-      deleteThread(t);
+      if (t->what_next == ThreadRelocated) {
+         next = t->link;
+      } else {
+         next = t->global_link;
+         deleteThread(t);
+      }
   }      
 
   // The run queue now contains a bunch of ThreadKilled threads.  We
@@ -3220,6 +3251,11 @@ interruptStgRts(void)
 {
     interrupted    = 1;
     context_switch = 1;
+    threadRunnable();
+    /* ToDo: if invoked from a signal handler, this threadRunnable
+     * only works if there's another thread (not this one) waiting to
+     * be woken up.
+     */
 }
 
 /* -----------------------------------------------------------------------------
@@ -3343,6 +3379,12 @@ unblockThread(StgTSO *tso)
              blocked_queue_tl = (StgTSO *)prev;
            }
          }
+#if defined(mingw32_HOST_OS)
+         /* (Cooperatively) signal that the worker thread should abort
+          * the request.
+          */
+         abandonWorkRequest(tso->block_info.async_result->reqID);
+#endif
          goto done;
        }
       }
@@ -3477,6 +3519,12 @@ unblockThread(StgTSO *tso)
              blocked_queue_tl = prev;
            }
          }
+#if defined(mingw32_HOST_OS)
+         /* (Cooperatively) signal that the worker thread should abort
+          * the request.
+          */
+         abandonWorkRequest(tso->block_info.async_result->reqID);
+#endif
          goto done;
        }
       }
@@ -3739,12 +3787,12 @@ raiseAsync_(StgTSO *tso, StgClosure *exception, rtsBool stop_at_atomically)
 #ifdef PROFILING
            StgCatchFrame *cf = (StgCatchFrame *)frame;
 #endif
-           StgClosure *raise;
+           StgThunk *raise;
            
            // we've got an exception to raise, so let's pass it to the
            // handler in this frame.
            //
-           raise = (StgClosure *)allocate(sizeofW(StgClosure)+1);
+           raise = (StgThunk *)allocate(sizeofW(StgThunk)+1);
            TICK_ALLOC_SE_THK(1,0);
            SET_HDR(raise,&stg_raise_info,cf->header.prof.ccs);
            raise->payload[0] = exception;
@@ -3849,7 +3897,7 @@ raiseAsync_(StgTSO *tso, StgClosure *exception, rtsBool stop_at_atomically)
 StgWord
 raiseExceptionHelper (StgTSO *tso, StgClosure *exception)
 {
-    StgClosure *raise_closure = NULL;
+    StgThunk *raise_closure = NULL;
     StgPtr p, next;
     StgRetInfoTable *info;
     //
@@ -3886,11 +3934,11 @@ raiseExceptionHelper (StgTSO *tso, StgClosure *exception)
            // Only create raise_closure if we need to.
            if (raise_closure == NULL) {
                raise_closure = 
-                   (StgClosure *)allocate(sizeofW(StgClosure)+MIN_UPD_SIZE);
+                   (StgThunk *)allocate(sizeofW(StgThunk)+MIN_UPD_SIZE);
                SET_HDR(raise_closure, &stg_raise_info, CCCS);
                raise_closure->payload[0] = exception;
            }
-           UPD_IND(((StgUpdateFrame *)p)->updatee,raise_closure);
+           UPD_IND(((StgUpdateFrame *)p)->updatee,(StgClosure *)raise_closure);
            p = next;
            continue;