0.9.4.5:

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

diff --git a/src/code/target-thread.lisp b/src/code/target-thread.lisp
index 81e349e..63e282d 100644 (file)
--- a/src/code/target-thread.lisp
+++ b/src/code/target-thread.lisp
@@ -93,6 +93,9 @@ in future versions."
       system-area-pointer
     (lisp-fun-address unsigned-long))
 
+  (define-alien-routine "block_blockable_signals"
+    void)
+
   (define-alien-routine reap-dead-thread void
     (thread-sap system-area-pointer))
 
@@ -464,42 +467,47 @@ returns the thread exits."
          (setup-p nil)
          (real-function (coerce function 'function))
          (thread-sap
-          (%create-thread
-           (sb!kernel:get-lisp-obj-address
-            (lambda ()
-              ;; FIXME: use semaphores?
-              (loop until setup-p)
-              ;; in time we'll move some of the binding presently done in C
-              ;; here too
-              (let ((*current-thread* thread)
-                    (sb!kernel::*restart-clusters* nil)
-                    (sb!kernel::*handler-clusters* nil)
-                    (sb!kernel::*condition-restarts* nil)
-                    (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)
-                (unwind-protect
-                     (catch 'sb!impl::toplevel-catcher
-                       (catch 'sb!impl::%end-of-the-world
-                         (with-simple-restart
-                             (terminate-thread
-                              (format nil "~~@<Terminate this thread (~A)~~@:>"
-                                      *current-thread*))
-                           ;; 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)
-                           (unwind-protect
-                                (funcall real-function)
-                             ;; we're going down, can't handle
-                             ;; interrupts sanely anymore
-                             (sb!unix::block-blockable-signals)))))
-                  ;; and remove what can be the last reference to
-                  ;; the thread object
-                  (handle-thread-exit thread)
-                  0))
-              (values))))))
+          ;; don't let the child inherit *CURRENT-THREAD* because that
+          ;; can prevent gc'ing this thread while the child runs
+          (let ((*current-thread* nil))
+            (%create-thread
+             (sb!kernel:get-lisp-obj-address
+              (lambda ()
+                ;; FIXME: use semaphores?
+                (loop until setup-p)
+                ;; in time we'll move some of the binding presently done in C
+                ;; here too
+                (let ((*current-thread* thread)
+                      (sb!kernel::*restart-clusters* nil)
+                      (sb!kernel::*handler-clusters* nil)
+                      (sb!kernel::*condition-restarts* nil)
+                      (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)
+                  (unwind-protect
+                       (catch 'sb!impl::toplevel-catcher
+                         (catch 'sb!impl::%end-of-the-world
+                           (with-simple-restart
+                               (terminate-thread
+                                (format nil
+                                        "~~@<Terminate this thread (~A)~~@:>"
+                                        *current-thread*))
+                             ;; 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)
+                             (unwind-protect
+                                  (funcall real-function)
+                               ;; we're going down, can't handle
+                               ;; interrupts sanely anymore
+                               (let ((sb!impl::*gc-inhibit* t))
+                                 (block-blockable-signals)
+                                 ;; and remove what can be the last
+                                 ;; reference to this thread
+                                 (handle-thread-exit thread))))))
+                    0))
+                (values)))))))
     (when (sb!sys:sap= thread-sap (sb!sys:int-sap 0))
       (error "Can't create a new thread"))
     (setf (thread-%sap thread) thread-sap)
@@ -546,15 +554,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
@@ -572,6 +585,6 @@ SB-EXT:QUIT - the usual cleanup forms will be evaluated"
     (let* ((index (sb!vm::symbol-tls-index symbol))
            (tl-val (sb!sys:sap-ref-word thread-sap
                                         (* sb!vm:n-word-bytes index))))
-      (if (eql tl-val sb!vm::unbound-marker-widetag)
+      (if (eql tl-val sb!vm::no-tls-value-marker-widetag)
           (sb!vm::symbol-global-value symbol)
           (sb!kernel:make-lisp-obj tl-val)))))