X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Ftarget-thread.lisp;h=093f50f49bbc76224f7dfedb7234154dd62c8594;hb=835768a81dad03b7eb94c2058e234413ba066396;hp=ec06a870ca3df381d17ba265ed8e0f0aae83cd97;hpb=0e2c926fea68a32c8ec58f12daa0c2b5befef1d4;p=sbcl.git diff --git a/src/code/target-thread.lisp b/src/code/target-thread.lisp index ec06a87..093f50f 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,18 +27,39 @@ (funcall real-function)) 0)))))))) +;;; 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 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)) + (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)) -;; 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)) (defun current-thread-id () (sb!sys:sap-int @@ -83,6 +104,8 @@ (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 @@ -90,28 +113,22 @@ (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:sigcont)))) ;;;; mutex @@ -120,20 +137,25 @@ (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) @@ -151,18 +173,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 - (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 @@ -191,7 +218,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))))) @@ -218,7 +245,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*))