From: Matt Birkholz <puck@birchwood-abbey.net>
Date: Sun, 21 Dec 2014 19:02:38 +0000 (-0700)
Subject: smp: Serialize access to (runtime thread) internals.
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=29c3f404a73830d05e5e34f748ad293fa3ff9e45;p=mit-scheme.git

smp: Serialize access to (runtime thread) internals.
---

diff --git a/src/runtime/thread.scm b/src/runtime/thread.scm
index c4c90de9d..89e0ee9b7 100644
--- a/src/runtime/thread.scm
+++ b/src/runtime/thread.scm
@@ -32,6 +32,62 @@ USA.
 ;;; This is set at boot/restore time and allows a host without the SMP
 ;;; primitives to run this code.
 (define enable-smp? #f)
+
+;;; Serialized Access
+;;;
+;;; Multiple processors may use this thread system simultaneously, so
+;;; procedures that modify its data structures (or that just want to
+;;; read consistent data structures!) must arrange to serialize their
+;;; accesses.  They must lock an OS-level mutex and unlock it when
+;;; they are done, and they must do this without-interrupts.  While
+;;; the mutex is locked, they should NOT signal errors nor invoke
+;;; arbitrary hooks, handlers, etc.  Thus there should be no need for
+;;; a recursive mutex.
+
+(define locked? #f)
+
+(define-integrable (get-interrupt-enables)
+  ((ucode-primitive get-interrupt-enables 0)))
+
+(define-integrable (only-gc-ok?)
+  (fix:= 0 (fix:andc (get-interrupt-enables) interrupt-mask/gc-ok)))
+
+(define-integrable (%lock)
+  (%if-tracing
+   ;; This happens when there is contention.  It is interesting,
+   ;; but not really a problem, so is noted only while %trace?ing.
+   (complain-if locked?
+		"%lock already locked"))
+  (if enable-smp?
+      ((ucode-primitive smp-lock-threads 1) #t))
+  (complain-if (not (only-gc-ok?))
+	       "%lock with wrong interrupt mask")
+  (set! locked? #t))
+
+(define-integrable (%unlock)
+  (complain-if (not locked?)
+	       "%unlock not locked")
+  (if enable-smp?
+      ((ucode-primitive smp-lock-threads 1) #f))
+  (complain-if (not (only-gc-ok?))
+	       "%unlock with wrong interrupt mask")
+  (set! locked? #f))
+
+(define-integrable (without-interrupts thunk)
+  (let ((interrupt-mask
+	 (set-interrupt-enables!
+	  (fix:and interrupt-mask/gc-ok (get-interrupt-enables)))))
+    (let ((value (thunk)))
+      (set-interrupt-enables! interrupt-mask)
+      value)))
+
+(define-integrable (with-threads-locked thunk)
+  (let ((interrupt-mask (set-interrupt-enables! interrupt-mask/gc-ok)))
+    (%lock)
+    (let ((value (thunk)))
+      (%unlock)
+      (set-interrupt-enables! interrupt-mask)
+      value)))
 
 (define-structure (thread
 		   (constructor %make-thread ())
@@ -94,7 +150,10 @@ USA.
 (define no-exit-value-marker
   (list 'NO-EXIT-VALUE-MARKER))
 
-(define-integrable (thread-dead? thread)
+(define (thread-dead? thread)
+  (guarantee-thread thread 'THREAD-DEAD?)
+  ;; Assuming the machine reads and writes words atomically, the
+  ;; execution-state slot can be read without locking.
   (eq? 'DEAD (thread/execution-state thread)))
 
 (define thread-population)
@@ -129,21 +188,10 @@ USA.
   (add-event-receiver! event:after-restore reset-threads!)
   (add-event-receiver! event:before-exit stop-thread-timer))
 
-(define (make-thread continuation)
-  (let ((thread (%make-thread)))
-    (set-thread/continuation! thread continuation)
-    (add-to-population!/unsafe thread-population thread)
-    (thread-running thread)
-    thread))
-
-(define-integrable (without-interrupts thunk)
-  (let ((interrupt-mask (set-interrupt-enables! interrupt-mask/gc-ok)))
-    (let ((value (thunk)))
-      (set-interrupt-enables! interrupt-mask)
-      value)))
-
 (define (threads-list)
-  (map-over-population thread-population (lambda (thread) thread)))
+  (with-threads-locked
+   (lambda ()
+     (map-over-population thread-population (lambda (thread) thread)))))
 
 (define (thread-execution-state thread)
   (guarantee-thread thread 'THREAD-EXECUTION-STATE)
@@ -162,11 +210,15 @@ USA.
 	 (lambda ()
 	   (call-with-current-continuation
 	    (lambda (continuation)
-	      (let ((thread (make-thread continuation)))
+	      (let ((thread (%make-thread)))
+		(set-thread/continuation! thread continuation)
+		(with-threads-locked
+		 (lambda ()
+		   (add-to-population!/unsafe thread-population thread)
+		   (thread-running (%id) thread)))
 		(%within-continuation (let ((k return)) (set! return #f) k)
-				      #t
-				      (lambda () thread)))))
-	   (set-interrupt-enables! interrupt-mask/all)
+		    #t
+		  (lambda () thread)))))
 	   (exit-current-thread
 	    (with-create-thread-continuation root-continuation thunk))))))))
 
@@ -184,11 +236,11 @@ USA.
 (define current-threads #f)
 
 (define-integrable (%id)
-  ;; To avoid task switching between accessing a processor id and
-  ;; using it (e.g. passing it to %current-thread), %id should be
+  ;; To avoid switching processors between accessing the processor id
+  ;; and using it (e.g. passing it to %current-thread), %id should be
   ;; called without-interrupts.
-  (if (not (fix:= (get-interrupt-enables) interrupt-mask/gc-ok))
-      (outf-error "\n;%id: WRONG interrupt mask!"))
+  (complain-if (not (only-gc-ok?))
+	       "%id: wrong interrupt mask")
   (if enable-smp?
       ((ucode-primitive smp-id 0))
       0))
@@ -214,77 +266,103 @@ USA.
 		      (loop (fix:1+ i))))))))))
 
 (define (thread-continuation thread)
-  (guarantee-thread thread 'THREAD-CONTINUATION)
+  (guarantee-thread thread 'thread-continuation)
   (thread/continuation thread))
 
-(define (thread-running thread)
-  (%thread-running thread)
+(define (thread-running id thread)
+  (assert-locked 'thread-running)
+  (%thread-running id thread)
   (%maybe-toggle-thread-timer))
 
-(define (%thread-running thread)
+(define (%thread-running id thread)
+  (%%trace ";"id" %thread-running "thread"\n")
+  (assert-locked '%thread-running)
   (set-thread/execution-state! thread 'RUNNING)
   (let ((prev last-runnable-thread))
     (if prev
 	(set-thread/next! prev thread)
 	(set! first-runnable-thread thread)))
   (set! last-runnable-thread thread)
+  (complain-if (not (eq? #f (thread/next thread)))
+	       "%thread-running: last-runnable-thread has a next")
   unspecific)
 
 (define (thread-not-running id thread state)
-  (if (not (eq? thread (%current-thread id)))
-      (outf-error "\n;thread-not-running: NOT CURRENT"))
+  ;; This procedure never returns.
+  (%trace ";"id" thread-not-running: stopping "thread" in state "state"\n")
+  (assert-locked 'thread-not-running)
+  (complain-if (not (eq? thread (%current-thread id)))
+	       "thread-not-running: not current")
   (set-thread/execution-state! thread state)
   (vector-set! current-threads id #f)
   (run-first-thread id))
 
 (define (run-first-thread id)
+  ;; This procedure never returns.
+  (assert-locked 'run-first-thread)
+  (complain-if (%current-thread id)
+	       "run-first-thread: already running a thread")
   (if first-runnable-thread
       (let ((thread first-runnable-thread))
-	(if (%current-thread id)
-	    (outf-error "\n;run-first-thread: ALREADY running a thread!"))
+	(%%trace ";"id" run-first-thread: running "thread"\n")
 	(set! first-runnable-thread (thread/next thread))
 	(if (not first-runnable-thread)
 	    (set! last-runnable-thread #f)
-	    (if (not last-runnable-thread)
-		(outf-error "\n;run-first-thread: lost last-runnable!")))
+	    (complain-if (not last-runnable-thread)
+			 "run-first-thread: lost last-runnable"))
 	(set-thread/next! thread #f)
 	(vector-set! current-threads id thread)
 	(run-thread thread))
-      (wait-for-io)))
+      (begin
+	(%%trace ";"id" run-first-thread: no runnable threads\n")
+	(wait-for-io id))))
 
 (define (run-thread thread)
+  ;; This procedure never returns.
+  (%%trace ";"(%%id)" run-thread "thread"\n")
+  (assert-locked 'run-thread)
   (let ((continuation (thread/continuation thread))
 	(fp-env (thread/floating-point-environment thread)))
-    (if (not (continuation? continuation))
-	(outf-error "\n;run-thread: NO CONTINUATION!"))
+    (complain-if (not (continuation? continuation))
+		 "run-thread: no continuation")
     (set-thread/continuation! thread #f)
     (%within-continuation continuation #t
       (lambda ()
 	(enter-float-environment fp-env)
-	(%resume-current-thread thread)))))
+	(%resume-thread thread)))))
 
-(define (%resume-current-thread thread)
+(define (%resume-thread thread)
+  (%trace ";"(%%id)" %resume-thread "thread"\n")
+  (assert-locked '%resume-thread)
+  (complain-if (not (eq? thread (%current-thread (%%id))))
+	       "%resume-thread: not current")
   (if (not (thread/block-events? thread))
-      (begin
-	(handle-thread-events thread)
-	(set-thread/block-events?! thread #f)))
+      (handle-thread-events thread))
   (%maybe-toggle-thread-timer)
-  (set-interrupt-enables! interrupt-mask/all))
+  (%unlock))
 
 (define (suspend-current-thread)
   (without-interrupts %suspend-current-thread))
 
 (define (%suspend-current-thread)
-  (%suspend-thread (%current-thread (%id))))
+  (let* ((id (%id))
+	 (thread (%current-thread id)))
+    (%trace ";"id" %suspend-current-thread "thread"\n")
+    (%lock)
+    (%suspend-thread thread)))
 
 (define (%suspend-thread thread)
+  (%trace ";"(%%id)" %suspend-thread "thread"\n")
+  (assert-locked '%suspend-thread)
   (let ((block-events? (thread/block-events? thread)))
     (set-thread/block-events?! thread #f)
     (maybe-signal-io-thread-events)
     (let ((any-events? (handle-thread-events thread)))
       (set-thread/block-events?! thread block-events?)
       (if any-events?
-	  (%maybe-toggle-thread-timer)
+	  (begin
+	    (%maybe-toggle-thread-timer)
+	    (%unlock))
 	  (call-with-current-continuation
 	   (lambda (continuation)
 	     (set-thread/continuation! thread continuation)
@@ -297,10 +375,12 @@ USA.
    (lambda ()
      (let* ((id (%id))
 	    (thread (%current-thread id)))
+       (%trace ";"id" stop-current-thread: "thread"\n")
        (call-with-current-continuation
 	(lambda (continuation)
 	  (set-thread/continuation! thread continuation)
 	  (maybe-save-thread-float-environment! thread)
+	  (%lock)
 	  (thread-not-running id thread 'STOPPED)))))))
 
 (define (restart-thread thread discard-events? event)
@@ -314,9 +394,11 @@ USA.
      (lambda ()
        (if (not (eq? 'STOPPED (thread/execution-state thread)))
 	   (error:bad-range-argument thread restart-thread))
+       (%lock)
        (if discard-events? (ring/discard-all (thread/pending-events thread)))
        (if event (%signal-thread-event thread event))
-       (thread-running thread)))))
+       (thread-running (%id) thread)
+       (%unlock)))))
 
 (define (disallow-preempt-current-thread)
   (set-thread/execution-state! (current-thread) 'RUNNING-WITHOUT-PREEMPTION))
@@ -328,24 +410,36 @@ USA.
   ;; Preserve the floating-point environment here to guarantee that the
   ;; thread timer won't raise or clear exceptions (particularly the
   ;; inexact result exception) that the interrupted thread cares about.
+  (%lock)
   (let* ((id (%id))
-	 (old (%current-thread id)))
-    (let ((fp-env (enter-default-float-environment old)))
-      (set! next-scheduled-timeout #f)
-      (deliver-timer-events)
-      (maybe-signal-io-thread-events)
-      (cond ((and (not first-runnable-thread) (not old))
-	     (%maybe-toggle-thread-timer))
-	    ((not old)
-	     (run-first-thread id))
-	    ((not first-runnable-thread)
-	     (restore-float-environment-from-default fp-env)
-	     (%resume-current-thread old))
-	    ((eq? 'RUNNING-WITHOUT-PREEMPTION (thread/execution-state old))
-	     (restore-float-environment-from-default fp-env)
-	     (%resume-current-thread old))
-	    (else
-	     (%yield-thread id old fp-env))))))
+	 (old (%current-thread id))
+	 (fp-env (and old (enter-default-float-environment old))))
+    (%%trace ";"id" thread-timer: interrupt in "old"\n")
+    (set! next-scheduled-timeout #f)
+    (deliver-timer-events)
+    (maybe-signal-io-thread-events)
+    (cond ((and (not first-runnable-thread) (not old))
+	   (%maybe-toggle-thread-timer)
+	   (%%trace ";"id" thread-timer: continuing with timer set for "
+		    next-scheduled-timeout"\n")
+	   (%unlock))
+	  ((not old)
+	   (%%trace ";"id" thread-timer: switching to "
+		    first-runnable-thread"\n")
+	   (run-first-thread id))
+	  ((not first-runnable-thread)
+	   (%trace ";"id" thread-timer: no runnable threads;"
+		   " continuing with "old"\n")
+	   (restore-float-environment-from-default fp-env)
+	   (%resume-thread old))
+	  ((eq? 'RUNNING-WITHOUT-PREEMPTION (thread/execution-state old))
+	   (%trace ";"id" thread-timer: running-without-preemption;"
+		   " continuing with "old"\n")
+	   (restore-float-environment-from-default fp-env)
+	   (%resume-thread old))
+	  (else
+	   (%trace ";"id" thread-timer: yielding "old"\n")
+	   (%yield-thread id old fp-env)))))
 
 (define (yield-current-thread)
   (without-interrupts
@@ -354,22 +448,28 @@ USA.
 	    (thread (%current-thread id)))
        (if thread
 	   (let ((fp-env (enter-default-float-environment thread)))
+	     (%lock)
 	     (maybe-signal-io-thread-events)
 	     ;; Allow preemption now, since the current thread has
 	     ;; volunteered to yield control.
 	     (set-thread/execution-state! thread 'RUNNING)
-	     (%yield-thread id thread fp-env)))))))
+	     (%yield-thread id thread fp-env))
+	   (complain-if #t "yield-current-thread: no current thread"))))))
 
 (define (%yield-thread id thread fp-env)
+  (%trace ";"id" %yield-thread: "thread" yields to "first-runnable-thread"\n")
+  (assert-locked '%yield-thread)
+  (complain-if (not (eq? thread (%current-thread id)))
+	       "%yield-thread: NOT CURRENT")
   (if (not first-runnable-thread)
       (begin
 	(restore-float-environment-from-default fp-env)
-	(%resume-current-thread thread))
+	(%resume-thread thread))
       (call-with-current-continuation
        (lambda (continuation)
 	 (set-thread/continuation! thread continuation)
 	 (maybe-save-thread-float-environment! thread fp-env)
-	 (%thread-running thread)
+	 (%thread-running id thread)
 	 (vector-set! current-threads id #F)
 	 (run-first-thread id)))))
 
@@ -384,10 +484,11 @@ USA.
    (lambda ()
      (let* ((id (%id))
 	    (thread (%current-thread id)))
-       (set-interrupt-enables! interrupt-mask/gc-ok)
+       (%trace ";"id" exit-current-thread: "thread" with "value"\n")
        (set-thread/block-events?! thread #t)
-       (ring/discard-all (thread/pending-events thread))
        (dynamic-unwind thread)
+       (%lock)
+       (ring/discard-all (thread/pending-events thread))
        (%deregister-io-thread-events thread #t)
        (%discard-thread-timer-records thread)
        (%disassociate-joined-threads thread)
@@ -403,6 +504,7 @@ USA.
 	(signal-thread-deadlock self "join thread" join-thread thread)
 	(without-interrupts
 	 (lambda ()
+	   (%lock)
 	   (let ((value (thread/exit-value thread)))
 	     (cond ((eq? value no-exit-value-marker)
 		    (set-thread/joined-threads!
@@ -411,26 +513,43 @@ USA.
 			   (thread/joined-threads thread)))
 		    (set-thread/joined-to!
 		     self
-		     (cons thread (thread/joined-to self))))
+		     (cons thread (thread/joined-to self)))
+		    (%trace ";"(%%id)" join-thread "self
+			    " to "thread": queued\n")
+		    (%unlock))
 		   ((eq? value detached-thread-marker)
+		    (%unlock)
 		    (signal-thread-detached thread))
 		   (else
+		    (%unlock)
+		    (%trace ";"(%%id)" join-thread "self
+			    " to "thread": signal self\n")
 		    (signal-thread-event
 		     self
-		     (event-constructor thread value))))))))))
+		     (event-constructor thread value))
+		    (%trace ";"(%%id)" join-thread "self
+			    " to "thread": signaled self\n")
+		    value))))))))
 
 (define (detach-thread thread)
   (guarantee-thread thread 'DETACH-THREAD)
   (without-interrupts
    (lambda ()
+     (%lock)
      (if (eq? (thread/exit-value thread) detached-thread-marker)
-	 (signal-thread-detached thread))
-     (release-joined-threads thread detached-thread-marker))))
+	 (begin
+	   (%unlock)
+	   (signal-thread-detached thread))
+	 (begin
+	   (release-joined-threads thread detached-thread-marker)
+	   (%unlock)))))
+  thread)
 
 (define detached-thread-marker
   (list 'DETACHED-THREAD-MARKER))
 
 (define (release-joined-threads thread value)
+  (assert-locked 'release-joined-threads)
   (set-thread/exit-value! thread value)
   (do ((joined (thread/joined-threads thread) (cdr joined)))
       ((not (pair? joined)))
@@ -441,6 +560,7 @@ USA.
   (%maybe-toggle-thread-timer))
 
 (define (%disassociate-joined-threads thread)
+  (assert-locked '%disassociate-joined-threads)
   (do ((threads (thread/joined-to thread) (cdr threads)))
       ((not (pair? threads)))
     (set-thread/joined-threads!
@@ -487,8 +607,8 @@ USA.
 	   (set! current-threads (vector-grow current-threads
 					      processor-count #f)))
 	  (else
-	   (if (not (subvector-filled? current-threads 1 len #f))
-	       (outf-error "\n;reset-threads restored MULTIPLE threads!"))
+	   (complain-if (not (subvector-filled? current-threads 1 len #f))
+			"reset-threads restored multiple threads")
 	   unspecific))))
 
 (define (reset-threads-high!)
@@ -496,22 +616,40 @@ USA.
 			 (make-select-registry)))
   (set! io-registrations #f))
 
-(define (wait-for-io)
+(define (wait-for-io id)
+  ;; This procedure never returns.
+  (%%trace ";"id" wait-for-io\n")
+  (assert-locked 'wait-for-io)
+  (complain-if (not (eq? (get-interrupt-enables) interrupt-mask/gc-ok))
+	       "wait-for-io: with interrupts")
+  (complain-if (%current-thread id)
+	       "wait-for-io: not idle")
   (%maybe-toggle-thread-timer #f)
+  (%%trace ";"id" wait-for-io: next timeout = "next-scheduled-timeout"\n")
   (let ((result
 	 (begin
+	   (%%trace ";"id" wait-for-io: blocking for i/o\n")
+	   (%unlock)
 	   (set-interrupt-enables! interrupt-mask/all)
 	   (test-select-registry io-registry #t))))
     (set-interrupt-enables! interrupt-mask/gc-ok)
+    (%lock)
     (signal-select-result result)
+    (complain-if (%current-thread id)
+		 "wait-for-io: ALREADY running a thread")
     (if first-runnable-thread
-	(let ((id (%id)))
-	  (if (not (thread/continuation first-runnable-thread))
-	      (outf-error "\n;wait-for-io: BOGUS runnable"))
+	(begin
+	  (complain-if (not (thread/continuation first-runnable-thread))
+		       "wait-for-io: BOGUS runnable")
+	  (%%trace ";"id" wait-for-io:"
+		   " run-first-thread "first-runnable-thread"\n")
 	  (run-first-thread id))
-	(wait-for-io))))
+	(wait-for-io id))))
 
 (define (signal-select-result result)
+  (%%trace ";"(%%id)" signal-select-result"
+	   " "(if (vector? result) (vector-ref result 0) result)"\n")
+  (assert-locked 'signal-select-result)
   (cond ((vector? result)
 	 (signal-io-thread-events (vector-ref result 0)
 				  (vector-ref result 1)
@@ -522,47 +660,55 @@ USA.
 				  '#(READ)))))
 
 (define (maybe-signal-io-thread-events)
-  (signal-select-result (test-select-registry io-registry #f)))
+  (assert-locked 'maybe-signal-io-thread-events)
+  (%%trace ";"(%%id)" maybe-signal-io-thread-events: testing\n")
+  (let ((result (test-select-registry io-registry #f)))
+    (signal-select-result result)
+    (%%trace ";"(%%id)" maybe-signal-io-thread-events => "
+	     (if (vector? result) (vector-ref result 0) result)"\n")))
 
 (define (block-on-io-descriptor descriptor mode)
-  (without-interrupts
-   (lambda ()
-     (let ((result 'INTERRUPT)
-	   (registration-1)
-	   (registration-2))
-       (dynamic-wind
-	   (lambda ()
-	     (let ((thread (current-thread)))
-	       (set! registration-1
-		     (%register-io-thread-event
-		      descriptor
-		      mode
-		      thread
-		      (lambda (mode)
-			(set! result mode)
-			unspecific)
-		      #f #t))
-	       (set! registration-2
-		     (%register-io-thread-event
-		      'PROCESS-STATUS-CHANGE
-		      'READ
-		      thread
-		      (lambda (mode)
-			mode
-			(set! result 'PROCESS-STATUS-CHANGE)
-			unspecific)
-		      #f #t)))
-	     (%maybe-toggle-thread-timer))
-	   (lambda ()
-	     (%suspend-current-thread)
-	     result)
-	   (lambda ()
-	     (%maybe-deregister-io-thread-event registration-2)
-	     (%maybe-deregister-io-thread-event registration-1)
-	     (%maybe-toggle-thread-timer)))))))
+  (let ((result 'INTERRUPT)
+	(registration-1)
+	(registration-2))
+    (dynamic-wind
+     (lambda ()
+       (with-threads-locked
+	(lambda ()
+	  (let ((thread (%current-thread (%id))))
+	    (set! registration-1
+		  (%register-io-thread-event
+		   descriptor
+		   mode
+		   thread
+		   (lambda (mode)
+		     (set! result mode)
+		     unspecific)
+		   #f #t))
+	    (set! registration-2
+		  (%register-io-thread-event
+		   'PROCESS-STATUS-CHANGE
+		   'READ
+		   thread
+		   (lambda (mode)
+		     mode
+		     (set! result 'PROCESS-STATUS-CHANGE)
+		     unspecific)
+		   #f #t)))
+       (%maybe-toggle-thread-timer))))
+     (lambda ()
+       (%suspend-current-thread)
+       result)
+     (lambda ()
+       (with-threads-locked
+	(lambda ()
+	  (%maybe-deregister-io-thread-event registration-2)
+	  (%maybe-deregister-io-thread-event registration-1)
+	  (%maybe-toggle-thread-timer)))))))
 
 (define (%maybe-deregister-io-thread-event tentry)
   ;; Ensure that another thread does not unwind our registration.
+  (assert-locked '%maybe-deregister-io-thread-event)
   (if (eq? (%current-thread (%id)) (tentry/thread tentry))
       (delete-tentry! tentry)))
 
@@ -578,7 +724,7 @@ USA.
 				    permanent? caller)
   (guarantee-select-mode mode caller)
   (guarantee-thread thread caller)
-  (without-interrupts
+  (with-threads-locked
    (lambda ()
      (let ((registration
 	    (%register-io-thread-event descriptor mode thread event
@@ -590,14 +736,14 @@ USA.
   (if (not (tentry? tentry))
       (error:wrong-type-argument tentry "I/O thread event registration"
 				 'DEREGISTER-IO-THREAD-EVENT))
-  (without-interrupts
+  (with-threads-locked
    (lambda ()
      (%deregister-io-thread-event tentry)
      (%maybe-toggle-thread-timer))))
 
 (define (deregister-io-descriptor-events descriptor mode)
   (guarantee-select-mode mode 'DEREGISTER-IO-DESCRIPTOR-EVENTS)
-  (without-interrupts
+  (with-threads-locked
    (lambda ()
      (let loop ((dentry io-registrations))
        (cond ((not dentry)
@@ -618,6 +764,7 @@ USA.
      (%maybe-toggle-thread-timer))))
 
 (define (%deregister-io-descriptor descriptor)
+  (%lock)
   (let dloop ((dentry io-registrations))
     (cond ((not dentry)
 	   unspecific)
@@ -643,10 +790,12 @@ USA.
 	   (dloop (dentry/next dentry)))
 	  (else
 	   (dloop (dentry/next dentry)))))
-  (%maybe-toggle-thread-timer))
+  (%maybe-toggle-thread-timer)
+  (%unlock))
 
 (define (%register-io-thread-event descriptor mode thread event permanent?
 				   front?)
+  (assert-locked '%register-io-thread-event)
   (let ((tentry (make-tentry thread event permanent?)))
     (let loop ((dentry io-registrations))
       (cond ((not dentry)
@@ -684,10 +833,12 @@ USA.
     tentry))
 
 (define (%deregister-io-thread-event tentry)
+  (assert-locked '%deregister-io-thread-event)
   (if (tentry/dentry tentry)
       (delete-tentry! tentry)))
 
 (define (%deregister-io-thread-events thread permanent?)
+  (assert-locked '%deregister-io-thread-events)
   (let loop ((dentry io-registrations) (tentries '()))
     (if (not dentry)
 	(do ((tentries tentries (cdr tentries)))
@@ -710,6 +861,7 @@ USA.
       (error:wrong-type-argument mode "select mode" procedure)))
 
 (define (signal-io-thread-events n vfd vmode)
+  (assert-locked 'signal-io-thread-events)
   (let ((search
 	 (lambda (descriptor predicate)
 	   (let scan-dentries ((dentry io-registrations))
@@ -749,6 +901,7 @@ USA.
 	    (%signal-thread-event (caar events) (cdar events)))))))
 
 (define (move-tentry-to-back! tentry)
+  (assert-locked 'move-tentry-to-back!)
   (let ((next (tentry/next tentry)))
     (if next
 	(let ((dentry (tentry/dentry tentry))
@@ -760,6 +913,7 @@ USA.
 	  (if (not prev) (set-dentry/first-tentry! dentry next))))))
 
 (define (delete-tentry! tentry)
+  (assert-locked 'delete-tentry!)
   (let ((dentry (tentry/dentry tentry))
 	(prev (tentry/prev tentry))
 	(next (tentry/next tentry)))
@@ -792,7 +946,7 @@ USA.
 ;;;; Events
 
 (define (block-thread-events)
-  (without-interrupts
+  (with-threads-locked
    (lambda ()
      (let ((thread (%current-thread (%id))))
        (if thread
@@ -802,7 +956,7 @@ USA.
 	   #f)))))
 
 (define (unblock-thread-events)
-  (without-interrupts
+  (with-threads-locked
    (lambda ()
      (let ((thread (%current-thread (%id))))
        (handle-thread-events thread)
@@ -829,6 +983,7 @@ USA.
 	      (set-interrupt-enables! interrupt-mask)
 	      value))
 	  (begin
+	    (complain-if #t "with-thread-events-blocked: no current thread")
 	    (set-interrupt-enables! interrupt-mask)
 	    (thunk))))))
 
@@ -838,45 +993,66 @@ USA.
      (let ((thread (%current-thread (%id))))
        (if thread
 	   (thread/block-events? thread)
-	   #f)))))
+	   (begin
+	     (complain-if #t "get-thread-event-block: no current thread")
+	     #f))))))
 
 (define (set-thread-event-block! block?)
   (without-interrupts
    (lambda ()
      (let ((thread (%current-thread (%id))))
        (if thread
-	   (set-thread/block-events?! thread block?)))
+	   (set-thread/block-events?! thread block?)
+	   (complain-if #t "set-thread-event-block!: no current thread")))
      unspecific)))
 
 (define (signal-thread-event thread event)
   (guarantee-thread thread 'SIGNAL-THREAD-EVENT)
   (without-interrupts
    (lambda ()
-     (let ((self (%current-thread (%id))))
+     (let* ((id (%id))
+	    (self (%current-thread id)))
+       (%trace ";"id" signal-thread-event to "thread" from "self"\n")
        (if (eq? thread self)
 	   (let ((block-events? (block-thread-events)))
+	     (%trace ";"id" signal-thread-event to self: await queue\n")
+	     (%lock)
 	     (%add-pending-event thread event)
+	     (%unlock)
+	     (%trace ";"id" signal-thread-event to self: queued\n")
 	     (if (not block-events?)
-		 (unblock-thread-events)))
+		 (begin
+		   (%trace ";"id" signal-thread-event to self: unblock\n")
+		   (unblock-thread-events))))
 	   (begin
 	     (if (eq? 'DEAD (thread/execution-state thread))
 		 (signal-thread-dead thread "signal event to"
 				     signal-thread-event thread event))
+	     (%lock)
+	     (%trace ";"id" signal-thread-event: %signal\n")
 	     (%signal-thread-event thread event)
 	     (if (and (not self) first-runnable-thread)
-		 (run-first-thread (%id))
-		 (%maybe-toggle-thread-timer))))))))
+		 (begin
+		   (%trace ";"id" signal-thread-event"
+			   " running "first-runnable-thread"\n")
+		   (run-first-thread id))
+		 (begin
+		   (%maybe-toggle-thread-timer)
+		   (%trace ";"id" signal-thread-event: done\n")
+		   (%unlock)))))))))
 
 (define (%signal-thread-event thread event)
+  (assert-locked '%signal-thread-event)
   (%add-pending-event thread event)
   (if (and (not (thread/block-events? thread))
 	   (eq? 'WAITING (thread/execution-state thread)))
-      (%thread-running thread)))
+      (%thread-running (%id) thread)))
 
 (define (%add-pending-event thread event)
   ;; PENDING-EVENTS has three states: (1) empty; (2) one #F event; or
   ;; (3) any number of non-#F events.  This optimizes #F events away
   ;; when they aren't needed.
+  (assert-locked '%add-pending-event)
   (let ((ring (thread/pending-events thread)))
     (let ((count (ring/count-max-2 ring)))
       (if event
@@ -888,6 +1064,8 @@ USA.
 	      (ring/enqueue ring event))))))
 
 (define (handle-thread-events thread)
+  (%%trace ";"(%%id)" handle-thread-events for "thread"\n")
+  (assert-locked 'handle-thread-events)
   (let loop ((any-events? #f))
     (let ((event (ring/dequeue (thread/pending-events thread) #t)))
       (if (eq? #t event)
@@ -896,13 +1074,15 @@ USA.
 	    (if event
 		(let ((block? (thread/block-events? thread)))
 		  (set-thread/block-events?! thread #t)
+		  (%unlock)
 		  (event)
 		  (set-interrupt-enables! interrupt-mask/gc-ok)
+		  (%lock)
 		  (set-thread/block-events?! thread block?)))
 	    (loop #t))))))
 
 (define (allow-thread-event-delivery)
-  (without-interrupts
+  (with-threads-locked
    (lambda ()
      (let ((thread (%current-thread (%id))))
        (if thread
@@ -913,6 +1093,7 @@ USA.
 	     (handle-thread-events thread)
 	     (set-thread/block-events?! thread block-events?))
 	   (begin
+	     (complain-if #t "allow-thread-event-delivery: no current thread")
 	     (deliver-timer-events)
 	     (maybe-signal-io-thread-events))))
      (%maybe-toggle-thread-timer))))
@@ -932,7 +1113,7 @@ USA.
 (define (register-timer-event interval event)
   (let ((time (+ (real-time-clock) interval)))
     (let ((new-record (make-timer-record time (current-thread) event #f)))
-      (without-interrupts
+      (with-threads-locked
        (lambda ()
 	 (let loop ((record timer-records) (prev #f))
 	   (if (or (not record) (< time (timer-record/time record)))
@@ -956,7 +1137,9 @@ USA.
 	  (unblock-thread-events)))))
 
 (define (deliver-timer-events)
+  (assert-locked 'deliver-timer-events)
   (let ((time (real-time-clock)))
+    (%%trace ";"(%%id)" deliver-timer-events: time = "time"\n")
     (do ((record timer-records (timer-record/next record)))
 	((or (not record) (< time (timer-record/time record)))
 	 (set! timer-records record)
@@ -971,7 +1154,7 @@ USA.
   (if (not (timer-record? registration))
       (error:wrong-type-argument registration "timer event registration"
 				 'DEREGISTER-TIMER-EVENT))
-  (without-interrupts
+  (with-threads-locked
    (lambda ()
      (let loop ((record timer-records) (prev #f))
        (if record
@@ -983,22 +1166,20 @@ USA.
 		 (loop next record)))))
      (%maybe-toggle-thread-timer))))
 
-(define-integrable (threads-pending-timer-events?)
-  timer-records)
-
 (define (deregister-all-events)
-  (let ((thread (current-thread)))
-    (set-interrupt-enables! interrupt-mask/gc-ok)
-    (let ((block-events? (thread/block-events? thread)))
+  (with-threads-locked
+   (lambda ()
+     (let* ((thread (%current-thread (%id)))
+	    (block-events? (thread/block-events? thread)))
       (set-thread/block-events?! thread #t)
       (ring/discard-all (thread/pending-events thread))
       (%deregister-io-thread-events thread #f)
       (%discard-thread-timer-records thread)
       (set-thread/block-events?! thread block-events?))
-    (%maybe-toggle-thread-timer)
-    (set-interrupt-enables! interrupt-mask/all)))
+     (%maybe-toggle-thread-timer))))
 
 (define (%discard-thread-timer-records thread)
+  (assert-locked '%discard-thread-timer-records)
   (let loop ((record timer-records) (prev #f))
     (if record
 	(let ((next (timer-record/next record)))
@@ -1016,25 +1197,29 @@ USA.
 (define (set-thread-timer-interval! interval)
   (if interval
       (guarantee-exact-positive-integer interval 'SET-THREAD-TIMER-INTERVAL!))
-  (without-interrupts
+  (with-threads-locked
    (lambda ()
      (set! timer-interval interval)
      (%maybe-toggle-thread-timer))))
 
 (define (start-thread-timer)
-  (without-interrupts %maybe-toggle-thread-timer))
+  (with-threads-locked %maybe-toggle-thread-timer))
 
 (define (stop-thread-timer)
-  (without-interrupts %stop-thread-timer))
+  (with-threads-locked %stop-thread-timer))
 
 (define (with-thread-timer-stopped thunk)
-  (dynamic-wind %stop-thread-timer thunk %maybe-toggle-thread-timer))
+  (dynamic-wind stop-thread-timer thunk start-thread-timer))
 
 (define (%maybe-toggle-thread-timer #!optional consider-non-timers?)
+  (assert-locked '%maybe-toggle-thread-timer)
   (let ((now (real-time-clock)))
+    (%%trace ";"(%%id)" %maybe-toggle-thread-timer "consider-non-timers?
+	     " time = "now"\n")
     (let ((start
 	   (lambda (time)
 	     (set! next-scheduled-timeout time)
+	     (%%trace ";"(%%id)" thread-timer: set to "(- time now)"\n")
 	     ((ucode-primitive real-timer-set) (- time now) 0))))
       (cond (timer-records
 	     (let ((next-event-time (timer-record/time timer-records)))
@@ -1043,8 +1228,10 @@ USA.
 		   ;; Instead signal the interrupt now.  This is ugly
 		   ;; but much simpler than refactoring the scheduler
 		   ;; so that we can do the right thing here.
-		   ((ucode-primitive request-interrupts! 1)
-		    interrupt-bit/timer)
+		   (begin
+		     (%%trace ";"(%%id)" thread-timer: requested\n")
+		     ((ucode-primitive request-interrupts! 1)
+		      interrupt-bit/timer))
 		   (start
 		    (if (and consider-non-timers? timer-interval)
 			(min next-event-time (+ now timer-interval))
@@ -1054,9 +1241,11 @@ USA.
 		  (or io-registrations first-runnable-thread))
 	     (start (+ now timer-interval)))
 	    (else
+	     (%%trace ";"(%%id)" thread-timer: stopped\n")
 	     (%stop-thread-timer))))))
 
 (define (%stop-thread-timer)
+  (assert-locked '%stop-thread-timer)
   (if next-scheduled-timeout
       (begin
 	((ucode-primitive real-timer-clear))
@@ -1094,9 +1283,9 @@ USA.
 
 (define (lock-thread-mutex mutex)
   (guarantee-thread-mutex mutex 'LOCK-THREAD-MUTEX)
-  (without-interrupts
+  (with-threads-locked
    (lambda ()
-     (let ((thread (current-thread))
+     (let ((thread (%current-thread (%id)))
 	   (owner (thread-mutex/owner mutex)))
        (if (eq? owner thread)
 	   (signal-thread-deadlock thread "lock thread mutex"
@@ -1104,29 +1293,36 @@ USA.
        (%lock-thread-mutex mutex thread owner)))))
 
 (define (%lock-thread-mutex mutex thread owner)
+  (assert-locked '%lock-thread-mutex)
   (add-thread-mutex! thread mutex)
   (if owner
       (begin
 	(ring/enqueue (thread-mutex/waiting-threads mutex) thread)
 	(do () ((eq? thread (thread-mutex/owner mutex)))
-	  (%suspend-thread thread)))
+	  (%suspend-thread thread)
+	  (%lock)))
       (set-thread-mutex/owner! mutex thread)))
 
 (define (unlock-thread-mutex mutex)
   (guarantee-thread-mutex mutex 'UNLOCK-THREAD-MUTEX)
-  (without-interrupts
-   (lambda ()
-     (let ((owner (thread-mutex/owner mutex)))
-       (if (and owner (not (eq? owner (current-thread))))
-	   (error "Don't own mutex:" mutex))
-       (%unlock-thread-mutex mutex owner)))))
+  (if (with-threads-locked
+       (lambda ()
+	 (let ((owner (thread-mutex/owner mutex)))
+	   (if (and owner (not (eq? owner (%current-thread (%id)))))
+	       #t
+	       (begin
+		 (%unlock-thread-mutex mutex owner)
+		 #f)))))
+      (error "Don't own mutex:" mutex)))
 
 (define (%unlock-thread-mutex mutex owner)
+  (assert-locked '%unlock-thread-mutex)
   (remove-thread-mutex! owner mutex)
   (if (%%unlock-thread-mutex mutex)
       (%maybe-toggle-thread-timer)))
 
 (define (%%unlock-thread-mutex mutex)
+  (assert-locked '%%unlock-thread-mutex)
   (let ((thread (ring/dequeue (thread-mutex/waiting-threads mutex) #f)))
     (set-thread-mutex/owner! mutex thread)
     (if thread (%signal-thread-event thread #f))
@@ -1134,7 +1330,7 @@ USA.
 
 (define (try-lock-thread-mutex mutex)
   (guarantee-thread-mutex mutex 'TRY-LOCK-THREAD-MUTEX)
-  (without-interrupts
+  (with-threads-locked
    (lambda ()
      (and (not (thread-mutex/owner mutex))
 	  (let ((thread (%current-thread (%id))))
@@ -1155,6 +1351,7 @@ USA.
 		(lambda () (lock-thread-mutex mutex))))
 
 (define (%disassociate-thread-mutexes thread)
+  (assert-locked '%disassociate-thread-mutexes)
   (do ((mutexes (thread/mutexes thread) (cdr mutexes)))
       ((not (pair? mutexes)))
     (let ((mutex (car mutexes)))
@@ -1164,9 +1361,11 @@ USA.
   (set-thread/mutexes! thread '()))
 
 (define-integrable (add-thread-mutex! thread mutex)
+  (assert-locked 'add-thread-mutex!)
   (set-thread/mutexes! thread (cons mutex (thread/mutexes thread))))
 
 (define-integrable (remove-thread-mutex! thread mutex)
+  (assert-locked 'remove-thread-mutex!)
   (set-thread/mutexes! thread (delq! mutex (thread/mutexes thread))))
 
 ;;;; Circular Rings
@@ -1186,12 +1385,14 @@ USA.
   (eq? (link/next ring) ring))
 
 (define (ring/enqueue ring item)
+  (assert-locked 'ring/enqueue)
   (let ((prev (link/prev ring)))
     (let ((link (make-link prev ring item)))
       (set-link/next! prev link)
       (set-link/prev! ring link))))
 
 (define (ring/dequeue ring default)
+  (assert-locked 'ring/dequeue)
   (let ((link (link/next ring)))
     (if (eq? link ring)
 	default
@@ -1202,10 +1403,12 @@ USA.
 	  (link/item link)))))
 
 (define (ring/discard-all ring)
+  (assert-locked 'ring/discard-all)
   (set-link/prev! ring ring)
   (set-link/next! ring ring))
 
 (define (ring/remove-item ring item)
+  (assert-locked 'ring/remove-item)
   (let loop ((link (link/next ring)))
     (if (not (eq? link ring))
 	(if (eq? (link/item link) item)
@@ -1216,15 +1419,18 @@ USA.
 	    (loop (link/next link))))))
 
 (define (ring/count-max-2 ring)
+  (assert-locked 'ring/count-max-2)
   (let ((link (link/next ring)))
     (cond ((eq? link ring) 0)
 	  ((eq? (link/next link) ring) 1)
 	  (else 2))))
 
 (define (ring/first-item ring)
+  (assert-locked 'ring/first-item)
   (link/item (link/next ring)))
 
 (define (ring/set-first-item! ring item)
+  (assert-locked 'ring/set-first-item!)
   (set-link/item! (link/next ring) item))
 
 ;;;; Error Conditions
@@ -1312,5 +1518,97 @@ USA.
 	    '()
 	  (lambda (condition port)
 	    condition
-	    (write-string "No current thread!" port))))
+	    (write-string "No current thread." port))))
   unspecific)
+
+(define-integrable (%%id)
+  (if enable-smp?
+      ((ucode-primitive smp-id 0))
+      0))
+
+#;(define-syntax assert-locked
+  (syntax-rules ()
+    ((_ NAME)
+     #f)))
+
+(define-syntax assert-locked
+  (syntax-rules ()
+    ((_ NAME)
+     (begin
+       (if (not locked?)
+	   (%outf-error ";"(%%id)" Warning: "NAME" not locked\n"))
+       (if (not (only-gc-ok?))
+	   (%outf-error ";"(%%id)" Warning: "NAME" can be interrupted\n"))))))
+
+#;(define-syntax complain-if
+  (syntax-rules ()
+    ((_ FORM MSG)
+     #f)))
+
+(define-syntax complain-if
+  (syntax-rules ()
+    ((_ FORM MSG)
+     (if FORM (%outf-error* (list ";"(%%id)" "MSG"\n"))))))
+
+#;(define-syntax %trace
+  (syntax-rules ()
+    ((_ . MSG)
+     #f)))
+
+(define %trace? #f)
+
+(define-syntax %trace
+  (syntax-rules ()
+    ((_ . MSG)
+     (if %trace?
+	 (outf-error* (list . MSG))))))
+
+(define (outf-error* objects)
+  (if (not (current-thread))
+      (begin
+	(%outf-error ";"(%%id)" WARNING: no current thread for %trace\n")
+	(%outf-error* objects))
+      (apply outf-error objects)))
+
+#;(define-syntax %if-tracing
+  (syntax-rules ()
+    ((_ . BODY)
+     #f)))
+
+(define-syntax %if-tracing
+  (syntax-rules ()
+    ((_ . BODY)
+     (if %trace?
+	 (begin . BODY)))))
+
+#;(define-syntax %%trace
+  (syntax-rules ()
+    ((_ . MSG)
+     #f)))
+
+(define-syntax %%trace
+  (syntax-rules ()
+    ((_ . MSG)
+     (if %trace? (%outf-error* (list . MSG))))))
+
+(define (%outf-error . objects)
+  ;; A version of outf-error that works when current-thread is #f.
+  (%outf-error* objects))
+
+(define (%outf-error* objects)
+  ((ucode-primitive outf-error 1)
+   (apply string-append (map %->string objects))))
+
+(define (%->string object)
+  (cond ((string? object) object)
+	((symbol? object) (symbol-name object))
+	((number? object) (number->string object))
+	((eq? object #f) "#f")
+	((eq? object #!default) "#!default")
+	((thread? object)
+	 (string-append "#[thread "(number->string (hash object))"]"))
+	(else
+	 (string-append "#["(symbol-name
+			     (microcode-type/code->name
+			      ((ucode-primitive object-type 1) object)))
+			" "(number->string (hash object))"]"))))
\ No newline at end of file