X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Ftarget-thread.lisp;h=2601a460e4e218bc1f21915d24f0e31265f21654;hb=4ed3f0d08c3a57a6762018d9622f253ab9d0f2b6;hp=c7d40d901f86bd3bbeddfb5b583bca4810e08f9e;hpb=8ee426cacceebd52f18232cd748ba8a1f211e9fd;p=sbcl.git diff --git a/src/code/target-thread.lisp b/src/code/target-thread.lisp index c7d40d9..2601a46 100644 --- a/src/code/target-thread.lisp +++ b/src/code/target-thread.lisp @@ -17,7 +17,7 @@ ;; 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 @@ -27,22 +27,46 @@ (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 @@ -57,18 +81,28 @@ ;;;; 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 @@ -83,12 +117,11 @@ (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 @@ -104,16 +137,16 @@ (setf (waitqueue-data queue) (delete pid (waitqueue-data queue)))))) -;;; this should probably only be called while holding the queue spinlock. -;;; not sure +;;; this should only be called while holding the queue spinlock. (defun signal-queue-head (queue) (let ((p (car (waitqueue-data queue)))) - (when p (sb!unix:unix-kill p :sigcont)))) + (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)))) @@ -153,21 +186,23 @@ "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 - (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))) + (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 @@ -196,7 +231,7 @@ time we reacquire LOCK and return to the caller." (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))))) @@ -223,7 +258,8 @@ restart if *BACKGROUND-THREADS-WAIT-FOR-DEBUGGER* says to do that instead" (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*)) @@ -234,8 +270,7 @@ restart if *BACKGROUND-THREADS-WAIT-FOR-DEBUGGER* says to do that instead" (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)))))