From: Gabor Melis Date: Fri, 1 Jul 2005 08:48:08 +0000 (+0000) Subject: 0.9.2.9: thread objects X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=94ea2b2082deaa0331dfb66fa6af6ca12dd8dc83;p=sbcl.git 0.9.2.9: thread objects * Public interface changes ** proper thread objects instead of thread ids ** (MAKE-THREAD FN &KEY NAME) => THREAD ** (THREAD-NAME THREAD): threads have names (useful for debugging, logging) ** (THREAD-ALIVE-P THREAD) ** *CURRENT-THREAD* special is bound in each thread ** (LIST-ALL-THREADS) returns a list of all active threads * Notes ** thread-init moved earlier in cold-init and reinit ** the lisp side does not ever use os_thread_t (it was problematic due to pthread_t being opaque) but struct thread * ** threads are reaped (i.e. the thread is pthread_joined and struct thread* is freed) by the thread object's finalizer. This makes it easy to implement resetting threads. Running threads are kept in sb-thread::*all-threads*. ** threads block all blockable signals when going down: interrupt-thread and others cannot catch it at an inappropriate moment, for instance calling quit outside the catch %end-of-the-world ** target-thread.lisp renamed target-multithread.lisp, target-thread.lisp now contains the generic thread support ** new file early-thread.lisp: define *current-thread* ** removed thread state STOPPING that was only used for assertions and complicated matters ** renumbered thread states ** sb-thread::release-spinlock now releases the locks with non-fixnum value, but is no longer safe to call multiple times ** much simplified locking for threads and gc ** fixed deadlocking bugs introduced by the pthread merge --- diff --git a/NEWS b/NEWS index 95aec0d..3f21c9c 100644 --- a/NEWS +++ b/NEWS @@ -5,6 +5,13 @@ changes in sbcl-0.9.3 relative to sbcl-0.9.2: * Support for the koi8-r external format. (thanks to Ivan Boldyrev) * Bug fix: OPEN no longer fails when *PRINT-READABLY* is T. (thanks to Zach Beane) + * threads + ** incompatible change: the threading api now works with thread + objects instead of thread ids + ** bug fix: threads are protected from signals and interruption when + starting up or going down + ** bug fix: a race where an exiting thread could lose its stack to gc + ** fixed numerous gc deadlocks introduced in the pthread merge changes in sbcl-0.9.2 relative to sbcl-0.9.1: * numerous signal handling fixes to increase stability diff --git a/build-order.lisp-expr b/build-order.lisp-expr index 7205266..5d4acb2 100644 --- a/build-order.lisp-expr +++ b/build-order.lisp-expr @@ -121,6 +121,7 @@ ;; mostly needed by stuff from comcom, but also used by "x86-vm" ("src/code/debug-var-io") + ("src/code/early-thread") ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; basic machinery for the target Lisp. Note that although most of these ;;; files are flagged :NOT-HOST, a few might not be. @@ -637,8 +638,9 @@ ("src/code/sharpm" :not-host) ; uses stuff from "code/reader" ("src/code/alloc" :not-host) - #!+sb-thread ("src/code/target-thread" :not-host) + #!+sb-thread + ("src/code/target-multithread" :not-host) #!-sb-thread ("src/code/target-unithread" :not-host) ;; defines SB!DI:DO-DEBUG-FUN-BLOCKS, needed by target-disassem.lisp diff --git a/contrib/sb-aclrepl/repl.lisp b/contrib/sb-aclrepl/repl.lisp index e2d3f82..1675daa 100644 --- a/contrib/sb-aclrepl/repl.lisp +++ b/contrib/sb-aclrepl/repl.lisp @@ -301,23 +301,21 @@ (values)) #+sb-thread -(defun thread-pids () - "Return a list of the pids for all threads" - (let ((offset (* 4 sb-vm::thread-os-thread-slot))) - (sb-thread::mapcar-threads - #'(lambda (sap) (sb-sys:sap-ref-32 sap offset))))) +(defun all-threads () + "Return a list of all threads" + (sb-thread:list-all-threads)) #+sb-thread -(defun other-thread-pids () - "Returns a list of pids for all threads except the current process" - (delete (sb-thread:current-thread-id) (thread-pids) :test #'eql)) +(defun other-threads () + "Returns a list of all threads except the current one" + (delete sb-thread:*current-thread* (all-threads))) (defun exit-cmd (&optional (status 0)) #+sb-thread - (let ((other-pids (other-thread-pids))) - (when other-pids + (let ((other-threads (other-threads))) + (when other-threads (format *output* "There exists the following processes~%") - (format *output* "~{~5d~%~}" other-pids) + (format *output* "~{~A~%~}" other-threads) (format *output* "Do you want to exit lisp anyway [n]? ") (force-output *output*) (let ((input (string-trim-whitespace (read-line *input*)))) @@ -325,9 +323,9 @@ (or (char= #\y (char input 0)) (char= #\Y (char input 0)))) ;; loop in case more threads get created while trying to exit - (do ((pids other-pids (other-thread-pids))) - ((eq nil pids)) - (map nil #'sb-thread:destroy-thread pids) + (do ((threads other-threads (other-threads))) + ((eq nil threads)) + (map nil #'sb-thread:destroy-thread threads) (sleep 0.2)) (return-from exit-cmd))))) (sb-ext:quit :unix-status status) @@ -566,43 +564,21 @@ (defun processes-cmd () #+sb-thread - (let ((pids (thread-pids)) - (current-pid (sb-thread:current-thread-id))) - (dolist (pid pids) - (format *output* "~&~D" pid) - (when (= pid current-pid) - (format *output* " [current listener]")))) + (dolist (thread (all-threads)) + (format *output* "~&~A" thread) + (when (= thread sb-thread:*current-thread*) + (format *output* " [current listener]"))) #-sb-thread (format *output* "~&Threads are not supported in this version of sbcl") (values)) -(defun kill-cmd (&rest selected-pids) +(defun kill-cmd (&rest selected-threads) #+sb-thread - (let ((pids (thread-pids))) - (dolist (selected-pid selected-pids) - (if (find selected-pid pids :test #'eql) - (progn - (sb-thread:destroy-thread selected-pid) - (format *output* "~&Thread ~A destroyed" selected-pid)) - (format *output* "~&No thread ~A exists" selected-pid)))) + (dolist (thread selected-threads) + (sb-thread:destroy-thread thread) + (format *output* "~&Thread ~A destroyed" thread)) #-sb-thread - (declare (ignore selected-pids)) - #-sb-thread - (format *output* "~&Threads are not supported in this version of sbcl") - (values)) - -(defun signal-cmd (signal &rest selected-pids) - #+sb-thread - (let ((pids (thread-pids))) - (dolist (selected-pid selected-pids) - (if (find selected-pid pids :test #'eql) - (progn - (sb-unix:unix-kill selected-pid signal) - (format *output* "~&Signal ~A sent to thread ~A" - signal selected-pid)) - (format *output* "~&No thread ~A exists" selected-pid)))) - #-sb-thread - (declare (ignore signal selected-pids)) + (declare (ignore selected-threads)) #-sb-thread (format *output* "~&Threads are not supported in this version of sbcl") (values)) @@ -658,7 +634,6 @@ ("inspect" 2 inspect-cmd "inspect an object") ("istep" 1 istep-cmd "navigate within inspection of a lisp object" :parsing :string) #+sb-thread ("kill" 2 kill-cmd "kill (destroy) processes") - #+sb-thread ("signal" 2 signal-cmd "send a signal to processes") #+sb-thread ("focus" 2 focus-cmd "focus the top level on a process") ("local" 3 local-cmd "print the value of a local variable") ("pwd" 3 pwd-cmd "print current directory") diff --git a/doc/manual/threading.texinfo b/doc/manual/threading.texinfo index 6efed89..944892a 100644 --- a/doc/manual/threading.texinfo +++ b/doc/manual/threading.texinfo @@ -58,12 +58,11 @@ if you want a bounded wait. (defvar *a-mutex* (make-mutex :name "my lock")) (defun thread-fn () - (let ((id (current-thread-id))) - (format t "Thread ~A running ~%" id) - (with-mutex (*a-mutex*) - (format t "Thread ~A got the lock~%" id) - (sleep (random 5))) - (format t "Thread ~A dropped lock, dying now~%" id))) + (format t "Thread ~A running ~%" *current-thread*) + (with-mutex (*a-mutex*) + (format t "Thread ~A got the lock~%" *current-thread*) + (sleep (random 5))) + (format t "Thread ~A dropped lock, dying now~%" *current-thread*))) (make-thread #'thread-fn) (make-thread #'thread-fn) @@ -130,7 +129,7 @@ it. (let ((head (car *buffer*))) (setf *buffer* (cdr *buffer*)) (format t "reader ~A woke, read ~A~%" - (current-thread-id) head)))))) + *current-thread* head)))))) (defun writer () (loop diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr index 7ff4ef7..d861f4b 100644 --- a/package-data-list.lisp-expr +++ b/package-data-list.lisp-expr @@ -1587,14 +1587,15 @@ is a good idea, but see SB-SYS re. blurring of boundaries." :name "SB!THREAD" :use ("CL" "SB!ALIEN" "SB!INT") :doc "public (but low-level): native thread support" - :export ("MAKE-THREAD" + :export ("*CURRENT-THREAD*" "MAKE-THREAD" "THREAD" + "THREAD-NAME" "THREAD-ALIVE-P" + "LIST-ALL-THREADS" "MAKE-LISTENER-THREAD" "DESTROY-THREAD" "TERMINATE-THREAD" "INTERRUPT-THREAD" "WITH-RECURSIVE-LOCK" "MUTEX" "MAKE-MUTEX" "GET-MUTEX" "RELEASE-MUTEX" "WITH-MUTEX" "MUTEX-VALUE" "WAITQUEUE" "MAKE-WAITQUEUE" "CONDITION-WAIT" "CONDITION-NOTIFY" "CONDITION-BROADCAST" - "WITH-RECURSIVE-LOCK" "RELEASE-FOREGROUND" "WITH-NEW-SESSION" - "CURRENT-THREAD-ID")) + "WITH-RECURSIVE-LOCK" "RELEASE-FOREGROUND" "WITH-NEW-SESSION")) #s(sb-cold:package-data :name "SB!LOOP" diff --git a/src/code/cold-init.lisp b/src/code/cold-init.lisp index 1e31f57..8e332ce 100644 --- a/src/code/cold-init.lisp +++ b/src/code/cold-init.lisp @@ -213,6 +213,7 @@ (show-and-call os-cold-init-or-reinit) + (show-and-call thread-init-or-reinit) (show-and-call stream-cold-init-or-reset) (show-and-call !loader-cold-init) (show-and-call !foreign-cold-init) @@ -259,7 +260,6 @@ (terpri) (/show0 "going into toplevel loop") (handling-end-of-the-world - (thread-init-or-reinit) (toplevel-init) (critically-unreachable "after TOPLEVEL-INIT"))) @@ -278,6 +278,7 @@ UNIX-like systems, UNIX-STATUS is used as the status code." ;;;; initialization functions (defun thread-init-or-reinit () + (sb!thread::init-initial-thread) (sb!thread::init-job-control) (sb!thread::get-foreground)) @@ -285,6 +286,7 @@ UNIX-like systems, UNIX-STATUS is used as the status code." (without-interrupts (without-gcing (os-cold-init-or-reinit) + (thread-init-or-reinit) (stream-reinit) (signal-cold-init-or-reinit) (setf (sb!alien:extern-alien "internal_errors_enabled" boolean) t) @@ -297,7 +299,6 @@ UNIX-like systems, UNIX-STATUS is used as the status code." ;; call site. (set-floating-point-modes :traps '(:overflow #!-netbsd :invalid :divide-by-zero)))) - (thread-init-or-reinit) (gc-reinit) ;; make sure TIME works correctly from saved cores (setf *internal-real-time-base-seconds* nil) diff --git a/src/code/debug.lisp b/src/code/debug.lisp index 7ce7153..964b07a 100644 --- a/src/code/debug.lisp +++ b/src/code/debug.lisp @@ -530,7 +530,7 @@ reset to ~S." "~2&~@~%" (type-of *debug-condition*) - (sb!thread:current-thread-id) + sb!thread:*current-thread* *debug-condition*) (error (condition) (setf *nested-debug-condition* condition) @@ -606,7 +606,7 @@ reset to ~S." (format *error-output* "~&~@~2%" (type-of condition) - (sb!thread:current-thread-id) + sb!thread:*current-thread* condition) ;; Flush *ERROR-OUTPUT* even before the BACKTRACE, so that ;; even if we hit an error within BACKTRACE (e.g. a bug in diff --git a/src/code/early-impl.lisp b/src/code/early-impl.lisp index 84fdee8..3058fcf 100644 --- a/src/code/early-impl.lisp +++ b/src/code/early-impl.lisp @@ -22,7 +22,6 @@ sb!vm::*current-catch-block* sb!vm::*current-unwind-protect-block* sb!vm::*alien-stack* - #!+sb-thread sb!thread::*foreground-thread-stack* sb!vm::*control-stack-start* sb!vm::*control-stack-end* sb!vm::*binding-stack-start* diff --git a/src/code/early-thread.lisp b/src/code/early-thread.lisp new file mode 100644 index 0000000..bbdce56 --- /dev/null +++ b/src/code/early-thread.lisp @@ -0,0 +1,12 @@ +;;;; This software is part of the SBCL system. See the README file for +;;;; more information. +;;;; +;;;; This software is derived from the CMU CL system, which was +;;;; written at Carnegie Mellon University and released into the +;;;; public domain. The software is in the public domain and is +;;;; provided with absolutely no warranty. See the COPYING and CREDITS +;;;; files for more information. + +(in-package "SB!THREAD") + +(defvar *current-thread*) diff --git a/src/code/exhaust.lisp b/src/code/exhaust.lisp index 6724c66..7c6ec72 100644 --- a/src/code/exhaust.lisp +++ b/src/code/exhaust.lisp @@ -14,11 +14,8 @@ (define-alien-routine ("protect_control_stack_guard_page" %protect-control-stack-guard-page) sb!alien:void - (thread-id #!+sb-thread sb!alien:unsigned-long - #!-sb-thread sb!alien:int) + (thread-sap system-area-pointer) (protect-p sb!alien:int)) (defun protect-control-stack-guard-page (n) (%protect-control-stack-guard-page - (sb!thread:current-thread-id) (if n 1 0))) - - + (sb!thread::thread-%sap sb!thread:*current-thread*) (if n 1 0))) diff --git a/src/code/gc.lisp b/src/code/gc.lisp index 43c2b07..1acfa9c 100644 --- a/src/code/gc.lisp +++ b/src/code/gc.lisp @@ -208,8 +208,8 @@ environment these hooks may run in any thread.") (sb!thread:make-mutex :name "GC lock") "ID of thread running SUB-GC") (defun sub-gc (&key (gen 0)) - (unless (eql (sb!thread:current-thread-id) - (sb!thread::mutex-value *already-in-gc*)) + (unless (eq sb!thread:*current-thread* + (sb!thread::mutex-value *already-in-gc*)) ;; With gencgc, unless *NEED-TO-COLLECT-GARBAGE* every allocation ;; in this function triggers another gc, potentially exceeding ;; maximum interrupt nesting. @@ -235,8 +235,7 @@ environment these hooks may run in any thread.") ;; current belief is that it is part of the normal order ;; of things and not a bug. (when (plusp freed) - (incf *n-bytes-freed-or-purified* freed))) - (sb!thread::reap-dead-threads))) + (incf *n-bytes-freed-or-purified* freed))))) ;; Outside the mutex, these may cause another GC. FIXME: it can ;; potentially exceed maximum interrupt nesting by triggering ;; GCs. @@ -298,4 +297,3 @@ environment these hooks may run in any thread.") "Disable the garbage collector." (setq *gc-inhibit* 1) nil) - diff --git a/src/code/target-multithread.lisp b/src/code/target-multithread.lisp new file mode 100644 index 0000000..ce284ad --- /dev/null +++ b/src/code/target-multithread.lisp @@ -0,0 +1,387 @@ +;;;; support for threads in the target machine + +;;;; This software is part of the SBCL system. See the README file for +;;;; more information. +;;;; +;;;; This software is derived from the CMU CL system, which was +;;;; written at Carnegie Mellon University and released into the +;;;; public domain. The software is in the public domain and is +;;;; provided with absolutely no warranty. See the COPYING and CREDITS +;;;; files for more information. + +(in-package "SB!THREAD") + +(define-alien-routine ("create_thread" %create-thread) + system-area-pointer + (lisp-fun-address unsigned-long)) + +(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 +(declaim (inline get-spinlock release-spinlock)) + +(defun get-spinlock (lock offset new-value) + (declare (optimize (speed 3) (safety 0))) + ;; %instance-set-conditional can test for 0 (which is a fixnum) and + ;; store any value + (loop until + (eql (sb!vm::%instance-set-conditional lock offset 0 new-value) 0))) + +(defun release-spinlock (lock offset) + (declare (optimize (speed 3) (safety 0))) + ;; %instance-set-conditional cannot compare arbitrary objects + ;; meaningfully, so + ;; (sb!vm::%instance-set-conditional lock offset our-value 0) + ;; does not work for bignum thread ids. + (sb!vm::%instance-set lock offset 0)) + +(defmacro with-spinlock ((queue) &body body) + `(unwind-protect + (progn + (get-spinlock ,queue 2 *current-thread*) + ,@body) + (release-spinlock ,queue 2))) + + +;;;; the higher-level locking operations are based on waitqueues + +(declaim (inline waitqueue-data-address mutex-value-address)) + +(defstruct waitqueue + (name nil :type (or null simple-string)) + (lock 0) + (data nil)) + +;;; The bare 4 here and 5 below are offsets of the slots in the struct. +;;; There ought to be some better way to get these numbers +(defun waitqueue-data-address (lock) + (declare (optimize (speed 3))) + (sb!ext:truly-the + (unsigned-byte 32) + (+ (sb!kernel:get-lisp-obj-address lock) + (- (* 4 sb!vm:n-word-bytes) sb!vm:instance-pointer-lowtag)))) + +(defstruct (mutex (:include waitqueue)) + (value nil)) + +(defun mutex-value-address (lock) + (declare (optimize (speed 3))) + (sb!ext:truly-the + (unsigned-byte 32) + (+ (sb!kernel:get-lisp-obj-address lock) + (- (* 5 sb!vm:n-word-bytes) sb!vm:instance-pointer-lowtag)))) + +(declaim (inline futex-wait futex-wake)) +(sb!alien:define-alien-routine + "futex_wait" int (word unsigned-long) (old-value unsigned-long)) +(sb!alien:define-alien-routine + "futex_wake" int (word unsigned-long) (n unsigned-long)) + + +;;;; mutex + +(defun get-mutex (lock &optional new-value (wait-p t)) + "Acquire LOCK, setting it to NEW-VALUE or some suitable default value +if NIL. If WAIT-P is non-NIL and the lock is in use, sleep until it +is available" + (declare (type mutex lock) (optimize (speed 3))) + (let (old) + (unless new-value (setf new-value *current-thread*)) + (when (eql new-value (mutex-value lock)) + (warn "recursive lock attempt ~S~%" lock) + (format *debug-io* "Thread: ~A~%" *current-thread*) + (sb!debug:backtrace most-positive-fixnum *debug-io*) + (force-output *debug-io*)) + (loop + (unless + (setf old (sb!vm::%instance-set-conditional lock 4 nil new-value)) + (return t)) + (unless wait-p (return nil)) + (futex-wait (mutex-value-address lock) + (sb!kernel:get-lisp-obj-address old))))) + +(defun release-mutex (lock) + (declare (type mutex lock)) + (setf (mutex-value lock) nil) + (futex-wake (mutex-value-address lock) 1)) + +;;;; condition variables + +(defun condition-wait (queue lock) + "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." + (assert lock) + (let ((value (mutex-value lock))) + (unwind-protect + (let ((me *current-thread*)) + ;; XXX we should do something to ensure that the result of this setf + ;; is visible to all CPUs + (setf (waitqueue-data queue) me) + (release-mutex lock) + ;; Now we go to sleep using futex-wait. If anyone else + ;; manages to grab LOCK and call CONDITION-NOTIFY during + ;; this comment, it will change queue->data, and so + ;; futex-wait returns immediately instead of sleeping. + ;; Ergo, no lost wakeup + (futex-wait (waitqueue-data-address queue) + (sb!kernel:get-lisp-obj-address me))) + ;; 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. + (get-mutex lock value)))) + +(defun condition-notify (queue) + "Notify one of the processes waiting on QUEUE" + (let ((me *current-thread*)) + ;; no problem if >1 thread notifies during the comment in + ;; condition-wait: as long as the value in queue-data isn't the + ;; waiting thread's id, it matters not what it is + ;; XXX we should do something to ensure that the result of this setf + ;; is visible to all CPUs + (setf (waitqueue-data queue) me) + (futex-wake (waitqueue-data-address queue) 1))) + +(defun condition-broadcast (queue) + (let ((me *current-thread*)) + (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::%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 + (lock (make-mutex :name "session lock")) + (threads nil) + (interactive-threads nil) + (interactive-threads-queue (make-waitqueue))) + +(defun new-session () + (make-session :threads (list *current-thread*) + :interactive-threads (list *current-thread*))) + +(defun init-job-control () + (setf *session* (new-session))) + +(defun %delete-thread-from-session (thread session) + (with-mutex ((session-lock session)) + (setf (session-threads session) + (delete thread (session-threads session)) + (session-interactive-threads session) + (delete thread (session-interactive-threads session))))) + +(defun call-with-new-session (fn) + (%delete-thread-from-session *current-thread* *session*) + (let ((*session* (new-session))) + (funcall fn))) + +(defmacro with-new-session (args &body forms) + (declare (ignore args)) ;for extensibility + (sb!int:with-unique-names (fb-name) + `(labels ((,fb-name () ,@forms)) + (call-with-new-session (function ,fb-name))))) + +;;; Remove thread from its session, if it has one. +(defun handle-thread-exit (thread) + (with-mutex (*all-threads-lock*) + (setq *all-threads* (delete thread *all-threads*))) + (when *session* + (%delete-thread-from-session thread *session*))) + +(defun terminate-session () + "Kill all threads in session except for this one. Does nothing if current +thread is not the foreground thread" + ;; FIXME: threads created in other threads may escape termination + (let ((to-kill + (with-mutex ((session-lock *session*)) + (and (eq *current-thread* + (car (session-interactive-threads *session*))) + (session-threads *session*))))) + ;; do the kill after dropping the mutex; unwind forms in dying + ;; threads may want to do session things + (dolist (thread to-kill) + (unless (eq thread *current-thread*) + ;; terminate the thread but don't be surprised if it has + ;; exited in the meantime + (handler-case (terminate-thread thread) + (interrupt-thread-error ())))))) + +;;; called from top of invoke-debugger +(defun debugger-wait-until-foreground-thread (stream) + "Returns T if thread had been running in background, NIL if it was +interactive." + (declare (ignore stream)) + (prog1 + (with-mutex ((session-lock *session*)) + (not (member *current-thread* + (session-interactive-threads *session*)))) + (get-foreground))) + +(defun get-foreground () + (let ((was-foreground t)) + (loop + (with-mutex ((session-lock *session*)) + (let ((int-t (session-interactive-threads *session*))) + (when (eq (car int-t) *current-thread*) + (unless was-foreground + (format *query-io* "Resuming thread ~A~%" *current-thread*)) + (return-from get-foreground t)) + (setf was-foreground nil) + (unless (member *current-thread* int-t) + (setf (cdr (last int-t)) + (list *current-thread*))) + (condition-wait + (session-interactive-threads-queue *session*) + (session-lock *session*))))))) + +(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*)) + (setf (session-interactive-threads *session*) + (delete *current-thread* (session-interactive-threads *session*))) + (when next + (setf (session-interactive-threads *session*) + (list* next + (delete next (session-interactive-threads *session*))))) + (condition-broadcast (session-interactive-threads-queue *session*)))) + +(defun foreground-thread () + (car (session-interactive-threads *session*))) + +(defun make-listener-thread (tty-name) + (assert (probe-file tty-name)) + (let* ((in (sb!unix:unix-open (namestring tty-name) sb!unix:o_rdwr #o666)) + (out (sb!unix:unix-dup in)) + (err (sb!unix:unix-dup in))) + (labels ((thread-repl () + (sb!unix::unix-setsid) + (let* ((sb!impl::*stdin* + (sb!sys:make-fd-stream in :input t :buffering :line + :dual-channel-p t)) + (sb!impl::*stdout* + (sb!sys:make-fd-stream out :output t :buffering :line + :dual-channel-p t)) + (sb!impl::*stderr* + (sb!sys:make-fd-stream err :output t :buffering :line + :dual-channel-p t)) + (sb!impl::*tty* + (sb!sys:make-fd-stream err :input t :output t + :buffering :line + :dual-channel-p t)) + (sb!impl::*descriptor-handlers* nil)) + (with-new-session () + (unwind-protect + (sb!impl::toplevel-repl nil) + (sb!int:flush-standard-output-streams)))))) + (make-thread #'thread-repl)))) diff --git a/src/code/target-signal.lisp b/src/code/target-signal.lisp index d358486..b627bd9 100644 --- a/src/code/target-signal.lisp +++ b/src/code/target-signal.lisp @@ -44,6 +44,8 @@ ;;; When inappropriate build options are used, this also prints messages ;;; listing the signals that were masked (sb!alien:define-alien-routine "reset_signal_mask" sb!alien:void) + +(sb!alien:define-alien-routine "block_blockable_signals" sb!alien:void) ;;;; C routines that actually do all the work of establishing signal handlers (sb!alien:define-alien-routine ("install_handler" install-handler) @@ -85,7 +87,7 @@ (defun sigint-%break (format-string &rest format-arguments) #!+sb-thread (let ((foreground-thread (sb!thread::foreground-thread))) - (if (eql foreground-thread (sb!thread:current-thread-id)) + (if (eq foreground-thread sb!thread:*current-thread*) (apply #'%break 'sigint format-string format-arguments) (sb!thread:interrupt-thread foreground-thread diff --git a/src/code/target-thread.lisp b/src/code/target-thread.lisp index 307af53..176eeb6 100644 --- a/src/code/target-thread.lisp +++ b/src/code/target-thread.lisp @@ -1,4 +1,5 @@ -;;;; support for threads in the target machine +;;;; support for threads in the target machine common to uni- and +;;;; multithread systems ;;;; This software is part of the SBCL system. See the README file for ;;;; more information. @@ -11,384 +12,72 @@ (in-package "SB!THREAD") -;;; FIXME it would be good to define what a thread id is or isn't (our -;;; current assumption is that it's a fixnum). It so happens that on -;;; Linux it's a pid, but it might not be on posix thread implementations - -(define-alien-routine ("create_thread" %create-thread) - unsigned-long - (lisp-fun-address unsigned-long)) - -(define-alien-routine reap-dead-threads void) - -(defvar *session* nil) - -;;;; 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))) - ;; %instance-set-conditional can test for 0 (which is a fixnum) and - ;; store any value - (loop until - (eql (sb!vm::%instance-set-conditional lock offset 0 new-value) 0))) - -(defun release-spinlock (lock offset) - (declare (optimize (speed 3) (safety 0))) - ;; %instance-set-conditional cannot compare arbitrary objects - ;; meaningfully, so - ;; (sb!vm::%instance-set-conditional lock offset our-value 0) - ;; does not work for bignum thread ids. - (sb!vm::%instance-set lock offset 0)) - -(defmacro with-spinlock ((queue) &body body) - (with-unique-names (pid) - `(let ((,pid (current-thread-id))) - (unwind-protect - (progn - (get-spinlock ,queue 2 ,pid) - ,@body) - (release-spinlock ,queue 2))))) - - -;;;; the higher-level locking operations are based on waitqueues - -(declaim (inline waitqueue-data-address mutex-value-address)) - -(defstruct waitqueue - (name nil :type (or null simple-string)) - (lock 0) - (data nil)) - -;;; The bare 4 here and 5 below are offsets of the slots in the struct. -;;; There ought to be some better way to get these numbers -(defun waitqueue-data-address (lock) - (declare (optimize (speed 3))) - (sb!ext:truly-the - (unsigned-byte 32) - (+ (sb!kernel:get-lisp-obj-address lock) - (- (* 4 sb!vm:n-word-bytes) sb!vm:instance-pointer-lowtag)))) - -(defstruct (mutex (:include waitqueue)) - (value nil)) - -(defun mutex-value-address (lock) - (declare (optimize (speed 3))) - (sb!ext:truly-the - (unsigned-byte 32) - (+ (sb!kernel:get-lisp-obj-address lock) - (- (* 5 sb!vm:n-word-bytes) sb!vm:instance-pointer-lowtag)))) - -(declaim (inline futex-wait futex-wake)) -(sb!alien:define-alien-routine - "futex_wait" int (word unsigned-long) (old-value unsigned-long)) -(sb!alien:define-alien-routine - "futex_wake" int (word unsigned-long) (n unsigned-long)) - - -;;;; mutex - -(defun get-mutex (lock &optional new-value (wait-p t)) - "Acquire LOCK, setting it to NEW-VALUE or some suitable default value -if NIL. If WAIT-P is non-NIL and the lock is in use, sleep until it -is available" - (declare (type mutex lock) (optimize (speed 3))) - (let ((pid (current-thread-id)) - old) - (unless new-value (setf new-value pid)) - (when (eql new-value (mutex-value lock)) - (warn "recursive lock attempt ~S~%" lock)) - (loop - (unless - (setf old (sb!vm::%instance-set-conditional lock 4 nil new-value)) - (return t)) - (unless wait-p (return nil)) - (futex-wait (mutex-value-address lock) - (sb!kernel:get-lisp-obj-address old))))) - -(defun release-mutex (lock) - (declare (type mutex lock)) - (setf (mutex-value lock) nil) - (futex-wake (mutex-value-address lock) 1)) - -;;;; condition variables - -(defun condition-wait (queue lock) - "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." - (assert lock) - (let ((value (mutex-value lock))) - (unwind-protect - (let ((me (current-thread-id))) - ;; XXX we should do something to ensure that the result of this setf - ;; is visible to all CPUs - (setf (waitqueue-data queue) me) - (release-mutex lock) - ;; Now we go to sleep using futex-wait. If anyone else - ;; manages to grab LOCK and call CONDITION-NOTIFY during - ;; this comment, it will change queue->data, and so - ;; futex-wait returns immediately instead of sleeping. - ;; Ergo, no lost wakeup - (futex-wait (waitqueue-data-address queue) - (sb!kernel:get-lisp-obj-address me))) - ;; 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. - (get-mutex lock value)))) - - -(defun condition-notify (queue) - "Notify one of the processes waiting on QUEUE" - (let ((me (current-thread-id))) - ;; no problem if >1 thread notifies during the comment in - ;; condition-wait: as long as the value in queue-data isn't the - ;; waiting thread's id, it matters not what it is - ;; XXX we should do something to ensure that the result of this setf - ;; is visible to all CPUs - (setf (waitqueue-data queue) me) - (futex-wake (waitqueue-data-address queue) 1))) - -(defun condition-broadcast (queue) - (let ((me (current-thread-id))) - (setf (waitqueue-data queue) me) - (futex-wake (waitqueue-data-address queue) (ash 1 30)))) - -(defun make-thread (function) - (let* ((real-function (coerce function 'function)) - (tid - (%create-thread - (sb!kernel:get-lisp-obj-address - (lambda () - ;; 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) - (catch 'sb!impl::%end-of-the-world - (with-simple-restart - (terminate-thread - (format nil "~~@" - (current-thread-id))) - ;; 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) - (funcall real-function)) - 0)) - (values)))))) - (when (zerop tid) (error "Can't create a new thread")) - (with-mutex ((session-lock *session*)) - (pushnew tid (session-threads *session*))) - tid)) - -(defun destroy-thread (thread-id) - "Deprecated. Soon to be removed or reimplemented using pthread_cancel." - (terminate-thread thread-id)) - -;;; 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 - -(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" - 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 -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 () +(defstruct (thread (:constructor %make-thread)) + name + %sap) + +(def!method print-object ((thread thread) stream) + (if (thread-name thread) + (print-unreadable-object (thread stream :type t :identity t) + (prin1 (thread-name thread) stream)) + (print-unreadable-object (thread stream :type t :identity t) + ;; body is empty => there is only one space between type and + ;; identity + )) + thread) + +(defun thread-state (thread) + (let ((state + (sb!kernel:make-lisp-obj + (sb!sys:sap-int + (sb!sys:sap-ref-sap (thread-%sap thread) + (* sb!vm::thread-state-slot + sb!vm::n-word-bytes)))))) + (ecase state + (0 :starting) + (1 :running) + (2 :suspended) + (3 :dead)))) + +(defun %set-thread-state (thread state) + (setf (sb!sys:sap-ref-sap (thread-%sap thread) + (* sb!vm::thread-state-slot + sb!vm::n-word-bytes)) + (sb!sys:int-sap + (sb!kernel:get-lisp-obj-address + (ecase state + (:starting 0) + (:running 1) + (:suspended 2) + (:dead 3)))))) + +(defun thread-alive-p (thread) + (not (eq :dead (thread-state thread)))) + +;; A thread is eligible for gc iff it has finished and there are no +;; more references to it. This list is supposed to keep a reference to +;; all running threads. +(defvar *all-threads* ()) +(defvar *all-threads-lock* (make-mutex :name "all threads lock")) + +(defun list-all-threads () + (with-mutex (*all-threads-lock*) + (copy-list *all-threads*))) + +(declaim (inline current-thread-sap)) +(defun current-thread-sap () + (sb!vm::current-thread-offset-sap sb!vm::thread-this-slot)) + +(declaim (inline current-thread-sap-id)) +(defun current-thread-sap-id () (sb!sys:sap-int (sb!vm::current-thread-offset-sap sb!vm::thread-os-thread-slot))) -;;;; iterate over the in-memory threads - -(defun mapcar-threads (function) - "Call FUNCTION once for each known thread, giving it the thread structure as argument" - (let ((function (coerce function 'function))) - (loop for thread = (alien-sap (extern-alien "all_threads" (* t))) - then (sb!sys:sap-ref-sap thread (* sb!vm:n-word-bytes - sb!vm::thread-next-slot)) - until (sb!sys:sap= thread (sb!sys:int-sap 0)) - collect (funcall function thread)))) - -(defun thread-sap-from-id (id) - (let ((thread (alien-sap (extern-alien "all_threads" (* t))))) - (loop - (when (sb!sys:sap= thread (sb!sys:int-sap 0)) (return nil)) - ;; FIXME: 32/64 bit - (let ((pid (sb!sys:sap-ref-32 thread (* sb!vm:n-word-bytes - sb!vm::thread-os-thread-slot)))) - (when (= pid id) (return thread)) - (setf thread (sb!sys:sap-ref-sap thread (* sb!vm:n-word-bytes - sb!vm::thread-next-slot))))))) - -;;; 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-id) - (let ((thread (thread-sap-from-id thread-id))) - (when thread - (let* ((index (sb!vm::symbol-tls-index symbol)) - (tl-val (sb!sys:sap-ref-word thread - (* 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 - (lock (make-mutex :name "session lock")) - (threads nil) - (interactive-threads nil) - (interactive-threads-queue (make-waitqueue))) - -(defun new-session () - (let ((tid (current-thread-id))) - (make-session :threads (list tid) - :interactive-threads (list tid)))) - -(defun init-job-control () - (setf *session* (new-session))) - -(defun %delete-thread-from-session (tid session) - (with-mutex ((session-lock session)) - (setf (session-threads session) - (delete tid (session-threads session)) - (session-interactive-threads session) - (delete tid (session-interactive-threads session))))) - -(defun call-with-new-session (fn) - (%delete-thread-from-session (current-thread-id) *session*) - (let ((*session* (new-session))) (funcall fn))) - -(defmacro with-new-session (args &body forms) - (declare (ignore args)) ;for extensibility - (sb!int:with-unique-names (fb-name) - `(labels ((,fb-name () ,@forms)) - (call-with-new-session (function ,fb-name))))) - -;;; Remove thread id TID from its session, if it has one. This is -;;; called from C mark_thread_dead(). -(defun handle-thread-exit (tid) - (when *session* - (%delete-thread-from-session tid *session*))) - -(defun terminate-session () - "Kill all threads in session except for this one. Does nothing if current -thread is not the foreground thread" - (reap-dead-threads) - ;; FIXME: threads created in other threads may escape termination - (let* ((tid (current-thread-id)) - (to-kill - (with-mutex ((session-lock *session*)) - (and (eql tid (car (session-interactive-threads *session*))) - (session-threads *session*))))) - ;; do the kill after dropping the mutex; unwind forms in dying - ;; threads may want to do session things - (dolist (p to-kill) - (unless (eql p tid) - ;; terminate the thread but don't be surprised if it has - ;; exited in the meantime - (handler-case (terminate-thread p) - (interrupt-thread-error ())))))) - -;;; called from top of invoke-debugger -(defun debugger-wait-until-foreground-thread (stream) - "Returns T if thread had been running in background, NIL if it was -interactive." - (declare (ignore stream)) - (prog1 - (with-mutex ((session-lock *session*)) - (not (member (current-thread-id) - (session-interactive-threads *session*)))) - (get-foreground))) - - -(defun get-foreground () - (let ((was-foreground t)) - (loop - (with-mutex ((session-lock *session*)) - (let ((tid (current-thread-id)) - (int-t (session-interactive-threads *session*))) - (when (eql (car int-t) tid) - (unless was-foreground - (format *query-io* "Resuming thread ~A~%" tid)) - (return-from get-foreground t)) - (setf was-foreground nil) - (unless (member tid int-t) - (setf (cdr (last int-t)) - (list tid))) - (condition-wait - (session-interactive-threads-queue *session*) - (session-lock *session*))))))) - -(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*)) - (let ((tid (current-thread-id))) - (setf (session-interactive-threads *session*) - (delete tid (session-interactive-threads *session*))) - (when next - (setf (session-interactive-threads *session*) - (list* next - (delete next (session-interactive-threads *session*))))) - (condition-broadcast (session-interactive-threads-queue *session*))))) - -(defun foreground-thread () - (car (session-interactive-threads *session*))) - -(defun make-listener-thread (tty-name) - (assert (probe-file tty-name)) - (let* ((in (sb!unix:unix-open (namestring tty-name) sb!unix:o_rdwr #o666)) - (out (sb!unix:unix-dup in)) - (err (sb!unix:unix-dup in))) - (labels ((thread-repl () - (sb!unix::unix-setsid) - (let* ((sb!impl::*stdin* - (sb!sys:make-fd-stream in :input t :buffering :line :dual-channel-p t)) - (sb!impl::*stdout* - (sb!sys:make-fd-stream out :output t :buffering :line :dual-channel-p t)) - (sb!impl::*stderr* - (sb!sys:make-fd-stream err :output t :buffering :line :dual-channel-p t)) - (sb!impl::*tty* - (sb!sys:make-fd-stream err :input t :output t :buffering :line :dual-channel-p t)) - (sb!impl::*descriptor-handlers* nil)) - (with-new-session () - (unwind-protect - (sb!impl::toplevel-repl nil) - (sb!int:flush-standard-output-streams)))))) - (make-thread #'thread-repl)))) +(defun init-initial-thread () + (let ((initial-thread (%make-thread :name "initial thread" + :%sap (current-thread-sap)))) + (setq *current-thread* initial-thread) + ;; Either *all-threads* is empty or it contains exactly one thread + ;; in case we are in reinit since saving core with multiple + ;; threads doesn't work. + (setq *all-threads* (list initial-thread)))) diff --git a/src/code/target-unithread.lisp b/src/code/target-unithread.lisp index 3005dee..1d5a494 100644 --- a/src/code/target-unithread.lisp +++ b/src/code/target-unithread.lisp @@ -13,19 +13,12 @@ ;;; used bu debug-int.lisp to access interrupt contexts #!-sb-fluid (declaim (inline sb!vm::current-thread-offset-sap)) -(defun sb!vm::current-thread-offset-sap (n) +(defun sb!vm::current-thread-offset-sap (n) (declare (type (unsigned-byte 27) n)) - (sb!sys:sap-ref-sap (alien-sap (extern-alien "all_threads" (* t))) - (* n sb!vm:n-word-bytes))) + (sb!sys:sap-ref-sap (alien-sap (extern-alien "all_threads" (* t))) + (* n sb!vm:n-word-bytes))) -(defun current-thread-id () - ;; FIXME: 32/64 - (sb!sys:sap-ref-32 (alien-sap (extern-alien "all_threads" (* t))) - (* sb!vm::thread-os-thread-slot sb!vm:n-word-bytes))) - -(defun reap-dead-threads ()) - -;;;; queues, locks +;;;; queues, locks ;; spinlocks use 0 as "free" value: higher-level locks use NIL (defun get-spinlock (lock offset new-value) @@ -53,7 +46,7 @@ (when (and old-value wait-p) (error "In unithread mode, mutex ~S was requested with WAIT-P ~S and ~ new-value ~S, but has already been acquired (with value ~S)." - lock wait-p new-value old-value)) + lock wait-p new-value old-value)) (setf (mutex-value lock) new-value) t)) @@ -62,7 +55,7 @@ (setf (mutex-value lock) nil)) -;; FIXME need suitable stub or ERROR-signaling definitions for +;; FIXME need suitable stub or ERROR-signaling definitions for ;; condition-wait (queue lock) ;; condition-notify (queue) diff --git a/src/code/thread.lisp b/src/code/thread.lisp index 1e622ce..19f14be 100644 --- a/src/code/thread.lisp +++ b/src/code/thread.lisp @@ -53,4 +53,3 @@ (release-mutex ,mutex))))) #!-sb-thread `(locally ,@body)) - diff --git a/src/compiler/generic/genesis.lisp b/src/compiler/generic/genesis.lisp index 4da74cc..2befcac 100644 --- a/src/compiler/generic/genesis.lisp +++ b/src/compiler/generic/genesis.lisp @@ -1276,8 +1276,7 @@ core and return a descriptor to it." (frob sb!kernel::undefined-alien-function-error) (frob sb!kernel::memory-fault-error) (frob sb!di::handle-breakpoint) - (frob sb!di::handle-fun-end-breakpoint) - (frob sb!thread::handle-thread-exit)) + (frob sb!di::handle-fun-end-breakpoint)) (cold-set 'sb!vm::*current-catch-block* (make-fixnum-descriptor 0)) (cold-set 'sb!vm::*current-unwind-protect-block* (make-fixnum-descriptor 0)) diff --git a/src/compiler/generic/objdef.lisp b/src/compiler/generic/objdef.lisp index eeab36c..716589e 100644 --- a/src/compiler/generic/objdef.lisp +++ b/src/compiler/generic/objdef.lisp @@ -377,7 +377,8 @@ (this :c-type "struct thread *" :length #!+alpha 2 #!-alpha 1) (prev :c-type "struct thread *" :length #!+alpha 2 #!-alpha 1) (next :c-type "struct thread *" :length #!+alpha 2 #!-alpha 1) - (state) ; running, stopping, stopped, dead + ;; starting, running, suspended, dead + (state) #!+(or x86 x86-64) (pseudo-atomic-atomic) #!+(or x86 x86-64) (pseudo-atomic-interrupted) (interrupt-fun) diff --git a/src/compiler/x86-64/parms.lisp b/src/compiler/x86-64/parms.lisp index d03dc9b..485ab17 100644 --- a/src/compiler/x86-64/parms.lisp +++ b/src/compiler/x86-64/parms.lisp @@ -168,7 +168,6 @@ sb!kernel::memory-fault-error sb!di::handle-breakpoint fdefinition-object - #!+sb-thread sb!thread::handle-thread-exit ;; free pointers ;; diff --git a/src/compiler/x86/parms.lisp b/src/compiler/x86/parms.lisp index 6c8850e..35d1b4a 100644 --- a/src/compiler/x86/parms.lisp +++ b/src/compiler/x86/parms.lisp @@ -274,7 +274,6 @@ sb!kernel::memory-fault-error sb!di::handle-breakpoint fdefinition-object - #!+sb-thread sb!thread::handle-thread-exit ;; free pointers ;; diff --git a/src/pcl/low.lisp b/src/pcl/low.lisp index 8a58b8e..d7ee7a9 100644 --- a/src/pcl/low.lisp +++ b/src/pcl/low.lisp @@ -352,16 +352,11 @@ #+sb-thread (progn -(defstruct spinlock (value 0)) -(defvar *pcl-lock* (make-spinlock)) + (defvar *pcl-lock* (sb-thread:make-waitqueue)) -(defmacro with-pcl-lock (&body body) - `(progn - (sb-thread::get-spinlock *pcl-lock* 1 (sb-thread::current-thread-id)) - (unwind-protect - (progn ,@body) - (setf (spinlock-value *pcl-lock*) 0)))) -);progn + (defmacro with-pcl-lock (&body body) + `(sb-thread::with-spinlock (*pcl-lock*) + ,@body))) #-sb-thread (defmacro with-pcl-lock (&body body) diff --git a/src/runtime/gencgc.c b/src/runtime/gencgc.c index 0c0c98f..a425415 100644 --- a/src/runtime/gencgc.c +++ b/src/runtime/gencgc.c @@ -4154,8 +4154,10 @@ alloc(long nbytes) sigaddset_blockable(&new_mask); thread_sigmask(SIG_BLOCK,&new_mask,&old_mask); - if((!data->pending_handler) && - maybe_defer_handler(interrupt_maybe_gc_int,data,0,0,0)) { + if(!data->pending_handler) { + if(!maybe_defer_handler(interrupt_maybe_gc_int,data,0,0,0)) + lose("Not in atomic: %d.\n", + SymbolValue(PSEUDO_ATOMIC_ATOMIC,thread)); /* Leave the signals blocked just as if it was * deferred the normal way and set the * pending_mask. */ diff --git a/src/runtime/interrupt.c b/src/runtime/interrupt.c index ac1abcf..5164c30 100644 --- a/src/runtime/interrupt.c +++ b/src/runtime/interrupt.c @@ -75,8 +75,6 @@ static void store_signal_data_for_later (struct interrupt_data *data, os_context_t *context); boolean interrupt_maybe_gc_int(int signal, siginfo_t *info, void *v_context); -extern volatile lispobj all_threads_lock; - void sigaddset_blockable(sigset_t *s) { sigaddset(s, SIGHUP); @@ -150,7 +148,13 @@ void reset_signal_mask () thread_sigmask(SIG_SETMASK,&new,0); } - +void block_blockable_signals () +{ + sigset_t block; + sigemptyset(&block); + sigaddset_blockable(&block); + thread_sigmask(SIG_BLOCK, &block, 0); +} /* @@ -261,10 +265,7 @@ undo_fake_foreign_function_call(os_context_t *context) { struct thread *thread=arch_os_get_current_thread(); /* Block all blockable signals. */ - sigset_t block; - sigemptyset(&block); - sigaddset_blockable(&block); - thread_sigmask(SIG_BLOCK, &block, 0); + block_blockable_signals(); /* going back into Lisp */ foreign_function_call_active = 0; @@ -639,16 +640,16 @@ sig_stop_for_gc_handler(int signal, siginfo_t *info, void *void_context) * good time to let the kernel reap any of our children in that * awful state, to stop them from being waited for indefinitely. * Userland reaping is done later when GC is finished */ - if(thread->state!=STATE_STOPPING) { - lose("sig_stop_for_gc_handler: wrong thread state: %ld\n", - fixnum_value(thread->state)); + if(thread->state!=STATE_RUNNING) { + lose("sig_stop_for_gc_handler: wrong thread state: %ld\n", + fixnum_value(thread->state)); } - thread->state=STATE_STOPPED; + thread->state=STATE_SUSPENDED; sigemptyset(&ss); sigaddset(&ss,SIG_STOP_FOR_GC); sigwaitinfo(&ss,0); - if(thread->state!=STATE_STOPPED) { - lose("sig_stop_for_gc_handler: wrong thread state on wakeup: %ld\n", + if(thread->state!=STATE_SUSPENDED) { + lose("sig_stop_for_gc_handler: wrong thread state on wakeup: %ld\n", fixnum_value(thread->state)); } thread->state=STATE_RUNNING; @@ -839,6 +840,9 @@ void interrupt_thread_handler(int num, siginfo_t *info, void *v_context) * thread interrupt execution is undefined. */ struct thread *th=arch_os_get_current_thread(); struct cons *c; + if (th->state != STATE_RUNNING) + lose("interrupt_thread_handler: thread %ld in wrong state: %d\n", + th->os_thread,fixnum_value(th->state)); get_spinlock(&th->interrupt_fun_lock,(long)th); c=((struct cons *)native_pointer(th->interrupt_fun)); arrange_return_to_lisp_function(context,c->car); @@ -869,8 +873,8 @@ boolean handle_guard_page_triggered(os_context_t *context,void *addr){ * protection so the error handler has some headroom, protect the * previous page so that we can catch returns from the guard page * and restore it. */ - protect_control_stack_guard_page(th->os_thread,0); - protect_control_stack_return_guard_page(th->os_thread,1); + protect_control_stack_guard_page(th,0); + protect_control_stack_return_guard_page(th,1); arrange_return_to_lisp_function (context, SymbolFunction(CONTROL_STACK_EXHAUSTED_ERROR)); @@ -882,8 +886,8 @@ boolean handle_guard_page_triggered(os_context_t *context,void *addr){ * unprotect this one. This works even if we somehow missed * the return-guard-page, and hit it on our way to new * exhaustion instead. */ - protect_control_stack_guard_page(th->os_thread,1); - protect_control_stack_return_guard_page(th->os_thread,0); + protect_control_stack_guard_page(th,1); + protect_control_stack_return_guard_page(th,0); return 1; } else if (addr >= undefined_alien_address && diff --git a/src/runtime/thread.c b/src/runtime/thread.c index a6b462f..6e3e978 100644 --- a/src/runtime/thread.c +++ b/src/runtime/thread.c @@ -28,10 +28,53 @@ int dynamic_values_bytes=4096*sizeof(lispobj); /* same for all threads */ struct thread *all_threads; volatile lispobj all_threads_lock; -volatile lispobj thread_start_lock; extern struct interrupt_data * global_interrupt_data; extern int linux_no_threads_p; +/* When trying to get all_threads_lock one should make sure that + * sig_stop_for_gc is not blocked. Else there would be a possible + * deadlock: gc locks it, other thread blocks signals, gc sends stop + * request to other thread and waits, other thread blocks on lock. */ +void check_sig_stop_for_gc_can_arrive_or_lose() +{ + /* Get the current sigmask, by blocking the empty set. */ + sigset_t empty,current; + sigemptyset(&empty); + thread_sigmask(SIG_BLOCK, &empty, ¤t); + if (sigismember(¤t,SIG_STOP_FOR_GC)) + lose("SIG_STOP_FOR_GC is blocked\n"); + if (SymbolValue(INTERRUPTS_ENABLED,arch_os_get_current_thread()) == NIL) + lose("interrupts disabled\n"); + if (arch_pseudo_atomic_atomic(NULL)) + lose("n pseudo atomic\n"); +} + +#ifdef QSHOW_SIGNALS +#define FSHOW_SIGNAL FSHOW +#else +#define FSHOW_SIGNAL(args) +#endif + +#define GET_ALL_THREADS_LOCK(name) \ + { \ + sigset_t _newset,_oldset; \ + sigemptyset(&_newset); \ + sigaddset_blockable(&_newset); \ + sigdelset(&_newset,SIG_STOP_FOR_GC); \ + thread_sigmask(SIG_BLOCK, &_newset, &_oldset); \ + check_sig_stop_for_gc_can_arrive_or_lose(); \ + FSHOW_SIGNAL((stderr,"/%s:waiting on lock=%ld, thread=%ld\n",name, \ + all_threads_lock,arch_os_get_current_thread()->os_thread)); \ + get_spinlock(&all_threads_lock,(long)arch_os_get_current_thread()); \ + FSHOW_SIGNAL((stderr,"/%s:got lock, thread=%ld\n", \ + name,arch_os_get_current_thread()->os_thread)); + +#define RELEASE_ALL_THREADS_LOCK(name) \ + FSHOW_SIGNAL((stderr,"/%s:released lock\n",name)); \ + release_spinlock(&all_threads_lock); \ + thread_sigmask(SIG_SETMASK,&_oldset,0); \ + } + int initial_thread_trampoline(struct thread *th) { @@ -54,14 +97,6 @@ initial_thread_trampoline(struct thread *th) } #ifdef LISP_FEATURE_SB_THREAD -void mark_thread_dead(struct thread *th) { - funcall1(SymbolFunction(HANDLE_THREAD_EXIT),alloc_number(th->os_thread)); - /* I hope it's safe for a thread to detach itself inside a - * cancellation cleanup */ - pthread_detach(th->os_thread); - th->state=STATE_DEAD; - /* FIXME: if gc hits here it will rip the stack from under us */ -} /* this is the first thing that runs in the child (which is why the * silly calling convention). Basically it calls the user's requested @@ -71,26 +106,22 @@ void mark_thread_dead(struct thread *th) { int new_thread_trampoline(struct thread *th) { - lispobj function,ret; + lispobj function; function = th->unbound_marker; th->unbound_marker = UNBOUND_MARKER_WIDETAG; - pthread_cleanup_push((void (*) (void *))mark_thread_dead,th); - if(arch_os_thread_init(th)==0) return 1; + if(arch_os_thread_init(th)==0) return 1; /* wait here until our thread is linked into all_threads: see below */ while(th->os_thread<1) sched_yield(); th->state=STATE_RUNNING; - ret = funcall0(function); - /* execute cleanup */ - pthread_cleanup_pop(1); - return ret; + return funcall0(function); } #endif /* LISP_FEATURE_SB_THREAD */ /* this is called from any other thread to create the new one, and - * initialize all parts of it that can be initialized from another - * thread + * initialize all parts of it that can be initialized from another + * thread */ struct thread * create_thread_struct(lispobj initial_function) { @@ -123,7 +154,7 @@ struct thread * create_thread_struct(lispobj initial_function) { int i; for(i=0;i<(dynamic_values_bytes/sizeof(lispobj));i++) per_thread->dynamic_values[i]=UNBOUND_MARKER_WIDETAG; - if(SymbolValue(FREE_TLS_INDEX,0)==UNBOUND_MARKER_WIDETAG) + if(SymbolValue(FREE_TLS_INDEX,0)==UNBOUND_MARKER_WIDETAG) SetSymbolValue (FREE_TLS_INDEX, make_fixnum(MAX_INTERRUPTS+ @@ -132,7 +163,7 @@ struct thread * create_thread_struct(lispobj initial_function) { #define STATIC_TLS_INIT(sym,field) \ ((struct symbol *)(sym-OTHER_POINTER_LOWTAG))->tls_index= \ make_fixnum(THREAD_SLOT_OFFSET_WORDS(field)) - + STATIC_TLS_INIT(BINDING_STACK_START,binding_stack_start); STATIC_TLS_INIT(BINDING_STACK_POINTER,binding_stack_pointer); STATIC_TLS_INIT(CONTROL_STACK_START,control_stack_start); @@ -176,7 +207,7 @@ struct thread * create_thread_struct(lispobj initial_function) { #ifndef LISP_FEATURE_SB_THREAD /* the tls-points-into-struct-thread trick is only good for threaded * sbcl, because unithread sbcl doesn't have tls. So, we copy the - * appropriate values from struct thread here, and make sure that + * appropriate values from struct thread here, and make sure that * we use the appropriate SymbolValue macros to access any of the * variable quantities from the C runtime. It's not quite OAOOM, * it just feels like it */ @@ -192,20 +223,20 @@ struct thread * create_thread_struct(lispobj initial_function) { current_binding_stack_pointer=th->binding_stack_pointer; current_control_stack_pointer=th->control_stack_start; #endif -#endif +#endif bind_variable(CURRENT_CATCH_BLOCK,make_fixnum(0),th); - bind_variable(CURRENT_UNWIND_PROTECT_BLOCK,make_fixnum(0),th); + bind_variable(CURRENT_UNWIND_PROTECT_BLOCK,make_fixnum(0),th); bind_variable(FREE_INTERRUPT_CONTEXT_INDEX,make_fixnum(0),th); bind_variable(INTERRUPT_PENDING, NIL,th); bind_variable(INTERRUPTS_ENABLED,T,th); th->interrupt_data = (struct interrupt_data *) os_validate(0,(sizeof (struct interrupt_data))); - if(all_threads) + if(all_threads) memcpy(th->interrupt_data, arch_os_get_current_thread()->interrupt_data, sizeof (struct interrupt_data)); - else + else memcpy(th->interrupt_data,global_interrupt_data, sizeof (struct interrupt_data)); @@ -215,12 +246,6 @@ struct thread * create_thread_struct(lispobj initial_function) { void link_thread(struct thread *th,os_thread_t kid_tid) { - sigset_t newset,oldset; - sigemptyset(&newset); - sigaddset_blockable(&newset); - thread_sigmask(SIG_BLOCK, &newset, &oldset); - - get_spinlock(&all_threads_lock,kid_tid); if (all_threads) all_threads->prev=th; th->next=all_threads; th->prev=0; @@ -229,12 +254,9 @@ void link_thread(struct thread *th,os_thread_t kid_tid) * all_threads_lock to ensure that we don't have >1 thread with * os_thread=0 on the list at once */ - protect_control_stack_guard_page(th->os_thread,1); + protect_control_stack_guard_page(th,1); /* child will not start until this is set */ th->os_thread=kid_tid; - release_spinlock(&all_threads_lock); - - thread_sigmask(SIG_SETMASK,&oldset,0); } void create_initial_thread(lispobj initial_function) { @@ -247,180 +269,185 @@ void create_initial_thread(lispobj initial_function) { } #ifdef LISP_FEATURE_SB_THREAD -os_thread_t create_thread(lispobj initial_function) { + +boolean create_os_thread(struct thread *th,os_thread_t *kid_tid) +{ + /* The new thread inherits the restrictive signal mask set here, + * and enables signals again when it is set up properly. */ + pthread_attr_t attr; + sigset_t newset,oldset; + boolean r=1; + sigemptyset(&newset); + sigaddset_blockable(&newset); + thread_sigmask(SIG_BLOCK, &newset, &oldset); + + if((pthread_attr_init(&attr)) || + (pthread_attr_setstack(&attr,th->control_stack_start, + THREAD_CONTROL_STACK_SIZE-16)) || + (pthread_create + (kid_tid,&attr,(void *(*)(void *))new_thread_trampoline,th))) + r=0; + thread_sigmask(SIG_SETMASK,&oldset,0); + return r; +} + +struct thread *create_thread(lispobj initial_function) { struct thread *th; os_thread_t kid_tid=0; - pthread_attr_t attr; + boolean success; if(linux_no_threads_p) return 0; + th=create_thread_struct(initial_function); if(th==0) return 0; -#ifdef QSHOW_SIGNALS - SHOW("create_thread:waiting on lock"); -#endif - get_spinlock(&thread_start_lock,arch_os_get_current_thread()->os_thread); -#ifdef QSHOW_SIGNALS - SHOW("create_thread:got lock"); -#endif - /* The new thread inherits the restrictive signal mask set here, - * and enables signals again when it is set up properly. */ - { - sigset_t newset,oldset; - sigemptyset(&newset); - sigaddset_blockable(&newset); - thread_sigmask(SIG_BLOCK, &newset, &oldset); - if((pthread_attr_init(&attr)) || - (pthread_attr_setstack(&attr,th->control_stack_start, - THREAD_CONTROL_STACK_SIZE-16)) || - (pthread_create - (&kid_tid,&attr,(void *(*)(void *))new_thread_trampoline,th))) - kid_tid=0; - thread_sigmask(SIG_SETMASK,&oldset,0); - } - if(kid_tid>0) { + + /* we must not be interrupted here after a successful + * create_os_thread, because the kid will be waiting for its + * thread struct to be linked */ + GET_ALL_THREADS_LOCK("create_thread") + + success=create_os_thread(th,&kid_tid); + if (success) link_thread(th,kid_tid); - /* it's started and initialized, it's safe to gc */ - release_spinlock(&thread_start_lock); -#ifdef QSHOW_SIGNALS - SHOW("create_thread:released lock"); -#endif - /* by now the kid might have already exited */ - return kid_tid; - } else { - release_spinlock(&thread_start_lock); -#ifdef QSHOW_SIGNALS - SHOW("create_thread:released lock(failure)"); -#endif + else os_invalidate((os_vm_address_t) th->control_stack_start, ((sizeof (lispobj)) * (th->control_stack_end-th->control_stack_start)) + BINDING_STACK_SIZE+ALIEN_STACK_SIZE+dynamic_values_bytes+ 32*SIGSTKSZ); - return 0; - } -} -#endif -struct thread *find_thread_by_os_thread(os_thread_t tid) -{ - struct thread *th; - for_each_thread(th) - if(th->os_thread==tid) return th; - return 0; + RELEASE_ALL_THREADS_LOCK("create_thread") + + if (success) + return th; + else + return 0; } +#endif #if defined LISP_FEATURE_SB_THREAD /* This is not needed unless #+SB-THREAD, as there's a trivial null * unithread definition. */ -void reap_dead_threads() +/* called from lisp from the thread object finalizer */ +void reap_dead_thread(struct thread *th) { - struct thread *th,*next,*prev=0; - th=all_threads; - while(th) { - next=th->next; - if(th->state==STATE_DEAD) { + if(th->state!=STATE_DEAD) + lose("thread %lx is not joinable, state=%d\n",th,th->state); #ifdef LISP_FEATURE_GENCGC - gc_alloc_update_page_tables(0, &th->alloc_region); -#endif - get_spinlock(&all_threads_lock,th->os_thread); - if(prev) prev->next=next; - else all_threads=next; - release_spinlock(&all_threads_lock); - if(th->tls_cookie>=0) arch_os_thread_cleanup(th); - os_invalidate((os_vm_address_t) th->control_stack_start, - ((sizeof (lispobj)) - * (th->control_stack_end-th->control_stack_start)) + - BINDING_STACK_SIZE+ALIEN_STACK_SIZE+dynamic_values_bytes+ - 32*SIGSTKSZ); - } else - prev=th; - th=next; + { + sigset_t newset,oldset; + sigemptyset(&newset); + sigaddset_blockable(&newset); + thread_sigmask(SIG_BLOCK, &newset, &oldset); + gc_alloc_update_page_tables(0, &th->alloc_region); + release_spinlock(&all_threads_lock); + thread_sigmask(SIG_SETMASK,&oldset,0); } +#endif + GET_ALL_THREADS_LOCK("reap_dead_thread") + FSHOW((stderr,"/reap_dead_thread: reaping %ld\n",th->os_thread)); + if(th->prev) + th->prev->next=th->next; + else all_threads=th->next; + if(th->next) + th->next->prev=th->prev; + RELEASE_ALL_THREADS_LOCK("reap_dead_thread") + if(th->tls_cookie>=0) arch_os_thread_cleanup(th); + gc_assert(pthread_join(th->os_thread,NULL)==0); + os_invalidate((os_vm_address_t) th->control_stack_start, + ((sizeof (lispobj)) + * (th->control_stack_end-th->control_stack_start)) + + BINDING_STACK_SIZE+ALIEN_STACK_SIZE+dynamic_values_bytes+ + 32*SIGSTKSZ); } -int interrupt_thread(os_thread_t tid, lispobj function) +int interrupt_thread(struct thread *th, lispobj function) { - struct thread *th; - for_each_thread(th) - if((th->os_thread==tid) && (th->state != STATE_DEAD)) { - /* In clone_threads, if A and B both interrupt C at approximately - * the same time, it does not matter: the second signal will be - * masked until the handler has returned from the first one. - * In pthreads though, we can't put the knowledge of what function - * to call into the siginfo, so we have to store it in the - * destination thread, and do it in such a way that A won't - * clobber B's interrupt. Hence this stupid linked list. - * - * This does depend on SIG_INTERRUPT_THREAD being queued - * (as POSIX RT signals are): we need to keep - * interrupt_fun data for exactly as many signals as are - * going to be received by the destination thread. - */ - struct cons *c; - int kill_status; - /* mask the signals in case this thread is being interrupted */ - sigset_t newset,oldset; - sigemptyset(&newset); - sigaddset_blockable(&newset); - thread_sigmask(SIG_BLOCK, &newset, &oldset); - - get_spinlock(&th->interrupt_fun_lock, - (int)arch_os_get_current_thread()); - kill_status=thread_kill(th->os_thread,SIG_INTERRUPT_THREAD); - if(kill_status==0) { - c=alloc_cons(function,th->interrupt_fun); - th->interrupt_fun=c; - } - release_spinlock(&th->interrupt_fun_lock); - thread_sigmask(SIG_SETMASK,&oldset,0); - return (kill_status ? -1 : 0); - } + /* A thread may also become dead after this test. */ + if ((th->state != STATE_DEAD)) { + /* In clone_threads, if A and B both interrupt C at + * approximately the same time, it does not matter: the + * second signal will be masked until the handler has + * returned from the first one. In pthreads though, we + * can't put the knowledge of what function to call into + * the siginfo, so we have to store it in the destination + * thread, and do it in such a way that A won't clobber + * B's interrupt. Hence this stupid linked list. + * + * This does depend on SIG_INTERRUPT_THREAD being queued + * (as POSIX RT signals are): we need to keep + * interrupt_fun data for exactly as many signals as are + * going to be received by the destination thread. + */ + struct cons *c=alloc_cons(function,NIL); + int kill_status; + /* interrupt_thread_handler locks this spinlock with + * interrupts blocked and it does so for the sake of + * arrange_return_to_lisp_function, so we must also block + * them. */ + sigset_t newset,oldset; + sigemptyset(&newset); + sigaddset_blockable(&newset); + thread_sigmask(SIG_BLOCK, &newset, &oldset); + get_spinlock(&th->interrupt_fun_lock, + (long)arch_os_get_current_thread()); + kill_status=thread_kill(th->os_thread,SIG_INTERRUPT_THREAD); + if(kill_status==0) { + ((struct cons *)native_pointer(c))->cdr=th->interrupt_fun; + th->interrupt_fun=c; + } + release_spinlock(&th->interrupt_fun_lock); + thread_sigmask(SIG_SETMASK,&oldset,0); + return (kill_status ? -1 : 0); + } errno=EPERM; return -1; } -/* stopping the world is a two-stage process. From this thread we signal +/* stopping the world is a two-stage process. From this thread we signal * all the others with SIG_STOP_FOR_GC. The handler for this signal does - * the usual pseudo-atomic checks (we don't want to stop a thread while + * the usual pseudo-atomic checks (we don't want to stop a thread while * it's in the middle of allocation) then waits for another SIG_STOP_FOR_GC. */ +/* To avoid deadlocks when gc stops the world all clients of each + * mutex must enable or disable SIG_STOP_FOR_GC for the duration of + * holding the lock, but they must agree on which. */ void gc_stop_the_world() { struct thread *p,*th=arch_os_get_current_thread(); -#ifdef QSHOW_SIGNALS - SHOW("gc_stop_the_world:begin"); -#endif + FSHOW_SIGNAL((stderr,"/gc_stop_the_world:waiting on lock, thread=%ld\n", + th->os_thread)); /* keep threads from starting while the world is stopped. */ - get_spinlock(&thread_start_lock,th->os_thread); -#ifdef QSHOW_SIGNALS - SHOW("gc_stop_the_world:locked"); -#endif + get_spinlock(&all_threads_lock,(long)th); + FSHOW_SIGNAL((stderr,"/gc_stop_the_world:got lock, thread=%ld\n", + th->os_thread)); /* stop all other threads by sending them SIG_STOP_FOR_GC */ for(p=all_threads; p; p=p->next) { while(p->state==STATE_STARTING) sched_yield(); - if((p!=th) && (p->os_thread!=0) && (p->state==STATE_RUNNING)) { - p->state=STATE_STOPPING; + if((p!=th) && (p->state==STATE_RUNNING)) { + FSHOW_SIGNAL((stderr,"/gc_stop_the_world:sending sig_stop to %ld\n", + p->os_thread)); if(thread_kill(p->os_thread,SIG_STOP_FOR_GC)==-1) { - /* FIXME: we can't kill the thread; assume because it died - * already */ + /* we can't kill the thread; assume because it died + * since we last checked */ p->state=STATE_DEAD; + FSHOW_SIGNAL((stderr,"/gc_stop_the_world:assuming %ld dead\n", + p->os_thread)); } } } -#ifdef QSHOW_SIGNALS - SHOW("gc_stop_the_world:signals sent"); -#endif - /* wait for the running threads to stop */ + FSHOW_SIGNAL((stderr,"/gc_stop_the_world:signals sent\n")); + /* wait for the running threads to stop or finish */ for(p=all_threads;p;) { - if((p==th) || (p->os_thread==0) || (p->state==STATE_STARTING) || - (p->state==STATE_DEAD) || (p->state==STATE_STOPPED)) { + gc_assert(p->os_thread!=0); + gc_assert(p->state!=STATE_STARTING); + if((p==th) || (p->state==STATE_SUSPENDED) || + (p->state==STATE_DEAD)) { p=p->next; } } -#ifdef QSHOW_SIGNALS - SHOW("gc_stop_the_world:end"); -#endif + FSHOW_SIGNAL((stderr,"/gc_stop_the_world:end\n")); } void gc_start_the_world() @@ -429,15 +456,12 @@ void gc_start_the_world() /* if a resumed thread creates a new thread before we're done with * this loop, the new thread will get consed on the front of * all_threads, but it won't have been stopped so won't need - * restarting; there can be threads just starting from before - * gc_stop_the_world, though */ -#ifdef QSHOW_SIGNALS - SHOW("gc_start_the_world:begin"); -#endif + * restarting */ + FSHOW_SIGNAL((stderr,"/gc_start_the_world:begin\n")); for(p=all_threads;p;p=p->next) { - if((p!=th) && (p->os_thread!=0) && (p->state!=STATE_STARTING) && - (p->state!=STATE_DEAD)) { - if(p->state!=STATE_STOPPED) { + gc_assert(p->os_thread!=0); + if((p!=th) && (p->state!=STATE_DEAD)) { + if(p->state!=STATE_SUSPENDED) { lose("gc_start_the_world: wrong thread state is %ld\n", fixnum_value(p->state)); } @@ -448,14 +472,11 @@ void gc_start_the_world() * risk signal accumulation and lose any meaning of * thread->state */ for(p=all_threads;p;) { - gc_assert(p->state!=STATE_STOPPING); - if((p==th) || (p->os_thread==0) || (p->state!=STATE_STOPPED)) { + if((p==th) || (p->state!=STATE_SUSPENDED)) { p=p->next; } } - release_spinlock(&thread_start_lock); -#ifdef QSHOW_SIGNALS - SHOW("gc_start_the_world:end"); -#endif + release_spinlock(&all_threads_lock); + FSHOW_SIGNAL((stderr,"/gc_start_the_world:end\n")); } #endif diff --git a/src/runtime/thread.h b/src/runtime/thread.h index 870411c..e1cabcd 100644 --- a/src/runtime/thread.h +++ b/src/runtime/thread.h @@ -1,4 +1,3 @@ - #if !defined(_INCLUDE_THREAD_H_) #define _INCLUDE_THREAD_H_ @@ -6,6 +5,7 @@ #include #include #include "sbcl.h" +#include "globals.h" #include "runtime.h" #include "os.h" #include "interrupt.h" @@ -18,11 +18,10 @@ struct alloc_region { }; #include "genesis/static-symbols.h" #include "genesis/thread.h" -#define STATE_RUNNING (make_fixnum(0)) -#define STATE_STOPPING (make_fixnum(1)) -#define STATE_STOPPED (make_fixnum(2)) +#define STATE_STARTING (make_fixnum(0)) +#define STATE_RUNNING (make_fixnum(1)) +#define STATE_SUSPENDED (make_fixnum(2)) #define STATE_DEAD (make_fixnum(3)) -#define STATE_STARTING (make_fixnum(4)) #define THREAD_SLOT_OFFSET_WORDS(c) \ (offsetof(struct thread,c)/(sizeof (struct thread *))) @@ -34,7 +33,6 @@ union per_thread_data { extern struct thread *all_threads; extern int dynamic_values_bytes; -extern struct thread *find_thread_by_os_thread(os_thread_t tid); #ifdef LISP_FEATURE_SB_THREAD #define for_each_thread(th) for(th=all_threads;th;th=th->next) diff --git a/src/runtime/validate.c b/src/runtime/validate.c index 536e262..8b62b47 100644 --- a/src/runtime/validate.c +++ b/src/runtime/validate.c @@ -80,16 +80,14 @@ validate(void) } void -protect_control_stack_guard_page(os_thread_t t_id, int protect_p) { - struct thread *th = find_thread_by_os_thread(t_id); +protect_control_stack_guard_page(struct thread *th, int protect_p) { os_protect(CONTROL_STACK_GUARD_PAGE(th), os_vm_page_size,protect_p ? (OS_VM_PROT_READ|OS_VM_PROT_EXECUTE) : OS_VM_PROT_ALL); } void -protect_control_stack_return_guard_page(os_thread_t t_id, int protect_p) { - struct thread *th = find_thread_by_os_thread(t_id); +protect_control_stack_return_guard_page(struct thread *th, int protect_p) { os_protect(CONTROL_STACK_RETURN_GUARD_PAGE(th), os_vm_page_size,protect_p ? (OS_VM_PROT_READ|OS_VM_PROT_EXECUTE) : OS_VM_PROT_ALL); diff --git a/src/runtime/validate.h b/src/runtime/validate.h index 1037f2f..11cee1a 100644 --- a/src/runtime/validate.h +++ b/src/runtime/validate.h @@ -42,8 +42,8 @@ #endif extern void validate(void); -extern void protect_control_stack_guard_page(os_thread_t t_id, int protect_p); -extern void protect_control_stack_return_guard_page(os_thread_t t_id, +extern void protect_control_stack_guard_page(struct thread *th, int protect_p); +extern void protect_control_stack_return_guard_page(struct thread *th, int protect_p); extern os_vm_address_t undefined_alien_address; #endif diff --git a/src/runtime/x86-arch.h b/src/runtime/x86-arch.h index 439f508..3105cf6 100644 --- a/src/runtime/x86-arch.h +++ b/src/runtime/x86-arch.h @@ -4,9 +4,6 @@ * namespace that we control. */ #ifndef _X86_ARCH_H #define _X86_ARCH_H -#ifndef SBCL_GENESIS_CONFIG -#error genesis/config.h (or sbcl.h) must be included before this file -#endif #ifndef SBCL_GENESIS_CONFIG #error genesis/config.h (or sbcl.h) must be included before this file @@ -17,19 +14,17 @@ /* FIXME: Do we also want * #define ARCH_HAS_FLOAT_REGISTERS * here? (The answer wasn't obvious to me when merging the - * architecture-abstracting patches for CSR's SPARC port. -- WHN - * 2002-02-15) */ - -#ifdef LISP_FEATURE_SB_THREAD + * architecture-abstracting patches for CSR's SPARC port. -- WHN 2002-02-15) */ extern never_returns lose(char *fmt, ...); static inline void get_spinlock(volatile lispobj *word,long value) { +#ifdef LISP_FEATURE_SB_THREAD u32 eax=0; if(*word==value) - lose("recursive get_spinlock: 0x%x,%d\n",word,value); + lose("recursive get_spinlock: 0x%x,%ld\n",word,value); do { asm ("xor %0,%0\n\ lock cmpxchg %1,%2" @@ -37,6 +32,9 @@ get_spinlock(volatile lispobj *word,long value) : "r" (value), "m" (*word) : "memory", "cc"); } while(eax!=0); +#else + *word=value; +#endif } static inline void @@ -45,18 +43,4 @@ release_spinlock(volatile lispobj *word) *word=0; } -#else - -static inline void -get_spinlock(lispobj *word, int value) -{ - *word = value; -} - -static inline void -release_spinlock(lispobj *word) { - *word = 0; -} - -#endif /* LISP_FEATURE_SB_THREAD */ #endif /* _X86_ARCH_H */ diff --git a/src/runtime/x86-linux-os.c b/src/runtime/x86-linux-os.c index 4ddacdf..4b4f9ff 100644 --- a/src/runtime/x86-linux-os.c +++ b/src/runtime/x86-linux-os.c @@ -78,8 +78,7 @@ int arch_os_thread_init(struct thread *thread) { 1, MODIFY_LDT_CONTENTS_DATA, 0, 0, 0, 1 }; int n; - /* thread->os_thread is not set yet*/ - get_spinlock(&modify_ldt_lock,(int)thread); + get_spinlock(&modify_ldt_lock,(long)thread); n=modify_ldt(0,local_ldt_copy,sizeof local_ldt_copy); /* get next free ldt entry */ @@ -139,7 +138,7 @@ int arch_os_thread_cleanup(struct thread *thread) { }; ldt_entry.entry_number=thread->tls_cookie; - get_spinlock(&modify_ldt_lock,thread); + get_spinlock(&modify_ldt_lock,(long)thread); if (modify_ldt (1, &ldt_entry, sizeof (ldt_entry)) != 0) { modify_ldt_lock=0; /* modify_ldt call failed: something magical is not happening */ diff --git a/tests/threads.impure.lisp b/tests/threads.impure.lisp index 41782bf..4e9e8fa 100644 --- a/tests/threads.impure.lisp +++ b/tests/threads.impure.lisp @@ -15,6 +15,17 @@ (in-package "SB-THREAD") ; this is white-box testing, really +(let ((old-threads (list-all-threads)) + (thread (make-thread (lambda () + (assert (find *current-thread* *all-threads*)) + (sleep 2)))) + (new-threads (list-all-threads))) + (assert (thread-alive-p thread)) + (assert (eq thread (first new-threads))) + (assert (= (1+ (length old-threads)) (length new-threads))) + (sleep 3) + (assert (not (thread-alive-p thread)))) + ;;; We had appalling scaling properties for a while. Make sure they ;;; don't reappear. (defun scaling-test (function &optional (nthreads 5)) @@ -55,7 +66,7 @@ ;;; elementary "can we get a lock and release it again" (let ((l (make-mutex :name "foo")) - (p (current-thread-id))) + (p *current-thread*)) (assert (eql (mutex-value l) nil) nil "1") (assert (eql (mutex-lock l) 0) nil "2") (sb-thread:get-mutex l) @@ -67,7 +78,7 @@ (describe l)) (let ((l (make-waitqueue :name "spinlock")) - (p (current-thread-id))) + (p *current-thread*)) (assert (eql (waitqueue-lock l) 0) nil "1") (with-spinlock (l) (assert (eql (waitqueue-lock l) p) nil "2")) @@ -77,7 +88,7 @@ ;; test that SLEEP actually sleeps for at least the given time, even ;; if interrupted by another thread exiting/a gc/anything (let ((start-time (get-universal-time))) - (make-thread (lambda () (sleep 1))) ; kid waits 1 then dies ->SIG_THREAD_EXIT + (make-thread (lambda () (sleep 1) (sb-ext:gc :full t))) (sleep 5) (assert (>= (get-universal-time) (+ 5 start-time)))) @@ -86,16 +97,16 @@ (lock (make-mutex :name "lock"))) (labels ((in-new-thread () (with-mutex (lock) - (assert (eql (mutex-value lock) (current-thread-id))) - (format t "~A got mutex~%" (current-thread-id)) + (assert (eql (mutex-value lock) *current-thread*)) + (format t "~A got mutex~%" *current-thread*) ;; now drop it and sleep (condition-wait queue lock) ;; after waking we should have the lock again - (assert (eql (mutex-value lock) (current-thread-id)))))) + (assert (eql (mutex-value lock) *current-thread*))))) (make-thread #'in-new-thread) (sleep 2) ; give it a chance to start ;; check the lock is free while it's asleep - (format t "parent thread ~A~%" (current-thread-id)) + (format t "parent thread ~A~%" *current-thread*) (assert (eql (mutex-value lock) nil)) (assert (eql (mutex-lock lock) 0)) (with-mutex (lock) @@ -119,7 +130,7 @@ (make-thread #'in-new-thread) (sleep 2) ; give it a chance to start ;; check the lock is free while it's asleep - (format t "parent thread ~A~%" (current-thread-id)) + (format t "parent thread ~A~%" *current-thread*) (assert (eql (mutex-value lock) nil)) (assert (eql (mutex-lock lock) 0)) (with-recursive-lock (lock) @@ -128,13 +139,13 @@ (let ((mutex (make-mutex :name "contended"))) (labels ((run () - (let ((me (current-thread-id))) + (let ((me *current-thread*)) (dotimes (i 100) (with-mutex (mutex) (sleep .1) (assert (eql (mutex-value mutex) me))) (assert (not (eql (mutex-value mutex) me)))) - (format t "done ~A~%" (current-thread-id))))) + (format t "done ~A~%" *current-thread*)))) (let ((kid1 (make-thread #'run)) (kid2 (make-thread #'run))) (format t "contention ~A ~A~%" kid1 kid2)))) @@ -146,14 +157,14 @@ (format t "interrupting child ~A~%" child) (interrupt-thread child (lambda () - (format t "child pid ~A~%" (current-thread-id)) + (format t "child pid ~A~%" *current-thread*) (when quit-p (sb-ext:quit)))) (sleep 1) child)) -;;; separate tests for (a) interrupting Lisp code, (b) C code, (c) a syscall, -;;; (d) waiting on a lock, (e) some code which we hope is likely to be -;;; in pseudo-atomic +;; separate tests for (a) interrupting Lisp code, (b) C code, (c) a syscall, +;; (d) waiting on a lock, (e) some code which we hope is likely to be +;; in pseudo-atomic (let ((child (test-interrupt (lambda () (loop))))) (terminate-thread child)) @@ -168,18 +179,39 @@ (setf child (test-interrupt (lambda () (with-mutex (lock) - (assert (eql (mutex-value lock) (current-thread-id)))) - (assert (not (eql (mutex-value lock) (current-thread-id)))) - (sleep 60)))) + (assert (eql (mutex-value lock) *current-thread*))) + (assert (not (eql (mutex-value lock) *current-thread*))) + (sleep 10)))) ;;hold onto lock for long enough that child can't get it immediately - (sleep 20) + (sleep 5) (interrupt-thread child (lambda () (format t "l ~A~%" (mutex-value lock)))) (format t "parent releasing lock~%")) (terminate-thread child)) +(format t "~&locking test done~%") + (defun alloc-stuff () (copy-list '(1 2 3 4 5))) -(let ((c (test-interrupt (lambda () (loop (alloc-stuff)))))) +(progn + (let ((thread (sb-thread:make-thread (lambda () (loop (alloc-stuff)))))) + (let ((killers + (loop repeat 4 collect + (sb-thread:make-thread + (lambda () + (loop repeat 25 do + (sleep (random 2d0)) + (princ ".") + (force-output) + (sb-thread:interrupt-thread + thread + (lambda ())))))))) + (loop while (some #'thread-alive-p killers) do (sleep 0.1)) + (sb-thread:terminate-thread thread))) + (sb-ext:gc :full t)) + +(format t "~&multi interrupt test done~%") + +(let ((c (make-thread (lambda () (loop (alloc-stuff)))))) ;; NB this only works on x86: other ports don't have a symbol for ;; pseudo-atomic atomicity (format t "new thread ~A~%" c) @@ -188,9 +220,11 @@ (interrupt-thread c (lambda () (princ ".") (force-output) + (assert (eq (thread-state *current-thread*) :running)) (assert (zerop SB-KERNEL:*PSEUDO-ATOMIC-ATOMIC*))))) (terminate-thread c)) -(terpri) + +(format t "~&interrupt test done~%") (defparameter *interrupt-count* 0) @@ -212,21 +246,20 @@ (princ ".") (force-output) (sb-impl::atomic-incf/symbol *interrupt-count*)))) - (sb-sys:with-pinned-objects (func) - (setq *interrupt-count* 0) - (dotimes (i 100) - (sleep (random 1d0)) - (interrupt-thread c func)) - (sleep 1) - (assert (= 100 *interrupt-count*)) - (terminate-thread c)))) + (setq *interrupt-count* 0) + (dotimes (i 100) + (sleep (random 1d0)) + (interrupt-thread c func)) + (sleep 1) + (assert (= 100 *interrupt-count*)) + (terminate-thread c))) -(format t "~&interrupt test done~%") +(format t "~&interrupt count test done~%") (let (a-done b-done) (make-thread (lambda () (dotimes (i 100) - (sb-ext:gc) (princ "\\") (force-output) ) + (sb-ext:gc) (princ "\\") (force-output)) (setf a-done t))) (make-thread (lambda () (dotimes (i 25) diff --git a/version.lisp-expr b/version.lisp-expr index c536493..aa8ebd2 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.8" +"0.9.2.9"