0.8.17.20:

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

diff --git a/src/code/target-thread.lisp b/src/code/target-thread.lisp
index 07a0031..b882962 100644 (file)
--- a/src/code/target-thread.lisp
+++ b/src/code/target-thread.lisp
@@ -58,7 +58,7 @@
 (declaim (inline waitqueue-data-address mutex-value-address))
 
 (defstruct waitqueue
-  (name nil :type (or null simple-base-string))
+  (name nil :type (or null simple-string))
   (lock 0)
   (data nil))
 
@@ -265,20 +265,22 @@ time we reacquire LOCK and return to the caller."
              ;; in time we'll move some of the binding presently done in C
              ;; here too
              (let ((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
                ;; 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)
                (sb!sys:enable-interrupt sb!unix:sigint :ignore)
-               (sb!unix:unix-exit
-                (catch 'sb!impl::%end-of-the-world 
-                  (with-simple-restart 
-                      (destroy-thread
-                       (format nil "~~@<Destroy this thread (~A)~~@:>"
-                               (current-thread-id)))
-                    (funcall real-function))
-                  0))))))))
+               (catch 'sb!impl::%end-of-the-world 
+                 (with-simple-restart 
+                     (destroy-thread
+                      (format nil "~~@<Destroy this thread (~A)~~@:>"
+                              (current-thread-id)))
+                   (funcall real-function))
+                 0))
+             (values))))))
     (with-mutex ((session-lock *session*))
       (pushnew tid (session-threads *session*)))
     tid))
@@ -306,15 +308,29 @@ time we reacquire LOCK and return to the caller."
 ;;; locks, you probably won't like the effect.  Used with thought
 ;;; though, it's a good deal gentler than the last-resort functions above
 
+(define-condition interrupt-thread-error (error)
+  ((thread :reader interrupt-thread-error-thread :initarg :thread)
+   (errno :reader interrupt-thread-error-errno :initarg :errno))
+  (:report (lambda (c s)
+            (format s "interrupt thread ~A failed (~A: ~A)"
+                    (interrupt-thread-error-thread c)
+                    (interrupt-thread-error-errno c)
+                    (strerror (interrupt-thread-error-errno c))))))
+
 (defun interrupt-thread (thread function)
   "Interrupt THREAD and make it run FUNCTION."
   (let ((function (coerce function 'function)))
-    (sb!sys:with-pinned-objects (function)
-      (sb!unix::syscall* ("interrupt_thread"
-                         sb!alien:unsigned-long  sb!alien:unsigned-long)
-                        thread
-                        thread 
-                        (sb!kernel:get-lisp-obj-address function)))))
+    (sb!sys:with-pinned-objects 
+     (function)
+     (multiple-value-bind (res err)
+        (sb!unix::syscall ("interrupt_thread"
+                           sb!alien:unsigned-long  sb!alien:unsigned-long)
+                          thread
+                          thread 
+                          (sb!kernel:get-lisp-obj-address function))
+       (unless res
+        (error 'interrupt-thread-error :thread thread :errno err))))))
+
 
 (defun terminate-thread (thread-id)
   "Terminate the thread identified by THREAD-ID, by causing it to run