From: Gabor Melis Date: Wed, 6 Jul 2005 14:49:38 +0000 (+0000) Subject: 0.9.2.32: X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=85ccf873433c26680881bf9ab01995d781e065e2;p=sbcl.git 0.9.2.32: * bug fix: debugger doesn't hang on session lock if interrupted at an inappropriate moment (added another without-interrupts until a better solution is found) --- diff --git a/NEWS b/NEWS index cb7f9e3..f4267cc 100644 --- a/NEWS +++ b/NEWS @@ -28,6 +28,8 @@ changes in sbcl-0.9.3 relative to sbcl-0.9.2: ** bug fix: don't halt on infinite error in threads if possible ** fixed numerous gc deadlocks introduced in the pthread merge ** bug fix: fixed thread safety issues in read and print + ** bug fix: debugger doesn't hang on session lock if interrupted at + an inappropriate moment * fixed some bugs revealed by Paul Dietz' test suite: ** TYPE-ERRORs from signalled by COERCE now have DATUM and EXPECTED-TYPE slots filled. diff --git a/src/code/target-multithread.lisp b/src/code/target-multithread.lisp index b2d2350..43f051c 100644 --- a/src/code/target-multithread.lisp +++ b/src/code/target-multithread.lisp @@ -18,8 +18,6 @@ (define-alien-routine reap-dead-thread void (thread-sap system-area-pointer)) -(defvar *session* nil) - ;;;; queues, locks ;; spinlocks use 0 as "free" value: higher-level locks use NIL @@ -153,112 +151,6 @@ time we reacquire LOCK and return to the caller." (setf (waitqueue-data queue) me) (futex-wake (waitqueue-data-address queue) (ash 1 30)))) -(defun make-thread (function &key name) - ;; ;; don't let them interrupt us because the child is waiting for setup-p - ;; (sb!sys:without-interrupts - (let* ((thread (%make-thread :name name)) - (setup-p nil) - (real-function (coerce function 'function)) - (thread-sap - (%create-thread - (sb!kernel:get-lisp-obj-address - (lambda () - ;; FIXME: use semaphores? - (loop until setup-p) - ;; in time we'll move some of the binding presently done in C - ;; here too - (let ((*current-thread* thread) - (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) - (unwind-protect - (catch 'sb!impl::toplevel-catcher - (catch 'sb!impl::%end-of-the-world - (with-simple-restart - (terminate-thread - (format nil "~~@" - *current-thread*)) - ;; now that most things have a chance to work - ;; properly without messing up other threads, it's - ;; time to enable signals - (sb!unix::reset-signal-mask) - (unwind-protect - (funcall real-function) - ;; we're going down, can't handle - ;; interrupts sanely anymore - (sb!unix::block-blockable-signals))))) - ;; mark the thread dead, so that the gc does not - ;; wait for it to handle sig-stop-for-gc - (%set-thread-state thread :dead) - ;; and remove what can be the last reference to - ;; the thread object - (handle-thread-exit thread) - 0)) - (values)))))) - (when (sb!sys:sap= thread-sap (sb!sys:int-sap 0)) - (error "Can't create a new thread")) - (setf (thread-%sap thread) thread-sap) - (with-mutex (*all-threads-lock*) - (push thread *all-threads*)) - (with-mutex ((session-lock *session*)) - (push thread (session-threads *session*))) - (setq setup-p t) - (sb!impl::finalize thread (lambda () (reap-dead-thread thread-sap))) - thread)) - -(defun destroy-thread (thread) - "Deprecated. Soon to be removed or reimplemented using pthread_cancel." - (terminate-thread thread)) - -;;; 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. - -(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))) - (multiple-value-bind (res err) - (sb!unix::syscall ("interrupt_thread" - system-area-pointer sb!alien:unsigned-long) - thread - (thread-%sap thread) - (sb!kernel:get-lisp-obj-address function)) - (unless res - (error 'interrupt-thread-error :thread thread :errno err))))) - -(defun terminate-thread (thread) - "Terminate the thread identified by THREAD, by causing it to run -SB-EXT:QUIT - the usual cleanup forms will be evaluated" - (interrupt-thread thread 'sb!ext:quit)) - -;;; internal use only. If you think you need to use this, either you -;;; are an SBCL developer, are doing something that you should discuss -;;; with an SBCL developer first, or are doing something that you -;;; should probably discuss with a professional psychiatrist first -(defun symbol-value-in-thread (symbol thread) - (let ((thread-sap (thread-%sap thread))) - (let* ((index (sb!vm::symbol-tls-index symbol)) - (tl-val (sb!sys:sap-ref-word thread-sap - (* sb!vm:n-word-bytes index)))) - (if (eql tl-val sb!vm::unbound-marker-widetag) - (sb!vm::symbol-global-value symbol) - (sb!kernel:make-lisp-obj tl-val))))) - ;;;; job control, independent listeners (defstruct session @@ -267,6 +159,16 @@ SB-EXT:QUIT - the usual cleanup forms will be evaluated" (interactive-threads nil) (interactive-threads-queue (make-waitqueue))) +(defvar *session* nil) + +;;; the debugger itself tries to acquire the session lock, don't let +;;; funny situations (like getting a sigint while holding the session +;;; lock) occur +(defmacro with-session-lock ((session) &body body) + `(sb!sys:without-interrupts + (with-mutex ((session-lock ,session)) + ,@body))) + (defun new-session () (make-session :threads (list *current-thread*) :interactive-threads (list *current-thread*))) @@ -275,7 +177,7 @@ SB-EXT:QUIT - the usual cleanup forms will be evaluated" (setf *session* (new-session))) (defun %delete-thread-from-session (thread session) - (with-mutex ((session-lock session)) + (with-session-lock (session) (setf (session-threads session) (delete thread (session-threads session)) (session-interactive-threads session) @@ -304,7 +206,7 @@ SB-EXT:QUIT - the usual cleanup forms will be evaluated" thread is not the foreground thread" ;; FIXME: threads created in other threads may escape termination (let ((to-kill - (with-mutex ((session-lock *session*)) + (with-session-lock (*session*) (and (eq *current-thread* (car (session-interactive-threads *session*))) (session-threads *session*))))) @@ -323,7 +225,7 @@ thread is not the foreground thread" interactive." (declare (ignore stream)) (prog1 - (with-mutex ((session-lock *session*)) + (with-session-lock (*session*) (not (member *current-thread* (session-interactive-threads *session*)))) (get-foreground))) @@ -331,7 +233,7 @@ interactive." (defun get-foreground () (let ((was-foreground t)) (loop - (with-mutex ((session-lock *session*)) + (with-session-lock (*session*) (let ((int-t (session-interactive-threads *session*))) (when (eq (car int-t) *current-thread*) (unless was-foreground @@ -348,7 +250,7 @@ interactive." (defun release-foreground (&optional next) "Background this thread. If NEXT is supplied, arrange for it to have the foreground next" - (with-mutex ((session-lock *session*)) + (with-session-lock (*session*) (setf (session-interactive-threads *session*) (delete *current-thread* (session-interactive-threads *session*))) (when next @@ -386,3 +288,109 @@ have the foreground next" (sb!impl::toplevel-repl nil) (sb!int:flush-standard-output-streams)))))) (make-thread #'thread-repl)))) + +;;;; the beef + +(defun make-thread (function &key name) + (let* ((thread (%make-thread :name name)) + (setup-p nil) + (real-function (coerce function 'function)) + (thread-sap + (%create-thread + (sb!kernel:get-lisp-obj-address + (lambda () + ;; FIXME: use semaphores? + (loop until setup-p) + ;; in time we'll move some of the binding presently done in C + ;; here too + (let ((*current-thread* thread) + (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) + (unwind-protect + (catch 'sb!impl::toplevel-catcher + (catch 'sb!impl::%end-of-the-world + (with-simple-restart + (terminate-thread + (format nil "~~@" + *current-thread*)) + ;; now that most things have a chance to work + ;; properly without messing up other threads, it's + ;; time to enable signals + (sb!unix::reset-signal-mask) + (unwind-protect + (funcall real-function) + ;; we're going down, can't handle + ;; interrupts sanely anymore + (sb!unix::block-blockable-signals))))) + ;; mark the thread dead, so that the gc does not + ;; wait for it to handle sig-stop-for-gc + (%set-thread-state thread :dead) + ;; and remove what can be the last reference to + ;; the thread object + (handle-thread-exit thread) + 0)) + (values)))))) + (when (sb!sys:sap= thread-sap (sb!sys:int-sap 0)) + (error "Can't create a new thread")) + (setf (thread-%sap thread) thread-sap) + (with-mutex (*all-threads-lock*) + (push thread *all-threads*)) + (with-session-lock (*session*) + (push thread (session-threads *session*))) + (setq setup-p t) + (sb!impl::finalize thread (lambda () (reap-dead-thread thread-sap))) + thread)) + +(defun destroy-thread (thread) + "Deprecated. Soon to be removed or reimplemented using pthread_cancel." + (terminate-thread thread)) + +;;; 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. + +(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))) + (multiple-value-bind (res err) + (sb!unix::syscall ("interrupt_thread" + system-area-pointer sb!alien:unsigned-long) + thread + (thread-%sap thread) + (sb!kernel:get-lisp-obj-address function)) + (unless res + (error 'interrupt-thread-error :thread thread :errno err))))) + +(defun terminate-thread (thread) + "Terminate the thread identified by THREAD, by causing it to run +SB-EXT:QUIT - the usual cleanup forms will be evaluated" + (interrupt-thread thread 'sb!ext:quit)) + +;;; internal use only. If you think you need to use this, either you +;;; are an SBCL developer, are doing something that you should discuss +;;; with an SBCL developer first, or are doing something that you +;;; should probably discuss with a professional psychiatrist first +(defun symbol-value-in-thread (symbol thread) + (let ((thread-sap (thread-%sap thread))) + (let* ((index (sb!vm::symbol-tls-index symbol)) + (tl-val (sb!sys:sap-ref-word thread-sap + (* sb!vm:n-word-bytes index)))) + (if (eql tl-val sb!vm::unbound-marker-widetag) + (sb!vm::symbol-global-value symbol) + (sb!kernel:make-lisp-obj tl-val))))) diff --git a/tests/threads.impure.lisp b/tests/threads.impure.lisp index 4e9e8fa..e073ad9 100644 --- a/tests/threads.impure.lisp +++ b/tests/threads.impure.lisp @@ -352,6 +352,18 @@ (format t "~&thread startup sigmask test done~%") +(let* ((main-thread *current-thread*) + (interruptor-thread + (make-thread (lambda () + (sleep 2) + (interrupt-thread main-thread #'break) + (sleep 2) + (interrupt-thread main-thread #'continue))))) + (with-session-lock (*session*) + (sleep 3)) + (loop while (thread-alive-p interruptor-thread))) + +(format t "~&session lock test done~%") #| ;; a cll post from eric marsden | (defun crash () | (setq *debugger-hook* diff --git a/version.lisp-expr b/version.lisp-expr index e551092..eea7f23 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -17,4 +17,4 @@ ;;; checkins which aren't released. (And occasionally for internal ;;; versions, especially for internal versions off the main CVS ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".) -"0.9.2.31" +"0.9.2.32"