From: Matt Birkholz <puck@birchwood-abbey.net>
Date: Thu, 9 Jul 2015 16:18:32 +0000 (-0700)
Subject: More checking for no-current-thread.
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=d2d1c43d51f6e5861e5a57dcd9d9c30eaafcadbe;p=mit-scheme.git

More checking for no-current-thread.
---

diff --git a/src/runtime/thread.scm b/src/runtime/thread.scm
index 4a9c51139..71ecfe30f 100644
--- a/src/runtime/thread.scm
+++ b/src/runtime/thread.scm
@@ -332,10 +332,10 @@ USA.
   (%unlock))
 
 (define (suspend-current-thread)
-  (without-interrupts
-   (lambda ()
-     (%lock)
-     (%suspend-thread first-running-thread))))
+  (set-interrupt-enables! interrupt-mask/in-threads)
+  (%lock)
+  (%assert first-running-thread "suspend-current-thread: no current thread")
+  (%suspend-thread first-running-thread))
 
 (define (%suspend-thread thread)
   (%assert-locked '%suspend-thread)
@@ -360,6 +360,7 @@ USA.
   (call-with-current-continuation
    (lambda (continuation)
      (let ((thread first-running-thread))
+       (%assert thread "stop-current-thread: lost current thread")
        (set-thread/continuation! thread continuation)
        (maybe-save-thread-float-environment! thread)
        (set-interrupt-enables! interrupt-mask/in-threads)
@@ -418,8 +419,9 @@ USA.
 (define (yield-current-thread)
   (without-interrupts
    (lambda ()
+     (%lock)
      (let ((thread first-running-thread))
-       (%lock)
+       (%assert thread "yield-current-thread: no current thread")
        ;; Allow preemption now, since the current thread has
        ;; volunteered to yield control.
        (set-thread/execution-state! thread 'RUNNING)
@@ -467,7 +469,8 @@ USA.
 
 (define (join-thread thread event-constructor)
   (guarantee-thread thread 'JOIN-THREAD)
-  (let ((self (current-thread)))
+  (let ((self first-running-thread))
+    (%assert self "join-thread: no current thread")
     (if (eq? thread self)
 	(signal-thread-deadlock self "join thread" join-thread thread)
 	(let ((mask (set-interrupt-enables! interrupt-mask/in-threads)))
@@ -492,7 +495,8 @@ USA.
 		   (set-interrupt-enables! mask)
 		   (signal-thread-event
 		    self
-		     (event-constructor thread value)))))))))
+		    ;; Executed in the dynamic state of SELF, not THREAD(!).
+		    (event-constructor thread value)))))))))
 
 (define (detach-thread thread)
   (guarantee-thread thread 'DETACH-THREAD)
@@ -870,6 +874,7 @@ USA.
   (with-thread-lock
    (lambda ()
      (let ((thread first-running-thread))
+       (%assert thread "unblock-thread-events: no current thread")
        (handle-thread-events thread)
        (set-thread/block-events?! thread #f)))))
 
@@ -1186,7 +1191,9 @@ USA.
 (define (deregister-all-events)
   (with-thread-lock
    (lambda ()
-     (let* ((thread first-running-thread)
+     (let* ((thread
+	     (or first-running-thread
+		 (%outf-error "deregister-all-events: no current thread")))
 	    (block-events? (thread/block-events? thread)))
       (set-thread/block-events?! thread #t)
       (ring/discard-all (thread/pending-events thread))
@@ -1306,7 +1313,8 @@ USA.
   (guarantee-thread-mutex mutex 'LOCK-THREAD-MUTEX)
   (let ((mask (set-interrupt-enables! interrupt-mask/in-threads)))
     (%lock)
-    (let ((thread first-running-thread)
+    (let ((thread (or first-running-thread
+		      (%outf-error "lock-thread-mutex: no current thread")))
 	  (owner (thread-mutex/owner mutex)))
       (if (eq? owner thread)
 	  (begin
@@ -1334,8 +1342,10 @@ USA.
   (guarantee-thread-mutex mutex 'UNLOCK-THREAD-MUTEX)
   (let ((mask (set-interrupt-enables! interrupt-mask/in-threads)))
     (%lock)
-    (let ((owner (thread-mutex/owner mutex)))
-      (if (and owner (not (eq? owner (current-thread))))
+    (let ((thread (or first-running-thread
+		    (%outf-error "unlock-thread-mutex: no current thread")))
+	  (owner (thread-mutex/owner mutex)))
+      (if (and owner (not (eq? owner thread)))
 	  (begin
 	    (%unlock)
 	    (set-interrupt-enables! mask)
@@ -1363,7 +1373,9 @@ USA.
   (with-thread-lock
    (lambda ()
      (and (not (thread-mutex/owner mutex))
-	  (let ((thread (current-thread)))
+	  (let ((thread
+		 (or first-running-thread
+		     (%outf-error "try-lock-thread-mutex: no current thread"))))
 	    (set-thread-mutex/owner! mutex thread)
 	    (add-thread-mutex! thread mutex)
 	    #t)))))