0.9.3.75:

[sbcl.git] / src / code / target-thread.lisp

diff --git a/src/code/target-thread.lisp b/src/code/target-thread.lisp
index 81e7130..639bd2d 100644 (file)
--- a/src/code/target-thread.lisp
+++ b/src/code/target-thread.lisp
@@ -50,17 +50,6 @@ in future versions."
       (#.(sb!vm:fixnumize 2) :suspended)
       (#.(sb!vm:fixnumize 3) :dead))))
 
-(defun %set-thread-state (thread state)
-  (setf (sb!sys:sap-ref-sap (thread-%sap thread)
-                            (* sb!vm::thread-state-slot
-                               sb!vm::n-word-bytes))
-        (sb!sys:int-sap
-          (ecase state
-            (:starting #.(sb!vm:fixnumize 0))
-            (:running #.(sb!vm:fixnumize 1))
-            (:suspended #.(sb!vm:fixnumize 2))
-            (:dead #.(sb!vm:fixnumize 3))))))
-
 (defun thread-alive-p (thread)
   #!+sb-doc
   "Check if THREAD is running."
@@ -104,6 +93,9 @@ in future versions."
       system-area-pointer
     (lisp-fun-address unsigned-long))
 
+  (define-alien-routine "block_deferrable_signals_and_inhibit_gc"
+    void)
+
   (define-alien-routine reap-dead-thread void
     (thread-sap system-area-pointer))
 
@@ -418,13 +410,14 @@ interactive."
 (defun release-foreground (&optional next)
   #!+sb-doc
   "Background this thread.  If NEXT is supplied, arrange for it to
-have the foreground next"
+have the foreground next."
   #!-sb-thread (declare (ignore next))
   #!-sb-thread nil
   #!+sb-thread
   (with-session-lock (*session*)
-    (setf (session-interactive-threads *session*)
-          (delete *current-thread* (session-interactive-threads *session*)))
+    (when (rest (session-interactive-threads *session*))
+      (setf (session-interactive-threads *session*)
+            (delete *current-thread* (session-interactive-threads *session*))))
     (when next
       (setf (session-interactive-threads *session*)
             (list* next
@@ -485,8 +478,7 @@ returns the thread exits."
                     (sb!kernel::*restart-clusters* nil)
                     (sb!kernel::*handler-clusters* nil)
                     (sb!kernel::*condition-restarts* nil)
-                    (sb!impl::*descriptor-handlers* nil) ; serve-event
-                    (sb!impl::*available-buffers* nil)) ;for fd-stream
+                    (sb!impl::*descriptor-handlers* nil)) ; serve-event
                 ;; can't use handling-end-of-the-world, because that flushes
                 ;; output streams, and we don't necessarily have any (or we
                 ;; could be sharing them)
@@ -505,13 +497,11 @@ returns the thread exits."
                                 (funcall real-function)
                              ;; we're going down, can't handle
                              ;; interrupts sanely anymore
-                             (sb!unix::block-blockable-signals)))))
-                  ;; mark the thread dead, so that the gc does not
-                  ;; wait for it to handle sig-stop-for-gc
-                  (%set-thread-state thread :dead)
-                  ;; and remove what can be the last reference to
-                  ;; the thread object
+                             (block-deferrable-signals-and-inhibit-gc)))))
+                  ;; and remove what can be the last references to the
+                  ;; thread object
                   (handle-thread-exit thread)
+                  (setq *current-thread* nil)
                   0))
               (values))))))
     (when (sb!sys:sap= thread-sap (sb!sys:int-sap 0))
@@ -560,15 +550,20 @@ won't like the effect."
   #!-sb-thread
   (funcall function)
   #!+sb-thread
-  (let ((function (coerce function 'function)))
-    (multiple-value-bind (res err)
-        (sb!unix::syscall ("interrupt_thread"
-                           system-area-pointer sb!alien:unsigned-long)
-                          thread
-                          (thread-%sap thread)
-                          (sb!kernel:get-lisp-obj-address function))
-      (unless res
-        (error 'interrupt-thread-error :thread thread :errno err)))))
+  (if (eq thread *current-thread*)
+      (funcall function)
+      (let ((function (coerce function 'function)))
+        (multiple-value-bind (res err)
+            ;; protect against gcing just when the ub32 address is
+            ;; just ready to be passed to C
+            (sb!sys::with-pinned-objects (function)
+              (sb!unix::syscall ("interrupt_thread"
+                                 system-area-pointer sb!alien:unsigned-long)
+                                thread
+                                (thread-%sap thread)
+                                (sb!kernel:get-lisp-obj-address function)))
+          (unless res
+            (error 'interrupt-thread-error :thread thread :errno err))))))
 
 (defun terminate-thread (thread)
   #!+sb-doc