[project @ 2005-02-15 11:39:52 by simonmar]

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

diff --git a/ghc/rts/Schedule.c b/ghc/rts/Schedule.c
index 6aedb8f..6f4e5f9 100644 (file)
--- a/ghc/rts/Schedule.c
+++ b/ghc/rts/Schedule.c
@@ -168,6 +168,11 @@ int context_switch = 0;
 /* if this flag is set as well, give up execution */
 rtsBool interrupted = rtsFalse;
 
+/* If this flag is set, we are running Haskell code.  Used to detect
+ * uses of 'foreign import unsafe' that should be 'safe'.
+ */
+rtsBool in_haskell = rtsFalse;
+
 /* Next thread ID to allocate.
  * Locks required: thread_id_mutex
  */
@@ -421,6 +426,15 @@ schedule( StgMainThread *mainThread USED_WHEN_RTS_SUPPORTS_THREADS,
       // We now have a capability...
 #endif
 
+    // Check whether we have re-entered the RTS from Haskell without
+    // going via suspendThread()/resumeThread (i.e. a 'safe' foreign
+    // call).
+    if (in_haskell) {
+         errorBelch("schedule: re-entered unsafely.\n"
+                    "   Perhaps a 'foreign import unsafe' should be 'safe'?");
+         stg_exit(1);
+    }
+
     //
     // If we're interrupted (the user pressed ^C, or some other
     // termination condition occurred), kill all the currently running
@@ -542,7 +556,10 @@ schedule( StgMainThread *mainThread USED_WHEN_RTS_SUPPORTS_THREADS,
     // ToDo: add deadlock detection in GUM (similar to SMP) -- HWL
 #endif
 
-#if defined(RTS_SUPPORTS_THREADS)
+#if defined(RTS_SUPPORTS_THREADS) || defined(mingw32_HOST_OS)
+    /* win32: might be back here due to awaitEvent() being abandoned
+     * as a result of a console event having been delivered.
+     */
     if ( EMPTY_RUN_QUEUE() ) {
        continue; // nothing to do
     }
@@ -899,6 +916,7 @@ run_thread:
     prev_what_next = t->what_next;
 
     errno = t->saved_errno;
+    in_haskell = rtsTrue;
 
     switch (prev_what_next) {
 
@@ -920,6 +938,8 @@ run_thread:
       barf("schedule: invalid what_next field");
     }
 
+    in_haskell = rtsFalse;
+
     // The TSO might have moved, so find the new location:
     t = cap->r.rCurrentTSO;
 
@@ -1044,7 +1064,6 @@ run_thread:
 #endif
       
       ready_to_gc = rtsTrue;
-      context_switch = 1;              /* stop other threads ASAP */
       PUSH_ON_RUN_QUEUE(t);
       /* actual GC is done at the end of the while loop */
       break;
@@ -1421,7 +1440,7 @@ isThreadBound(StgTSO* tso USED_IN_THREADED_RTS)
  * Singleton fork(). Do not copy any running threads.
  * ------------------------------------------------------------------------- */
 
-#ifndef mingw32_TARGET_OS
+#ifndef mingw32_HOST_OS
 #define FORKPROCESS_PRIMOP_SUPPORTED
 #endif
 
@@ -1581,6 +1600,7 @@ suspendThread( StgRegTable *reg )
   IF_DEBUG(scheduler, sched_belch("worker (token %d): leaving RTS", tok));
 #endif
 
+  in_haskell = rtsFalse;
   RELEASE_LOCK(&sched_mutex);
   
   errno = saved_errno;
@@ -1628,6 +1648,7 @@ resumeThread( StgInt tok )
   tso->why_blocked  = NotBlocked;
 
   cap->r.rCurrentTSO = tso;
+  in_haskell = rtsTrue;
   RELEASE_LOCK(&sched_mutex);
   errno = saved_errno;
   return &cap->r;
@@ -2328,7 +2349,6 @@ threadStackOverflow(StgTSO *tso)
   tso->link = dest;
   tso->sp = (P_)&(tso->stack[tso->stack_size]);
   tso->why_blocked = NotBlocked;
-  dest->mut_link = NULL;
 
   IF_PAR_DEBUG(verbose,
               debugBelch("@@ threadStackOverflow of TSO %d (now at %p): stack size increased to %ld\n",
@@ -2759,7 +2779,7 @@ unblockThread(StgTSO *tso)
 
   case BlockedOnRead:
   case BlockedOnWrite:
-#if defined(mingw32_TARGET_OS)
+#if defined(mingw32_HOST_OS)
   case BlockedOnDoProc:
 #endif
     {
@@ -2897,7 +2917,7 @@ unblockThread(StgTSO *tso)
 
   case BlockedOnRead:
   case BlockedOnWrite:
-#if defined(mingw32_TARGET_OS)
+#if defined(mingw32_HOST_OS)
   case BlockedOnDoProc:
 #endif
     {
@@ -3427,7 +3447,7 @@ printThreadBlockage(StgTSO *tso)
   case BlockedOnWrite:
     debugBelch("is blocked on write to fd %d", tso->block_info.fd);
     break;
-#if defined(mingw32_TARGET_OS)
+#if defined(mingw32_HOST_OS)
     case BlockedOnDoProc:
     debugBelch("is blocked on proc (request: %d)", tso->block_info.async_result->reqID);
     break;