(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))
;; 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))
;;; 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