1.0.3.11: Fix deportation gc safety bug

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

diff --git a/src/code/target-thread.lisp b/src/code/target-thread.lisp
index 9507b50..06002df 100644 (file)
--- a/src/code/target-thread.lisp
+++ b/src/code/target-thread.lisp
@@ -57,10 +57,18 @@ in future versions."
 (defvar *all-threads* ())
 (defvar *all-threads-lock* (make-mutex :name "all threads lock"))
 
+(defmacro with-all-threads-lock (&body body)
+  #!-sb-thread
+  `(locally ,@body)
+  #!+sb-thread
+  `(without-interrupts
+     (with-mutex (*all-threads-lock*)
+       ,@body)))
+
 (defun list-all-threads ()
   #!+sb-doc
   "Return a list of the live threads."
-  (with-mutex (*all-threads-lock*)
+  (with-all-threads-lock
     (copy-list *all-threads*)))
 
 (declaim (inline current-thread-sap))
@@ -97,7 +105,7 @@ in future versions."
   (define-alien-routine "signal_interrupt_thread"
       integer (os-thread unsigned-long))
 
-  (define-alien-routine "block_blockable_signals"
+  (define-alien-routine "block_deferrable_signals"
       void)
 
   #!+sb-lutex
@@ -117,6 +125,9 @@ in future versions."
     (sb!alien:define-alien-routine ("lutex_lock" %lutex-lock)
         int (lutex unsigned-long))
 
+    (sb!alien:define-alien-routine ("lutex_trylock" %lutex-trylock)
+        int (lutex unsigned-long))
+
     (sb!alien:define-alien-routine ("lutex_unlock" %lutex-unlock)
         int (lutex unsigned-long))
 
@@ -156,13 +167,18 @@ in future versions."
         int (word unsigned-long) (n unsigned-long))))
 
 ;;; used by debug-int.lisp to access interrupt contexts
-#!-(and sb-fluid sb-thread) (declaim (inline sb!vm::current-thread-offset-sap))
+#!-(or sb-fluid sb-thread) (declaim (inline sb!vm::current-thread-offset-sap))
 #!-sb-thread
 (defun sb!vm::current-thread-offset-sap (n)
   (declare (type (unsigned-byte 27) n))
   (sap-ref-sap (alien-sap (extern-alien "all_threads" (* t)))
                (* n sb!vm:n-word-bytes)))
 
+#!+sb-thread
+(defun sb!vm::current-thread-offset-sap (n)
+  (declare (type (unsigned-byte 27) n))
+  (sb!vm::current-thread-offset-sap n))
+
 ;;;; spinlocks
 
 (declaim (inline get-spinlock release-spinlock))
@@ -241,11 +257,11 @@ until it is available"
       (format *debug-io* "Thread: ~A~%" *current-thread*)
       (sb!debug:backtrace most-positive-fixnum *debug-io*)
       (force-output *debug-io*))
-    ;; FIXME: sb-lutex and (not wait-p)
     #!+sb-lutex
-    (when wait-p
-      (with-lutex-address (lutex (mutex-lutex mutex))
-        (%lutex-lock lutex))
+    (when (zerop (with-lutex-address (lutex (mutex-lutex mutex))
+                   (if wait-p
+                       (%lutex-lock lutex)
+                       (%lutex-trylock lutex))))
       (setf (mutex-value mutex) new-value))
     #!-sb-lutex
     (let (old)
@@ -467,16 +483,22 @@ this semaphore, then N of them is woken up."
 ;;; Remove thread from its session, if it has one.
 #!+sb-thread
 (defun handle-thread-exit (thread)
-  (with-mutex (*all-threads-lock*)
-    (/show0 "HANDLING THREAD EXIT")
-    #!+sb-lutex
-    (when (thread-interruptions-lock thread)
-      (/show0 "FREEING MUTEX LUTEX")
-      (with-lutex-address (lutex (mutex-lutex (thread-interruptions-lock thread)))
-        (%lutex-destroy lutex)))
-    (setq *all-threads* (delete thread *all-threads*)))
-  (when *session*
-    (%delete-thread-from-session thread *session*)))
+  (/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)
+    (setf (thread-os-thread thread) nil)
+    (setq *all-threads* (delete thread *all-threads*))
+    (when *session*
+      (%delete-thread-from-session thread *session*)))
+  #!+sb-lutex
+  (when (thread-interruptions-lock thread)
+    (/show0 "FREEING MUTEX LUTEX")
+    (with-lutex-address (lutex (mutex-lutex (thread-interruptions-lock thread)))
+      (%lutex-destroy lutex))))
 
 (defun terminate-session ()
   #!+sb-doc
@@ -607,6 +629,7 @@ returns the thread exits."
                   (sb!kernel::*restart-clusters* nil)
                   (sb!kernel::*handler-clusters* nil)
                   (sb!kernel::*condition-restarts* nil)
+                  (sb!impl::*step-out* nil)
                   ;; internal printer variables
                   (sb!impl::*previous-case* nil)
                   (sb!impl::*previous-readtable-case* nil)
@@ -615,7 +638,7 @@ returns the thread exits."
                   (sb!impl::*internal-symbol-output-fun* nil)
                   (sb!impl::*descriptor-handlers* nil)) ; serve-event
               (setf (thread-os-thread thread) (current-thread-sap-id))
-              (with-mutex (*all-threads-lock*)
+              (with-all-threads-lock
                 (push thread *all-threads*))
               (with-session-lock (*session*)
                 (push thread (session-threads *session*)))
@@ -638,15 +661,7 @@ returns the thread exits."
                            ;; threads, it's time to enable signals
                            (sb!unix::reset-signal-mask)
                            (funcall real-function))
-                      ;; we're going down, can't handle
-                      ;; interrupts sanely anymore
-                      (let ((sb!impl::*gc-inhibit* t))
-                        (block-blockable-signals)
-                        (setf (thread-%alive-p thread) nil)
-                        (setf (thread-os-thread thread) nil)
-                        ;; and remove what can be the last
-                        ;; reference to this thread
-                        (handle-thread-exit thread)))))))
+                      (handle-thread-exit thread))))))
             (values))))
     ;; Keep INITIAL-FUNCTION pinned until the child thread is
     ;; initialized properly.
@@ -757,3 +772,15 @@ SB-EXT:QUIT - the usual cleanup forms will be evaluated"
 
 (defun sb!vm::locked-symbol-global-value-add (symbol-name delta)
   (sb!vm::locked-symbol-global-value-add symbol-name delta))
+
+;;; Stepping
+
+(defun thread-stepping ()
+  (sb!kernel:make-lisp-obj
+   (sap-ref-word (current-thread-sap)
+                 (* sb!vm::thread-stepping-slot sb!vm:n-word-bytes))))
+
+(defun (setf thread-stepping) (value)
+  (setf (sap-ref-word (current-thread-sap)
+                      (* sb!vm::thread-stepping-slot sb!vm:n-word-bytes))
+        (sb!kernel:get-lisp-obj-address value)))