;; 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 :sigint :ignore)
+ (sb!sys:enable-interrupt sb!unix:sigint :ignore)
(sb!unix:unix-exit
(catch 'sb!impl::%end-of-the-world
(with-simple-restart
(funcall real-function))
0))))))))
+;;; Really, you don't want to use these: they'll get into trouble with
+;;; garbage collection. Use a lock or a waitqueue instead
+(defun suspend-thread (thread-id)
+ (sb!unix:unix-kill thread-id sb!unix:sigstop))
+(defun resume-thread (thread-id)
+ (sb!unix:unix-kill thread-id sb!unix:sigcont))
+;;; Note warning about cleanup forms
(defun destroy-thread (thread-id)
- (sb!unix:unix-kill thread-id :sigterm)
+ "Destroy the thread identified by THREAD-ID abruptly, without running cleanup forms"
+ (sb!unix:unix-kill thread-id sb!unix:sigterm)
;; may have been stopped for some reason, so now wake it up to
;; deliver the TERM
- (sb!unix:unix-kill thread-id :sigcont))
-
-;; Conventional wisdom says that it's a bad idea to use these unless
-;; you really need to. Use a lock or a waitqueue instead
-(defun suspend-thread (thread-id)
- (sb!unix:unix-kill thread-id :sigstop))
-(defun resume-thread (thread-id)
- (sb!unix:unix-kill thread-id :sigcont))
-
+ (sb!unix:unix-kill thread-id sb!unix:sigcont))
+
+
+;;; a moderate degree of care is expected for use of interrupt-thread,
+;;; due to its nature: if you interrupt a thread that was holding
+;;; important locks then do something that turns out to need those
+;;; locks, you probably won't like the effect. Used with thought
+;;; though, it's a good deal gentler than the last-resort functions above
+
+(defun interrupt-thread (thread function)
+ "Interrupt THREAD and make it run FUNCTION. "
+ (sb!unix::syscall* ("interrupt_thread"
+ sb!alien:unsigned-long sb!alien:unsigned-long)
+ thread
+ thread (sb!kernel:get-lisp-obj-address
+ (coerce function 'function))))
+(defun terminate-thread (thread-id)
+ "Terminate the thread identified by THREAD-ID, by causing it to run
+SB-EXT:QUIT - the usual cleanup forms will be evaluated"
+ (interrupt-thread thread-id 'sb!ext:quit))
+
+(declaim (inline current-thread-id))
(defun current-thread-id ()
- (sb!sys:sap-int
- (sb!vm::current-thread-offset-sap sb!vm::thread-pid-slot)))
+ (logand
+ (sb!sys:sap-int
+ (sb!vm::current-thread-offset-sap sb!vm::thread-pid-slot))
+ ;; KLUDGE pids are 16 bit really. Avoid boxing the return value
+ (1- (ash 1 16))))
;;;; iterate over the in-memory threads
;;;; queues, locks
;; spinlocks use 0 as "free" value: higher-level locks use NIL
+(declaim (inline get-spinlock release-spinlock))
+
(defun get-spinlock (lock offset new-value)
(declare (optimize (speed 3) (safety 0)))
(loop until
(eql (sb!vm::%instance-set-conditional lock offset 0 new-value) 0)))
+;; this should do nothing if we didn't own the lock, so safe to use in
+;; unwind-protect cleanups when lock acquisition failed for some reason
+(defun release-spinlock (lock offset our-value)
+ (declare (optimize (speed 3) (safety 0)))
+ (sb!vm::%instance-set-conditional lock offset our-value 0))
+
(defmacro with-spinlock ((queue) &body body)
(with-unique-names (pid)
- `(unwind-protect
- (let ((,pid (current-thread-id)))
- (get-spinlock ,queue 2 ,pid)
- ,@body)
- (setf (waitqueue-lock ,queue) 0))))
+ `(let ((,pid (current-thread-id)))
+ (unwind-protect
+ (progn
+ (get-spinlock ,queue 2 ,pid)
+ ,@body)
+ (release-spinlock ,queue 2 ,pid)))))
+
;;;; the higher-level locking operations are based on waitqueues
(sb!alien:define-alien-routine "block_sigcont" void)
(sb!alien:define-alien-routine "unblock_sigcont_and_sleep" void)
+
+;;; this should only be called while holding the queue spinlock.
+;;; it releases the spinlock before sleeping
(defun wait-on-queue (queue &optional lock)
(let ((pid (current-thread-id)))
- ;; FIXME what should happen if we get interrupted when we've blocked
- ;; the sigcont? For that matter, can we get interrupted?
(block-sigcont)
(when lock (release-mutex lock))
(sb!sys:without-interrupts
- (get-spinlock queue 2 pid)
- (pushnew pid (waitqueue-data queue))
- (setf (waitqueue-lock queue) 0))
+ (pushnew pid (waitqueue-data queue)))
+ (setf (waitqueue-lock queue) 0)
(unblock-sigcont-and-sleep)))
+;;; this should only be called while holding the queue spinlock. It doesn't
+;;; release it
(defun dequeue (queue)
(let ((pid (current-thread-id)))
- (sb!sys:without-interrupts
- (get-spinlock queue 2 pid)
+ (sb!sys:without-interrupts
(setf (waitqueue-data queue)
- (delete pid (waitqueue-data queue)))
- (setf (waitqueue-lock queue) 0))))
+ (delete pid (waitqueue-data queue))))))
+;;; this should only be called while holding the queue spinlock.
(defun signal-queue-head (queue)
- (let ((pid (current-thread-id))
- h)
- (sb!sys:without-interrupts
- (get-spinlock queue 2 pid)
- (setf h (car (waitqueue-data queue)))
- (setf (waitqueue-lock queue) 0))
- (when h
- (sb!unix:unix-kill h :sigcont))))
+ (let ((p (car (waitqueue-data queue))))
+ (when p (sb!unix:unix-kill p sb!unix::sig-dequeue))))
;;;; mutex
(defun get-mutex (lock &optional new-value (wait-p t))
- (declare (type mutex lock))
+ (declare (type mutex lock)
+ (optimize (speed 3)))
(let ((pid (current-thread-id)))
(unless new-value (setf new-value pid))
(assert (not (eql new-value (mutex-value lock))))
+ (get-spinlock lock 2 pid)
(loop
(unless
;; args are object slot-num old-value new-value
(sb!vm::%instance-set-conditional lock 4 nil new-value)
(dequeue lock)
+ (setf (waitqueue-lock lock) 0)
(return t))
- (unless wait-p (return nil))
+ (unless wait-p
+ (setf (waitqueue-lock lock) 0)
+ (return nil))
(wait-on-queue lock nil))))
(defun release-mutex (lock &optional (new-value nil))
(declare (type mutex lock))
;; we assume the lock is ours to release
- (setf (mutex-value lock) new-value)
- (signal-queue-head lock))
+ (with-spinlock (lock)
+ (setf (mutex-value lock) new-value)
+ (signal-queue-head lock)))
(defmacro with-mutex ((mutex &key value (wait-p t)) &body body)
"Atomically release LOCK and enqueue ourselves on QUEUE. Another
thread may subsequently notify us using CONDITION-NOTIFY, at which
time we reacquire LOCK and return to the caller."
- (unwind-protect
- (wait-on-queue queue lock)
- ;; If we are interrupted while waiting, we should do these things
- ;; before returning. Ideally, in the case of an unhandled signal,
- ;; we should do them before entering the debugger, but this is
- ;; better than nothing.
- (dequeue queue)
- (get-mutex lock)))
+ (assert lock)
+ (let ((value (mutex-value lock)))
+ (unwind-protect
+ (progn
+ (get-spinlock queue 2 (current-thread-id))
+ (wait-on-queue queue lock))
+ ;; If we are interrupted while waiting, we should do these things
+ ;; before returning. Ideally, in the case of an unhandled signal,
+ ;; we should do them before entering the debugger, but this is
+ ;; better than nothing.
+ (with-spinlock (queue)
+ (dequeue queue))
+ (get-mutex lock value))))
(defun condition-notify (queue)
"Notify one of the processes waiting on QUEUE"
- (signal-queue-head queue))
+ (with-spinlock (queue) (signal-queue-head queue)))
;;;; multiple independent listeners
(sb!sys:make-fd-stream err :input t :output t :buffering :line))
(sb!impl::*descriptor-handlers* nil))
(get-mutex *session-lock*)
- (sb!sys:enable-interrupt :sigint #'sb!unix::sigint-handler)
+ (sb!sys:enable-interrupt sb!unix:sigint #'sb!unix::sigint-handler)
(unwind-protect
(sb!impl::toplevel-repl nil)
(sb!int:flush-standard-output-streams)))))
(cond (wait-p (get-foreground))
(t (invoke-restart (car (compute-restarts))))))))
-;;; install this with (setf SB!INT:*REPL-PROMPT-FUN* #'thread-prompt-fun)
+;;; install this with
+;;; (setf SB-INT:*REPL-PROMPT-FUN* #'sb-thread::thread-repl-prompt-fun)
;;; One day it will be default
(defun thread-repl-prompt-fun (out-stream)
(let ((lock *session-lock*))
(sb!impl::repl-prompt-fun out-stream))))
(defun resume-stopped-thread (id)
- (let ((pid (current-thread-id))
- (lock *session-lock*))
+ (let ((lock *session-lock*))
(with-spinlock (lock)
(setf (waitqueue-data lock)
(cons id (delete id (waitqueue-data lock)))))
projects / sbcl.git / blobdiff