1.0.26.4: less pessimal waitqueues
[sbcl.git] / src / code / target-thread.lisp
index c534ca0..736c27e 100644 (file)
@@ -43,14 +43,16 @@ in future versions."
     (let* ((cookie (list thread))
            (info (if (thread-alive-p thread)
                      :running
-                     (multiple-value-list (join-thread thread :default cookie))))
+                     (multiple-value-list
+                      (join-thread thread :default cookie))))
            (state (if (eq :running info)
                       info
                       (if (eq cookie (car info))
                           :aborted
                           :finished)))
            (values (when (eq :finished state) info)))
-      (format stream "~@[~S ~]~:[~A~;~A~:[ no values~; values: ~:*~{~S~^, ~}~]~]"
+      (format stream
+              "~@[~S ~]~:[~A~;~A~:[ no values~; values: ~:*~{~S~^, ~}~]~]"
               (thread-name thread)
               (eq :finished state)
               state
@@ -85,8 +87,10 @@ in future versions."
 
 (declaim (inline current-thread-os-thread))
 (defun current-thread-os-thread ()
-  (sap-int
-   (sb!vm::current-thread-offset-sap sb!vm::thread-os-thread-slot)))
+  #!+sb-thread
+  (sap-int (sb!vm::current-thread-offset-sap sb!vm::thread-os-thread-slot))
+  #!-sb-thread
+  0)
 
 (defun init-initial-thread ()
   (/show0 "Entering INIT-INITIAL-THREAD")
@@ -98,8 +102,14 @@ in future versions."
     ;; in case we are in reinit since saving core with multiple
     ;; threads doesn't work.
     (setq *all-threads* (list initial-thread))))
+\f
 
-;;;;
+;;;; Aliens, low level stuff
+
+(define-alien-routine "kill_safely"
+    integer
+  (os-thread #!-alpha unsigned-long #!+alpha unsigned-int)
+  (signal int))
 
 #!+sb-thread
 (progn
@@ -110,9 +120,6 @@ in future versions."
   (define-alien-routine ("create_thread" %create-thread)
       unsigned-long (lisp-fun-address unsigned-long))
 
-  (define-alien-routine "signal_interrupt_thread"
-      integer (os-thread unsigned-long))
-
   (define-alien-routine "block_deferrable_signals"
       void)
 
@@ -191,10 +198,13 @@ in future versions."
 (defun sb!vm::current-thread-offset-sap (n)
   (declare (type (unsigned-byte 27) n))
   (sb!vm::current-thread-offset-sap n))
+\f
+
+;;;; Spinlocks
 
 (declaim (inline get-spinlock release-spinlock))
 
-;; Should always be called with interrupts disabled.
+;;; Should always be called with interrupts disabled.
 (defun get-spinlock (spinlock)
   (declare (optimize (speed 3) (safety 0)))
   (let* ((new *current-thread*)
@@ -208,20 +218,36 @@ in future versions."
                    (thread-yield)
                    (return-from get-spinlock t))))
         (if (and (not *interrupts-enabled*) *allow-with-interrupts*)
-            ;; If interrupts are enabled, but we are allowed to enabled them,
-            ;; check for pending interrupts every once in a while.
-            (loop
-              (loop repeat 128 do (cas)) ; 128 is arbitrary here
-              (sb!unix::%check-interrupts))
+            ;; If interrupts are disabled, but we are allowed to
+            ;; enabled them, check for pending interrupts every once
+            ;; in a while. %CHECK-INTERRUPTS is taking shortcuts, make
+            ;; sure that deferrables are unblocked by doing an empty
+            ;; WITH-INTERRUPTS once.
+            (progn
+              (with-interrupts)
+              (loop
+               (loop repeat 128 do (cas)) ; 128 is arbitrary here
+               (sb!unix::%check-interrupts)))
             (loop (cas)))))
     t))
 
 (defun release-spinlock (spinlock)
   (declare (optimize (speed 3) (safety 0)))
-  (setf (spinlock-value spinlock) nil)
-  nil)
+  ;; On x86 and x86-64 we can get away with no memory barriers, (see
+  ;; Linux kernel mailing list "spin_unlock optimization(i386)"
+  ;; thread, summary at
+  ;; http://kt.iserv.nl/kernel-traffic/kt19991220_47.html#1.
+  ;;
+  ;; If the compiler may reorder this with other instructions, insert
+  ;; compiler barrier here.
+  ;;
+  ;; FIXME: this does not work on SMP Pentium Pro and OOSTORE systems,
+  ;; neither on most non-x86 architectures (but we don't have threads
+  ;; on those).
+  (setf (spinlock-value spinlock) nil))
+\f
 
-;;;; mutexes
+;;;; Mutexes
 
 #!+sb-doc
 (setf (fdocumentation 'make-mutex 'function)
@@ -240,6 +266,15 @@ in future versions."
   (defconstant +lock-taken+ 1)
   (defconstant +lock-contested+ 2))
 
+(defun mutex-owner (mutex)
+  "Current owner of the mutex, NIL if the mutex is free. Naturally,
+this is racy by design (another thread may acquire the mutex after
+this function returns), it is intended for informative purposes. For
+testing whether the current thread is holding a mutex see
+HOLDING-MUTEX-P."
+  ;; Make sure to get the current value.
+  (sb!ext:compare-and-swap (mutex-%owner mutex) nil nil))
+
 (defun get-mutex (mutex &optional (new-owner *current-thread*) (waitp t))
   #!+sb-doc
   "Acquire MUTEX for NEW-OWNER, which must be a thread or NIL. If
@@ -266,8 +301,14 @@ directly."
            #!-sb-thread (ignore waitp))
   (unless new-owner
     (setq new-owner *current-thread*))
-  (when (eql new-owner (mutex-%owner mutex))
-    (error "Recursive lock attempt ~S." mutex))
+  (let ((old (mutex-%owner mutex)))
+    (when (eq new-owner old)
+      (error "Recursive lock attempt ~S." mutex))
+    #!-sb-thread
+    (when old
+      (error "Strange deadlock on ~S in an unithreaded build?" mutex)))
+  #!-sb-thread
+  (setf (mutex-%owner mutex) new-owner)
   #!+sb-thread
   (progn
     ;; FIXME: Lutexes do not currently support deadlines, as at least
@@ -287,6 +328,8 @@ directly."
       (setf (mutex-%owner mutex) new-owner)
       t)
     #!-sb-lutex
+    ;; This is a direct translation of the Mutex 2 algorithm from
+    ;; "Futexes are Tricky" by Ulrich Drepper.
     (let ((old (sb!ext:compare-and-swap (mutex-state mutex)
                                         +lock-free+
                                         +lock-taken+)))
@@ -299,13 +342,16 @@ directly."
                                                         +lock-taken+
                                                         +lock-contested+))))
              ;; Wait on the contested lock.
-             (multiple-value-bind (to-sec to-usec) (decode-timeout nil)
-               (when (= 1 (with-pinned-objects (mutex)
-                            (futex-wait (mutex-state-address mutex)
-                                        (get-lisp-obj-address +lock-contested+)
-                                        (or to-sec -1)
-                                        (or to-usec 0))))
-                 (signal-deadline))))
+             (loop
+              (multiple-value-bind (to-sec to-usec) (decode-timeout nil)
+                (case (with-pinned-objects (mutex)
+                        (futex-wait (mutex-state-address mutex)
+                                    (get-lisp-obj-address +lock-contested+)
+                                    (or to-sec -1)
+                                    (or to-usec 0)))
+                  ((1) (signal-deadline))
+                  ((2))
+                  (otherwise (return))))))
            (setf old (sb!ext:compare-and-swap (mutex-state mutex)
                                               +lock-free+
                                               +lock-contested+))
@@ -329,7 +375,7 @@ this mutex.
 RELEASE-MUTEX is not interrupt safe: interrupts should be disabled
 around calls to it.
 
-Signals a WARNING is current thread is not the current owner of the
+Signals a WARNING if current thread is not the current owner of the
 mutex."
   (declare (type mutex mutex))
   ;; Order matters: set owner to NIL before releasing state.
@@ -344,6 +390,14 @@ mutex."
     (with-lutex-address (lutex (mutex-lutex mutex))
       (%lutex-unlock lutex))
     #!-sb-lutex
+    ;; FIXME: once ATOMIC-INCF supports struct slots with word sized
+    ;; unsigned-byte type this can be used:
+    ;;
+    ;;     (let ((old (sb!ext:atomic-incf (mutex-state mutex) -1)))
+    ;;       (unless (eql old +lock-free+)
+    ;;         (setf (mutex-state mutex) +lock-free+)
+    ;;         (with-pinned-objects (mutex)
+    ;;           (futex-wake (mutex-state-address mutex) 1))))
     (let ((old (sb!ext:compare-and-swap (mutex-state mutex)
                                         +lock-taken+ +lock-free+)))
       (when (eql old +lock-contested+)
@@ -352,8 +406,9 @@ mutex."
         (with-pinned-objects (mutex)
           (futex-wake (mutex-state-address mutex) 1))))
     nil))
+\f
 
-;;;; waitqueues/condition variables
+;;;; Waitqueues/condition variables
 
 (defstruct (waitqueue (:constructor %make-waitqueue))
   #!+sb-doc
@@ -391,8 +446,9 @@ time we reacquire MUTEX and return to the caller."
     (assert (eq me (mutex-%owner mutex)))
     (/show0 "CONDITION-WAITing")
     #!+sb-lutex
-    ;; Need to disable interrupts so that we don't miss setting the owner on
-    ;; our way out. (pthread_cond_wait handles the actual re-acquisition.)
+    ;; Need to disable interrupts so that we don't miss setting the
+    ;; owner on our way out. (pthread_cond_wait handles the actual
+    ;; re-acquisition.)
     (without-interrupts
       (unwind-protect
            (progn
@@ -403,38 +459,48 @@ time we reacquire MUTEX and return to the caller."
                    (%lutex-wait queue-lutex-address mutex-lutex-address)))))
         (setf (mutex-%owner mutex) me)))
     #!-sb-lutex
-    ;; Need to disable interrupts so that we don't miss grabbing the mutex
-    ;; on our way out.
+    ;; Need to disable interrupts so that we don't miss grabbing the
+    ;; mutex on our way out.
     (without-interrupts
       (unwind-protect
-           (let ((me *current-thread*))
-             ;; FIXME: should we do something to ensure that the result
-             ;; of this setf is visible to all CPUs?
+           (let ((me nil))
+             ;; This setf becomes visible to other CPUS due to the
+             ;; usual memory barrier semantics of lock
+             ;; acquire/release.
              (setf (waitqueue-data queue) me)
              (release-mutex mutex)
-             ;; Now we go to sleep using futex-wait.  If anyone else
+             ;; Now we go to sleep using futex-wait. If anyone else
              ;; manages to grab MUTEX and call CONDITION-NOTIFY during
              ;; this comment, it will change queue->data, and so
              ;; futex-wait returns immediately instead of sleeping.
-             ;; Ergo, no lost wakeup. We may get spurious wakeups,
-             ;; but that's ok.
-             (multiple-value-bind (to-sec to-usec) (decode-timeout nil)
-               (when (= 1 (with-pinned-objects (queue me)
-                            (allow-with-interrupts
-                              (futex-wait (waitqueue-data-address queue)
-                                          (get-lisp-obj-address me)
-                                          (or to-sec -1) ;; our way if saying "no timeout"
-                                          (or to-usec 0)))))
-                 (signal-deadline))))
-        ;; If we are interrupted while waiting, we should do these things
-        ;; before returning.  Ideally, in the case of an unhandled signal,
-        ;; we should do them before entering the debugger, but this is
-        ;; better than nothing.
+             ;; Ergo, no lost wakeup. We may get spurious wakeups, but
+             ;; that's ok.
+             (loop
+              (multiple-value-bind (to-sec to-usec) (decode-timeout nil)
+                (case (with-pinned-objects (queue me)
+                        (allow-with-interrupts
+                          (futex-wait (waitqueue-data-address queue)
+                                      (get-lisp-obj-address me)
+                                      ;; our way if saying "no
+                                      ;; timeout":
+                                      (or to-sec -1)
+                                      (or to-usec 0))))
+                  ((1) (signal-deadline))
+                  ((2))
+                  ;; EWOULDBLOCK, -1 here, is the possible spurious
+                  ;; wakeup case. 0 is the normal wakeup.
+                  (otherwise (return))))))
+        ;; If we are interrupted while waiting, we should do these
+        ;; things before returning. Ideally, in the case of an
+        ;; unhandled signal, we should do them before entering the
+        ;; debugger, but this is better than nothing.
         (get-mutex mutex)))))
 
 (defun condition-notify (queue &optional (n 1))
   #!+sb-doc
-  "Notify N threads waiting on QUEUE."
+  "Notify N threads waiting on QUEUE. The same mutex that is used in
+the corresponding CONDITION-WAIT must be held by this thread during
+this call."
   #!-sb-thread (declare (ignore queue n))
   #!-sb-thread (error "Not supported in unithread builds.")
   #!+sb-thread
@@ -461,12 +527,13 @@ time we reacquire MUTEX and return to the caller."
   #!+sb-doc
   "Notify all threads waiting on QUEUE."
   (condition-notify queue
-                    ;; On a 64-bit platform truncating M-P-F to an int results
-                    ;; in -1, which wakes up only one thread.
+                    ;; On a 64-bit platform truncating M-P-F to an int
+                    ;; results in -1, which wakes up only one thread.
                     (ldb (byte 29 0)
                          most-positive-fixnum)))
+\f
 
-;;;; semaphores
+;;;; Semaphores
 
 (defstruct (semaphore (:constructor %make-semaphore (name %count)))
   #!+sb-doc
@@ -499,9 +566,9 @@ negative. Else blocks until the semaphore can be decremented."
   ;; A more direct implementation based directly on futexes should be
   ;; possible.
   ;;
-  ;; We need to disable interrupts so that we don't forget to decrement the
-  ;; waitcount (which would happen if an asynch interrupt should catch us on
-  ;; our way out from the loop.)
+  ;; We need to disable interrupts so that we don't forget to
+  ;; decrement the waitcount (which would happen if an asynch
+  ;; interrupt should catch us on our way out from the loop.)
   (with-system-mutex ((semaphore-mutex semaphore) :allow-with-interrupts t)
     ;; Quick check: is it positive? If not, enter the wait loop.
     (let ((count (semaphore-%count semaphore)))
@@ -511,7 +578,8 @@ negative. Else blocks until the semaphore can be decremented."
                (progn
                  (incf (semaphore-waitcount semaphore))
                  (loop until (plusp (setf count (semaphore-%count semaphore)))
-                       do (condition-wait (semaphore-queue semaphore) (semaphore-mutex semaphore)))
+                       do (condition-wait (semaphore-queue semaphore)
+                                          (semaphore-mutex semaphore)))
                  (setf (semaphore-%count semaphore) (1- count)))
             (decf (semaphore-waitcount semaphore)))))))
 
@@ -520,15 +588,16 @@ negative. Else blocks until the semaphore can be decremented."
   "Increment the count of SEMAPHORE by N. If there are threads waiting
 on this semaphore, then N of them is woken up."
   (declare (type (integer 1) n))
-  ;; Need to disable interrupts so that we don't lose a wakeup after we have
-  ;; incremented the count.
+  ;; Need to disable interrupts so that we don't lose a wakeup after
+  ;; we have incremented the count.
   (with-system-mutex ((semaphore-mutex semaphore))
     (let ((waitcount (semaphore-waitcount semaphore))
           (count (incf (semaphore-%count semaphore) n)))
       (when (plusp waitcount)
         (condition-notify (semaphore-queue semaphore) (min waitcount count))))))
+\f
 
-;;;; job control, independent listeners
+;;;; Job control, independent listeners
 
 (defstruct session
   (lock (make-mutex :name "session lock"))
@@ -541,15 +610,15 @@ on this semaphore, then N of them is woken up."
 ;;; The debugger itself tries to acquire the session lock, don't let
 ;;; funny situations (like getting a sigint while holding the session
 ;;; lock) occur. At the same time we need to allow interrupts while
-;;; *waiting* for the session lock for things like GET-FOREGROUND
-;;; to be interruptible.
+;;; *waiting* for the session lock for things like GET-FOREGROUND to
+;;; be interruptible.
 ;;;
-;;; Take care: we sometimes need to obtain the session lock while holding
-;;; on to *ALL-THREADS-LOCK*, so we must _never_ obtain it _after_ getting
-;;; a session lock! (Deadlock risk.)
+;;; Take care: we sometimes need to obtain the session lock while
+;;; holding on to *ALL-THREADS-LOCK*, so we must _never_ obtain it
+;;; _after_ getting a session lock! (Deadlock risk.)
 ;;;
-;;; FIXME: It would be good to have ordered locks to ensure invariants like
-;;; the above.
+;;; FIXME: It would be good to have ordered locks to ensure invariants
+;;; like the above.
 (defmacro with-session-lock ((session) &body body)
   `(with-system-mutex ((session-lock ,session) :allow-with-interrupts t)
      ,@body))
@@ -585,9 +654,6 @@ on this semaphore, then N of them is woken up."
 #!+sb-thread
 (defun handle-thread-exit (thread)
   (/show0 "HANDLING THREAD EXIT")
-  ;; We're going down, can't handle interrupts sanely anymore.
-  ;; GC remains enabled.
-  (block-deferrable-signals)
   ;; Lisp-side cleanup
   (with-all-threads-lock
     (setf (thread-%alive-p thread) nil)
@@ -699,8 +765,9 @@ have the foreground next."
                         (sb!impl::toplevel-repl nil)
                      (sb!int:flush-standard-output-streams))))))
       (make-thread #'thread-repl))))
+\f
 
-;;;; the beef
+;;;; The beef
 
 (defun make-thread (function &key name)
   #!+sb-doc
@@ -727,6 +794,9 @@ around and can be retrieved by JOIN-THREAD."
             ;; of Allegro's *cl-default-special-bindings*, as that is at
             ;; least accessible to users to secure their own libraries.
             ;;   --njf, 2006-07-15
+            ;;
+            ;; As it is, this lambda must not cons until we are ready
+            ;; to run GC. Be very careful.
             (let* ((*current-thread* thread)
                    (*restart-clusters* nil)
                    (*handler-clusters* (sb!kernel::initial-handler-clusters))
@@ -761,28 +831,50 @@ around and can be retrieved by JOIN-THREAD."
                          (format nil
                                  "~~@<Terminate this thread (~A)~~@:>"
                                  *current-thread*))
-                      (unwind-protect
-                           (progn
-                             ;; now that most things have a chance to
-                             ;; work properly without messing up other
-                             ;; threads, it's time to enable signals
-                             (sb!unix::reset-signal-mask)
-                             (setf (thread-result thread)
-                                   (cons t
-                                         (multiple-value-list
-                                          (funcall real-function)))))
-                        (handle-thread-exit thread)))))))
+                      (without-interrupts
+                        (unwind-protect
+                             (with-local-interrupts
+                               ;; Now that most things have a chance
+                               ;; to work properly without messing up
+                               ;; other threads, it's time to enable
+                               ;; signals.
+                               (sb!unix::unblock-deferrable-signals)
+                               (setf (thread-result thread)
+                                     (cons t
+                                           (multiple-value-list
+                                            (funcall real-function))))
+                               ;; Try to block deferrables. An
+                               ;; interrupt may unwind it, but for a
+                               ;; normal exit it prevents interrupt
+                               ;; loss.
+                               (block-deferrable-signals))
+                          ;; We're going down, can't handle interrupts
+                          ;; sanely anymore. GC remains enabled.
+                          (block-deferrable-signals)
+                          ;; We don't want to run interrupts in a dead
+                          ;; thread when we leave WITHOUT-INTERRUPTS.
+                          ;; This potentially causes important
+                          ;; interupts to be lost: SIGINT comes to
+                          ;; mind.
+                          (setq *interrupt-pending* nil)
+                          (handle-thread-exit thread))))))))
             (values))))
+    ;; If the starting thread is stopped for gc before it signals the
+    ;; semaphore then we'd be stuck.
+    (assert (not *gc-inhibit*))
     ;; Keep INITIAL-FUNCTION pinned until the child thread is
-    ;; initialized properly.
-    (with-pinned-objects (initial-function)
-      (let ((os-thread
-             (%create-thread
-              (get-lisp-obj-address initial-function))))
-        (when (zerop os-thread)
-          (error "Can't create a new thread"))
-        (wait-on-semaphore setup-sem)
-        thread))))
+    ;; initialized properly. Wrap the whole thing in
+    ;; WITHOUT-INTERRUPTS because we pass INITIAL-FUNCTION to another
+    ;; thread.
+    (without-interrupts
+      (with-pinned-objects (initial-function)
+        (let ((os-thread
+               (%create-thread
+                (get-lisp-obj-address initial-function))))
+          (when (zerop os-thread)
+            (error "Can't create a new thread"))
+          (wait-on-semaphore setup-sem)
+          thread)))))
 
 (define-condition join-thread-error (error)
   ((thread :reader join-thread-error-thread :initarg :thread))
@@ -802,13 +894,13 @@ around and can be retrieved by JOIN-THREAD."
   "Suspend current thread until THREAD exits. Returns the result
 values of the thread function. If the thread does not exit normally,
 return DEFAULT if given or else signal JOIN-THREAD-ERROR."
-  (with-mutex ((thread-result-lock thread))
+  (with-system-mutex ((thread-result-lock thread) :allow-with-interrupts t)
     (cond ((car (thread-result thread))
-           (values-list (cdr (thread-result thread))))
+           (return-from join-thread
+             (values-list (cdr (thread-result thread)))))
           (defaultp
-           default)
-          (t
-           (error 'join-thread-error :thread thread)))))
+           (return-from join-thread default))))
+  (error 'join-thread-error :thread thread))
 
 (defun destroy-thread (thread)
   #!+sb-doc
@@ -831,47 +923,54 @@ return DEFAULT if given or else signal JOIN-THREAD-ERROR."
   `(with-system-mutex ((thread-interruptions-lock ,thread))
      ,@body))
 
-;; Called from the signal handler in C.
+;;; Called from the signal handler.
+#!-win32
 (defun run-interruption ()
-  (in-interruption ()
-    (loop
-       (let ((interruption (with-interruptions-lock (*current-thread*)
-                             (pop (thread-interruptions *current-thread*)))))
-         (if interruption
-             (with-interrupts
-               (funcall interruption))
-             (return))))))
-
-;; The order of interrupt execution is peculiar. If thread A
-;; interrupts thread B with I1, I2 and B for some reason receives I1
-;; when FUN2 is already on the list, then it is FUN2 that gets to run
-;; first. But when FUN2 is run SIG_INTERRUPT_THREAD is enabled again
-;; and I2 hits pretty soon in FUN2 and run FUN1. This is of course
-;; just one scenario, and the order of thread interrupt execution is
-;; undefined.
+  (let ((interruption (with-interruptions-lock (*current-thread*)
+                        (pop (thread-interruptions *current-thread*)))))
+    ;; If there is more to do, then resignal and let the normal
+    ;; interrupt deferral mechanism take care of the rest. From the
+    ;; OS's point of view the signal we are in the handler for is no
+    ;; longer pending, so the signal will not be lost.
+    (when (thread-interruptions *current-thread*)
+      (kill-safely (thread-os-thread *current-thread*) sb!unix:sigpipe))
+    (when interruption
+      (funcall interruption))))
+
 (defun interrupt-thread (thread function)
   #!+sb-doc
   "Interrupt the live THREAD and make it run FUNCTION. A moderate
 degree of care is expected for use of INTERRUPT-THREAD, due to its
 nature: if you interrupt a thread that was holding important locks
 then do something that turns out to need those locks, you probably
-won't like the effect."
-  #!-sb-thread (declare (ignore thread))
-  #!-sb-thread
+won't like the effect. FUNCTION runs with interrupts disabled, but
+WITH-INTERRUPTS is allowed in it. Keep in mind that many things may
+enable interrupts (GET-MUTEX when contended, for instance) so the
+first thing to do is usually a WITH-INTERRUPTS or a
+WITHOUT-INTERRUPTS. Within a thread interrupts are queued, they are
+run in same the order they were sent."
+  #!+win32
+  (declare (ignore thread))
+  #!+win32
   (with-interrupt-bindings
     (with-interrupts (funcall function)))
-  #!+sb-thread
-  (if (eq thread *current-thread*)
-      (with-interrupt-bindings
-        (with-interrupts (funcall function)))
-      (let ((os-thread (thread-os-thread thread)))
-        (cond ((not os-thread)
-               (error 'interrupt-thread-error :thread thread))
-              (t
-               (with-interruptions-lock (thread)
-                 (push function (thread-interruptions thread)))
-               (when (minusp (signal-interrupt-thread os-thread))
-                 (error 'interrupt-thread-error :thread thread)))))))
+  #!-win32
+  (let ((os-thread (thread-os-thread thread)))
+    (cond ((not os-thread)
+           (error 'interrupt-thread-error :thread thread))
+          (t
+           (with-interruptions-lock (thread)
+             ;; Append to the end of the interruptions queue. It's
+             ;; O(N), but it does not hurt to slow interruptors down a
+             ;; bit when the queue gets long.
+             (setf (thread-interruptions thread)
+                   (append (thread-interruptions thread)
+                           (list (lambda ()
+                                   (without-interrupts
+                                     (allow-with-interrupts
+                                       (funcall function))))))))
+           (when (minusp (kill-safely os-thread sb!unix:sigpipe))
+             (error 'interrupt-thread-error :thread thread))))))
 
 (defun terminate-thread (thread)
   #!+sb-doc
@@ -906,39 +1005,48 @@ SB-EXT:QUIT - the usual cleanup forms will be evaluated"
 
   (defun %symbol-value-in-thread (symbol thread)
     (tagbody
-       ;; Prevent the dead from dying completely while we look for the TLS area...
+       ;; Prevent the dead from dying completely while we look for the
+       ;; TLS area...
        (with-all-threads-lock
          (if (thread-alive-p thread)
-             (let* ((offset (* sb!vm:n-word-bytes (sb!vm::symbol-tls-index symbol)))
+             (let* ((offset (* sb!vm:n-word-bytes
+                               (sb!vm::symbol-tls-index symbol)))
                     (tl-val (sap-ref-word (%thread-sap thread) offset)))
                (if (eql tl-val sb!vm::no-tls-value-marker-widetag)
                    (go :unbound)
-                   (return-from %symbol-value-in-thread (values (make-lisp-obj tl-val) t))))
+                   (return-from %symbol-value-in-thread
+                     (values (make-lisp-obj tl-val) t))))
              (return-from %symbol-value-in-thread (values nil nil))))
      :unbound
-       (error "Cannot read thread-local symbol value: ~S unbound in ~S" symbol thread)))
+       (error "Cannot read thread-local symbol value: ~S unbound in ~S"
+              symbol thread)))
 
   (defun %set-symbol-value-in-thread (symbol thread value)
     (tagbody
        (with-pinned-objects (value)
-         ;; Prevent the dead from dying completely while we look for the TLS area...
+         ;; Prevent the dead from dying completely while we look for
+         ;; the TLS area...
          (with-all-threads-lock
            (if (thread-alive-p thread)
-               (let* ((offset (* sb!vm:n-word-bytes (sb!vm::symbol-tls-index symbol)))
+               (let* ((offset (* sb!vm:n-word-bytes
+                                 (sb!vm::symbol-tls-index symbol)))
                       (sap (%thread-sap thread))
                       (tl-val (sap-ref-word sap offset)))
                  (if (eql tl-val sb!vm::no-tls-value-marker-widetag)
                      (go :unbound)
-                     (setf (sap-ref-word sap offset) (get-lisp-obj-address value)))
+                     (setf (sap-ref-word sap offset)
+                           (get-lisp-obj-address value)))
                  (return-from %set-symbol-value-in-thread (values value t)))
                (return-from %set-symbol-value-in-thread (values nil nil)))))
      :unbound
-       (error "Cannot set thread-local symbol value: ~S unbound in ~S" symbol thread))))
+       (error "Cannot set thread-local symbol value: ~S unbound in ~S"
+              symbol thread))))
 
 (defun sb!vm::locked-symbol-global-value-add (symbol-name delta)
   (sb!vm::locked-symbol-global-value-add symbol-name delta))
+\f
 
-;;; Stepping
+;;;; Stepping
 
 (defun thread-stepping ()
   (make-lisp-obj