From: Gabor Melis Date: Mon, 11 Jul 2005 15:31:07 +0000 (+0000) Subject: 0.9.2.38: thread cleanup, paranoid X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=ad3beba970fab6e451a461c9f9b14faf4ef17718;p=sbcl.git 0.9.2.38: thread cleanup, paranoid * fixed 32bitness in some places * untangled waitqueues, mutexes and spinlocks * updated the user manual * removed target-unithread.lisp and target-multithread.lisp and put everything into target-thread.lisp mainly for OOAO the docstrings, but also to provide as much as possible of the thread interface in unithread builds --- diff --git a/INSTALL b/INSTALL index 684aaf2..6cff13c 100644 --- a/INSTALL +++ b/INSTALL @@ -228,6 +228,7 @@ INSTALLING SBCL CMUCL OpenMCL CLISP (recent versions only) + ABCL (recent versions only) Note that every release isn't tested with every possible host compiler. You're most likely to get a clean build with SBCL itself diff --git a/build-order.lisp-expr b/build-order.lisp-expr index 5d4acb2..d622fc8 100644 --- a/build-order.lisp-expr +++ b/build-order.lisp-expr @@ -639,10 +639,6 @@ ("src/code/alloc" :not-host) ("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 ("src/code/gc" :not-host) ("src/code/purify" :not-host) diff --git a/doc/manual/threading.texinfo b/doc/manual/threading.texinfo index 944892a..f858438 100644 --- a/doc/manual/threading.texinfo +++ b/doc/manual/threading.texinfo @@ -9,9 +9,11 @@ multiprocessing on machines that have more than one CPU, but it does not allow Lisp control of the scheduler. This is found in the SB-THREAD package. -This requires x86 and Linux kernel 2.6 or systems with NPTL backports. +This requires x86/x86-64 and Linux kernel 2.6 or systems with NPTL +backports. @menu +* Threading basics:: * Special Variables:: * Mutex Support:: * Waitqueue/condition variables:: @@ -19,6 +21,25 @@ This requires x86 and Linux kernel 2.6 or systems with NPTL backports. * Implementation (Linux x86):: @end menu +@node Threading basics +@comment node-name, next, previous, up +@section Threading basics + +@lisp +(make-thread (lambda () (write-line "Hello, world"))) +@end lisp + +@include struct-sb-thread-thread.texinfo +@include var-sb-thread-star-current-thread-star.texinfo +@include fun-sb-thread-make-thread.texinfo +@include fun-sb-thread-thread-alive-p.texinfo +@include fun-sb-thread-list-all-threads.texinfo +@include condition-sb-thread-interrupt-thread-error.texinfo +@include fun-sb-thread-interrupt-thread-error-thread.texinfo +@include fun-sb-thread-interrupt-thread-error-errno.texinfo +@include fun-sb-thread-interrupt-thread.texinfo +@include fun-sb-thread-terminate-thread.texinfo + @node Special Variables @comment node-name, next, previous, up @section Special Variables @@ -37,6 +58,16 @@ bindings (e.g. using LET) are local to the thread; initial values in a new thread are taken from the thread that created it. @end itemize +The last point means that + +@lisp +(defparameter *x* 0) +(let ((*x* 1)) + (sb-thread:make-thread (lambda () (print *x*)))) +@end lisp + +prints @code{1}. + @node Mutex Support @comment node-name, next, previous, up @section Mutex Support @@ -66,9 +97,17 @@ if you want a bounded wait. (make-thread #'thread-fn) (make-thread #'thread-fn) - @end lisp +@include struct-sb-thread-mutex.texinfo +@include fun-sb-thread-make-mutex.texinfo +@include fun-sb-thread-mutex-name.texinfo +@include fun-sb-thread-mutex-value.texinfo +@include fun-sb-thread-get-mutex.texinfo +@include fun-sb-thread-release-mutex.texinfo +@include macro-sb-thread-with-mutex.texinfo +@include macro-sb-thread-with-recursive-lock.texinfo + @node Waitqueue/condition variables @comment node-name, next, previous, up @section Waitqueue/condition variables @@ -144,9 +183,15 @@ it. (make-thread #'writer) (make-thread #'reader) (make-thread #'reader) - @end lisp +@include struct-sb-thread-waitqueue.texinfo +@include fun-sb-thread-make-waitqueue.texinfo +@include fun-sb-thread-waitqueue-name.texinfo +@include fun-sb-thread-condition-wait.texinfo +@include fun-sb-thread-condition-notify.texinfo +@include fun-sb-thread-condition-broadcast.texinfo + @node Sessions/Debugging @comment node-name, next, previous, up @section Sessions/Debugging @@ -177,20 +222,17 @@ leaves other sessions running. @node Implementation (Linux x86) @comment node-name, next, previous, up -@section Implementation (Linux x86) - -On Linux x86, threading is implemented using @code{clone()} and does -not involve pthreads. This is not because there is anything wrong -with pthreads @emph{per se}, but there is plenty wrong (from our -perspective) with LinuxThreads. SBCL threads are mapped 1:1 onto -Linux tasks which share a VM but nothing else - each has its own -process id and can be seen in e.g. @command{ps} output. - -Per-thread local bindings for special variables is achieved using the -%fs segment register to point to a per-thread storage area. This may -cause interesting results if you link to foreign code that expects -threading or creates new threads, and the thread library in question -uses %fs in an incompatible way. +@section Implementation (Linux x86/x86-64) + +Threading is implemented using pthreads and some Linux specific bits +like futexes. + +On x86 the per-thread local bindings for special variables is achieved +using the %fs segment register to point to a per-thread storage area. +This may cause interesting results if you link to foreign code that +expects threading or creates new threads, and the thread library in +question uses %fs in an incompatible way. On x86-64 the r12 register +has a similar role. Queues require the @code{sys_futex()} system call to be available: this is the reason for the NPTL requirement. We test at runtime that diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr index 0719f1a..cbe2e9b 100644 --- a/package-data-list.lisp-expr +++ b/package-data-list.lisp-expr @@ -1587,15 +1587,20 @@ 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 ("*CURRENT-THREAD*" "MAKE-THREAD" "THREAD" + :export ("*CURRENT-THREAD*" "THREAD" "MAKE-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" + "INTERRUPT-THREAD-ERROR" + "INTERRUPT-THREAD-ERROR-THREAD" + "INTERRUPT-THREAD-ERROR-ERRNO" + "INTERRUPT-THREAD" "TERMINATE-THREAD" "DESTROY-THREAD" + "MUTEX" "MAKE-MUTEX" "MUTEX-NAME" "MUTEX-VALUE" + "GET-MUTEX" "RELEASE-MUTEX" "WITH-MUTEX" + "WITH-RECURSIVE-LOCK" + "WAITQUEUE" "MAKE-WAITQUEUE" "WAITQUEUE-NAME" "CONDITION-WAIT" "CONDITION-NOTIFY" "CONDITION-BROADCAST" - "WITH-RECURSIVE-LOCK" "RELEASE-FOREGROUND" "WITH-NEW-SESSION")) + "MAKE-LISTENER-THREAD" + "RELEASE-FOREGROUND" "WITH-NEW-SESSION")) #s(sb-cold:package-data :name "SB!LOOP" diff --git a/src/code/target-multithread.lisp b/src/code/target-multithread.lisp deleted file mode 100644 index 43f051c..0000000 --- a/src/code/target-multithread.lisp +++ /dev/null @@ -1,396 +0,0 @@ -;;;; 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)) - -;;;; 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)))) - -;;;; job control, independent listeners - -(defstruct session - (lock (make-mutex :name "session lock")) - (threads nil) - (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*))) - -(defun init-job-control () - (setf *session* (new-session))) - -(defun %delete-thread-from-session (thread session) - (with-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-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-session-lock (*session*) - (not (member *current-thread* - (session-interactive-threads *session*)))) - (get-foreground))) - -(defun get-foreground () - (let ((was-foreground t)) - (loop - (with-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-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)))) - -;;;; 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/src/code/target-thread.lisp b/src/code/target-thread.lisp index dd25ecb..67ef209 100644 --- a/src/code/target-thread.lisp +++ b/src/code/target-thread.lisp @@ -1,5 +1,4 @@ -;;;; support for threads in the target machine common to uni- and -;;;; multithread systems +;;;; support for threads in the target machine ;;;; This software is part of the SBCL system. See the README file for ;;;; more information. @@ -12,10 +11,23 @@ (in-package "SB!THREAD") +;;; set the doc here because in early-thread FDOCUMENTATION is not +;;; available, yet +#!+sb-doc +(setf (sb!kernel:fdocumentation '*current-thread* 'variable) + "Bound in each thread to the thread itself.") + (defstruct (thread (:constructor %make-thread)) + #!+sb-doc + "Thread type. Do not rely on threads being structs as it may change +in future versions." name %sap) +#!+sb-doc +(setf (sb!kernel:fdocumentation 'thread-name 'function) + "The name of the thread. Setfable.") + (def!method print-object ((thread thread) stream) (if (thread-name thread) (print-unreadable-object (thread stream :type t :identity t) @@ -50,6 +62,8 @@ (:dead #.(sb!vm:fixnumize 3)))))) (defun thread-alive-p (thread) + #!+sb-doc + "Check if THREAD is running." (not (eq :dead (thread-state thread)))) ;; A thread is eligible for gc iff it has finished and there are no @@ -59,6 +73,8 @@ (defvar *all-threads-lock* (make-mutex :name "all threads lock")) (defun list-all-threads () + #!+sb-doc + "Return a list of the live threads." (with-mutex (*all-threads-lock*) (copy-list *all-threads*))) @@ -79,3 +95,497 @@ ;; in case we are in reinit since saving core with multiple ;; threads doesn't work. (setq *all-threads* (list initial-thread)))) + +;;;; + +#!+sb-thread +(progn + (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)) + + (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))) + +;;; used by debug-int.lisp to access interrupt contexts +#!-(and sb-fluid sb-thread) (declaim (inline sb!vm::current-thread-offset-sap)) +#!-sb-thread +(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))) + +;;;; spinlocks + +(defstruct spinlock + #!+sb-doc + "Spinlock type." + (name nil :type (or null simple-string)) + (value 0)) + +(declaim (inline get-spinlock release-spinlock)) + +;;; The bare 2 here and below are offsets of the slots in the struct. +;;; There ought to be some better way to get these numbers +(defun get-spinlock (spinlock new-value) + (declare (optimize (speed 3) (safety 0)) + #!-sb-thread + (ignore spinlock new-value)) + ;; %instance-set-conditional can test for 0 (which is a fixnum) and + ;; store any value + #!+sb-thread + (loop until + (eql (sb!vm::%instance-set-conditional spinlock 2 0 new-value) 0))) + +(defun release-spinlock (spinlock) + (declare (optimize (speed 3) (safety 0)) + #!-sb-thread (ignore spinlock)) + ;; %instance-set-conditional cannot compare arbitrary objects + ;; meaningfully, so + ;; (sb!vm::%instance-set-conditional spinlock 2 our-value 0) + ;; does not work for bignum thread ids. + #!+sb-thread + (sb!vm::%instance-set spinlock 2 0)) + +(defmacro with-spinlock ((spinlock) &body body) + (sb!int:with-unique-names (lock) + `(let ((,lock ,spinlock)) + (get-spinlock ,lock *current-thread*) + (unwind-protect + (progn ,@body) + (release-spinlock ,lock))))) + +;;;; mutexes + +(defstruct mutex + #!+sb-doc + "Mutex type." + (name nil :type (or null simple-string)) + (value nil)) + +#!+sb-doc +(setf (sb!kernel:fdocumentation 'make-mutex 'function) + "Create a mutex." + (sb!kernel:fdocumentation 'mutex-name 'function) + "The name of the mutex. Setfable." + (sb!kernel:fdocumentation 'mutex-value 'function) + "The value of the mutex. NIL if the mutex is free. Setfable.") + +#!+sb-thread +(declaim (inline mutex-value-address)) +#!+sb-thread +(defun mutex-value-address (mutex) + (declare (optimize (speed 3))) + (sb!ext:truly-the + sb!vm:word + (+ (sb!kernel:get-lisp-obj-address mutex) + (- (* 3 sb!vm:n-word-bytes) sb!vm:instance-pointer-lowtag)))) + +(defun get-mutex (mutex &optional new-value (wait-p t)) + #!+sb-doc + "Acquire MUTEX, setting it to NEW-VALUE or some suitable default +value if NIL. If WAIT-P is non-NIL and the mutex is in use, sleep +until it is available" + (declare (type mutex mutex) (optimize (speed 3))) + (unless new-value (setf new-value *current-thread*)) + #!-sb-thread + (let ((old-value (mutex-value mutex))) + (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)." + mutex wait-p new-value old-value)) + (setf (mutex-value mutex) new-value) + t) + #!+sb-thread + (let (old) + (when (eql new-value (mutex-value mutex)) + (warn "recursive lock attempt ~S~%" mutex) + (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 mutex 2 nil new-value)) + (return t)) + (unless wait-p (return nil)) + (futex-wait (mutex-value-address mutex) + (sb!kernel:get-lisp-obj-address old))))) + +(defun release-mutex (mutex) + #!+sb-doc + "Release MUTEX by setting it to NIL. Wake up threads waiting for +this mutex." + (declare (type mutex mutex)) + (setf (mutex-value mutex) nil) + #!+sb-thread + (futex-wake (mutex-value-address mutex) 1)) + +;;;; waitqueues/condition variables + +(defstruct (waitqueue (:constructor %make-waitqueue)) + #!+sb-doc + "Waitqueue type." + (name nil :type (or null simple-string)) + (data nil)) + +(defun make-waitqueue (&key name) + #!+sb-doc + "Create a waitqueue." + (%make-waitqueue :name name)) + +#!+sb-doc +(setf (sb!kernel:fdocumentation 'waitqueue-name 'function) + "The name of the waitqueue. Setfable.") + +#!+sb-thread +(declaim (inline waitqueue-data-address)) +#!+sb-thread +(defun waitqueue-data-address (waitqueue) + (declare (optimize (speed 3))) + (sb!ext:truly-the + sb!vm:word + (+ (sb!kernel:get-lisp-obj-address waitqueue) + (- (* 3 sb!vm:n-word-bytes) sb!vm:instance-pointer-lowtag)))) + +(defun condition-wait (queue mutex) + #!+sb-doc + "Atomically release MUTEX and enqueue ourselves on QUEUE. Another +thread may subsequently notify us using CONDITION-NOTIFY, at which +time we reacquire MUTEX and return to the caller." + #!-sb-thread (declare (ignore queue)) + (assert mutex) + #!-sb-thread (error "Not supported in unithread builds.") + #!+sb-thread + (let ((value (mutex-value mutex))) + (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 mutex) + ;; Now we go to sleep using futex-wait. If anyone else + ;; manages to grab MUTEX 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 mutex value)))) + +(defun condition-notify (queue) + #!+sb-doc + "Notify one of the threads waiting on QUEUE." + #!-sb-thread (declare (ignore queue)) + #!-sb-thread (error "Not supported in unithread builds.") + #!+sb-thread + (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) + #!+sb-doc + "Notify all threads waiting on QUEUE." + #!-sb-thread (declare (ignore queue)) + #!-sb-thread (error "Not supported in unithread builds.") + #!+sb-thread + (let ((me *current-thread*)) + (setf (waitqueue-data queue) me) + (futex-wake (waitqueue-data-address queue) (ash 1 30)))) + +;;;; job control, independent listeners + +(defstruct session + (lock (make-mutex :name "session lock")) + (threads nil) + (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-thread (declare (ignore session)) + #!-sb-thread + `(locally ,@body) + #!+sb-thread + `(sb!sys:without-interrupts + (with-mutex ((session-lock ,session)) + ,@body))) + +(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-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. +#!+sb-thread +(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 () + #!+sb-doc + "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-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)) + #!-sb-thread nil + #!+sb-thread + (prog1 + (with-session-lock (*session*) + (not (member *current-thread* + (session-interactive-threads *session*)))) + (get-foreground))) + +(defun get-foreground () + #!-sb-thread t + #!+sb-thread + (let ((was-foreground t)) + (loop + (with-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) + #!+sb-doc + "Background this thread. If NEXT is supplied, arrange for it to +have the foreground next" + #!-sb-thread (declare (ignore next)) + #!-sb-thread nil + #!+sb-thread + (with-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)))) + +;;;; the beef + +(defun make-thread (function &key name) + #!+sb-doc + "Create a new thread of NAME that runs FUNCTION. When the function +returns the thread exits." + #!-sb-thread (declare (ignore function name)) + #!-sb-thread (error "Not supported in unithread builds.") + #!+sb-thread + (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) + #!+sb-doc + "Deprecated. Same as TERMINATE-THREAD." + (terminate-thread thread)) + +(define-condition interrupt-thread-error (error) + ((thread :reader interrupt-thread-error-thread :initarg :thread) + (errno :reader interrupt-thread-error-errno :initarg :errno)) + #!+sb-doc + (:documentation "Interrupting thread failed.") + (: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)))))) + +#!+sb-doc +(setf (sb!kernel:fdocumentation 'interrupt-thread-error-thread 'function) + "The thread that was not interrupted." + (sb!kernel:fdocumentation 'interrupt-thread-error-errno 'function) + "The reason why the interruption failed.") + +(defun interrupt-thread (thread function) + #!+sb-doc + "Interrupt the live THREAD and make it run FUNCTION. 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." + #!-sb-thread (declare (ignore thread)) + ;; not quite perfect, because it does not take WITHOUT-INTERRUPTS + ;; into account + #!-sb-thread + (funcall function) + #!+sb-thread + (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) + #!+sb-doc + "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 +#!+sb-thread +(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/src/code/target-unithread.lisp b/src/code/target-unithread.lisp deleted file mode 100644 index 1d5a494..0000000 --- a/src/code/target-unithread.lisp +++ /dev/null @@ -1,72 +0,0 @@ -;;;; unithread stub 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") - -;;; 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) - (declare (type (unsigned-byte 27) n)) - (sb!sys:sap-ref-sap (alien-sap (extern-alien "all_threads" (* t))) - (* n sb!vm:n-word-bytes))) - -;;;; queues, locks - -;; spinlocks use 0 as "free" value: higher-level locks use NIL -(defun get-spinlock (lock offset new-value) - (declare (ignore lock offset new-value))) - -(defmacro with-spinlock ((queue) &body body) - (declare (ignore queue)) - `(progn ,@body)) - -;;;; the higher-level locking operations are based on waitqueues - -(defstruct waitqueue - (name nil :type (or null simple-string)) - (lock 0) - (data nil)) - -(defstruct (mutex (:include waitqueue)) - (value nil)) - -;;;; mutex - -(defun get-mutex (lock &optional new-value (wait-p t)) - (declare (type mutex lock)) - (let ((old-value (mutex-value lock))) - (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)) - (setf (mutex-value lock) new-value) - t)) - -(defun release-mutex (lock) - (declare (type mutex lock)) - (setf (mutex-value lock) nil)) - - -;; FIXME need suitable stub or ERROR-signaling definitions for -;; condition-wait (queue lock) -;; condition-notify (queue) - -;;;; job control - -(defun init-job-control () t) -(defun debugger-wait-until-foreground-thread (stream) - (declare (ignore stream)) - t) -(defun get-foreground () t) -(defun release-foreground (&optional next) - (declare (ignore next)) - t) -(defun terminate-session ()) diff --git a/src/pcl/low.lisp b/src/pcl/low.lisp index d7ee7a9..76aa2b8 100644 --- a/src/pcl/low.lisp +++ b/src/pcl/low.lisp @@ -352,7 +352,7 @@ #+sb-thread (progn - (defvar *pcl-lock* (sb-thread:make-waitqueue)) + (defvar *pcl-lock* (sb-thread::make-spinlock)) (defmacro with-pcl-lock (&body body) `(sb-thread::with-spinlock (*pcl-lock*) diff --git a/src/runtime/thread.c b/src/runtime/thread.c index dc3fb2d..09171f4 100644 --- a/src/runtime/thread.c +++ b/src/runtime/thread.c @@ -325,11 +325,6 @@ struct thread *create_thread(lispobj initial_function) { 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. */ /* called from lisp from the thread object finalizer */ void reap_dead_thread(struct thread *th) diff --git a/tests/threads.impure.lisp b/tests/threads.impure.lisp index 4be11bc..03465c4 100644 --- a/tests/threads.impure.lisp +++ b/tests/threads.impure.lisp @@ -11,10 +11,29 @@ ;;;; absoluely no warranty. See the COPYING and CREDITS files for ;;;; more information. -#-sb-thread (quit :unix-status 104) - (in-package "SB-THREAD") ; this is white-box testing, really +(assert (eql 1 (length (list-all-threads)))) + +(assert (eq *current-thread* + (find (thread-name *current-thread*) (list-all-threads) + :key #'thread-name :test #'equal))) + +(assert (thread-alive-p *current-thread*)) + +(let ((a 0)) + (interrupt-thread *current-thread* (lambda () (setq a 1))) + (assert (eql a 1))) + +(let ((spinlock (make-spinlock))) + (with-spinlock (spinlock))) + +(let ((mutex (make-mutex))) + (with-mutex (mutex) + mutex)) + +#-sb-thread (sb-ext:quit :unix-status 104) + (let ((old-threads (list-all-threads)) (thread (make-thread (lambda () (assert (find *current-thread* *all-threads*)) @@ -68,36 +87,29 @@ (let ((l (make-mutex :name "foo")) (p *current-thread*)) (assert (eql (mutex-value l) nil) nil "1") - (assert (eql (mutex-lock l) 0) nil "2") (sb-thread:get-mutex l) (assert (eql (mutex-value l) p) nil "3") - (assert (eql (mutex-lock l) 0) nil "4") (sb-thread:release-mutex l) - (assert (eql (mutex-value l) nil) nil "5") - (assert (eql (mutex-lock l) 0) nil "6") - (describe l)) + (assert (eql (mutex-value l) nil) nil "5")) (labels ((ours-p (value) (sb-vm:control-stack-pointer-valid-p (sb-sys:int-sap (sb-kernel:get-lisp-obj-address value))))) (let ((l (make-mutex :name "rec"))) (assert (eql (mutex-value l) nil) nil "1") - (assert (eql (mutex-lock l) 0) nil "2") (sb-thread:with-recursive-lock (l) (assert (ours-p (mutex-value l)) nil "3") (sb-thread:with-recursive-lock (l) (assert (ours-p (mutex-value l)) nil "4")) (assert (ours-p (mutex-value l)) nil "5")) - (assert (eql (mutex-value l) nil) nil "6") - (assert (eql (mutex-lock l) 0) nil "7"))) + (assert (eql (mutex-value l) nil) nil "6"))) -(let ((l (make-waitqueue :name "spinlock")) +(let ((l (make-spinlock :name "spinlock")) (p *current-thread*)) - (assert (eql (waitqueue-lock l) 0) nil "1") + (assert (eql (spinlock-value l) 0) nil "1") (with-spinlock (l) - (assert (eql (waitqueue-lock l) p) nil "2")) - (assert (eql (waitqueue-lock l) 0) nil "3") - (describe l)) + (assert (eql (spinlock-value l) p) nil "2")) + (assert (eql (spinlock-value l) 0) nil "3")) ;; test that SLEEP actually sleeps for at least the given time, even ;; if interrupted by another thread exiting/a gc/anything @@ -108,7 +120,8 @@ (let ((queue (make-waitqueue :name "queue")) - (lock (make-mutex :name "lock"))) + (lock (make-mutex :name "lock")) + (n 0)) (labels ((in-new-thread () (with-mutex (lock) (assert (eql (mutex-value lock) *current-thread*)) @@ -116,14 +129,16 @@ ;; now drop it and sleep (condition-wait queue lock) ;; after waking we should have the lock again - (assert (eql (mutex-value lock) *current-thread*))))) + (assert (eql (mutex-value lock) *current-thread*)) + (assert (eql n 1)) + (decf n)))) (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*) (assert (eql (mutex-value lock) nil)) - (assert (eql (mutex-lock lock) 0)) (with-mutex (lock) + (incf n) (condition-notify queue)) (sleep 1))) @@ -146,7 +161,6 @@ ;; check the lock is free while it's asleep (format t "parent thread ~A~%" *current-thread*) (assert (eql (mutex-value lock) nil)) - (assert (eql (mutex-lock lock) 0)) (with-recursive-lock (lock) (condition-notify queue)) (sleep 1))) @@ -272,11 +286,11 @@ (let (a-done b-done) (make-thread (lambda () - (dotimes (i 100) + (dotimes (i 100) (sb-ext:gc) (princ "\\") (force-output)) (setf a-done t))) (make-thread (lambda () - (dotimes (i 25) + (dotimes (i 25) (sb-ext:gc :full t) (princ "/") (force-output)) (setf b-done t))) diff --git a/version.lisp-expr b/version.lisp-expr index dcaaf93..538e705 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.37" +"0.9.2.38"