From: Daniel B. <da...@us...> - 2003-11-23 19:41:52
|
Update of /cvsroot/sbcl/sbcl/src/code In directory sc8-pr-cvs1:/tmp/cvs-serv3935/src/code Modified Files: Tag: resistance-is-futex cold-init.lisp gc.lisp target-thread.lisp Log Message: 0.8.5.37.resistance-is-futex.1 Let's have some of this stuff in CVS before I completely forget what it does. Highlights: We rewrote the locking around GC again. This time I think I understand it, so it stands an outside chance of being correct Support the "futex" fast userspace locking in Linux 2.6, for mutexes and condition variables. This is not in the default build: to enable, add :sb-futex to the target features. Requires 2.6 or an NPTL backport at build time, but an SBCL built with the feature should be able to fall back to the signals-based locking if futexes are not available at runtime The *session-lock* stuff is presently broken, because we can't introspect on kernel queues from user space. Chopped out the *background-threads-wait-for-debugger* switch as it can now be done with *invoke-debugger-hook* anyway Cut out much of the never-actually-worked cruft from target-thread.lisp search_{static,read_only}_space now external functions like search_dynamic_space, mostly so I can debug in gdb more easily os_init in linux-os.c rearranged a bit and test for sys_futex call added, but should be otherwise functionally identical signal_thread_to_dequeue wrapper function means we don't need to grovel SIGRTMIN (patch from Andreas Fuchs) Fix for changes in Linux 2.6 SIGTRAP handling: trap_PendingInterrupt now removes SIGTRAP from the signal mask before executing the pending handler, otherwise any pseudoatomic in the pending handler will lead to process death in short order small amount of spring-cleaning in the threads.impure.lisp test Incorporated parts of the thread patch in 0.8.5's contrib/ ... stop_the_world now uses a slot in the thread structure to work out what needs stopping and what has been stopped, instead of just counting them ... threads are created in STOPPED state and only set RUNNING in new_thread_trampoline Index: cold-init.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/src/code/cold-init.lisp,v retrieving revision 1.42 retrieving revision 1.42.10.1 diff -u -d -r1.42 -r1.42.10.1 --- cold-init.lisp 28 Aug 2003 15:32:28 -0000 1.42 +++ cold-init.lisp 23 Nov 2003 19:41:49 -0000 1.42.10.1 @@ -289,6 +289,7 @@ ;; disabled by default. Joe User can explicitly enable them if ;; desired. (set-floating-point-modes :traps '(:overflow :invalid :divide-by-zero)) + (sb!thread::maybe-install-futex-functions) ;; Clear pseudo atomic in case this core wasn't compiled with ;; support. Index: gc.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/src/code/gc.lisp,v retrieving revision 1.53 retrieving revision 1.53.2.1 diff -u -d -r1.53 -r1.53.2.1 --- gc.lisp 25 Oct 2003 21:34:36 -0000 1.53 +++ gc.lisp 23 Nov 2003 19:41:49 -0000 1.53.2.1 @@ -230,28 +230,27 @@ ;;; For GENCGC all generations < GEN will be GC'ed. -(defvar *already-in-gc* nil "System is running SUB-GC") -(defvar *gc-mutex* (sb!thread:make-mutex :name "GC Mutex")) +(defvar *already-in-gc* + (sb!thread:make-mutex :name "GC lock") "ID of thread running SUB-GC") (defun sub-gc (&key (gen 0) &aux (pre-gc-dynamic-usage (dynamic-usage))) - ;; catch attempts to gc recursively or during post-hooks and ignore them - (when (sb!thread::mutex-value *gc-mutex*) (return-from sub-gc nil)) - (sb!thread:with-mutex (*gc-mutex* :wait-p nil) + (let ((me (sb!thread:current-thread-id))) + (when (eql (sb!thread::mutex-value *already-in-gc*) me) + (return-from sub-gc nil)) (setf *need-to-collect-garbage* t) (when (zerop *gc-inhibit*) - (without-interrupts - (gc-stop-the-world) - (collect-garbage gen) - (incf *n-bytes-freed-or-purified* - (max 0 (- pre-gc-dynamic-usage (dynamic-usage)))) - (setf *need-to-collect-garbage* nil) - (gc-start-the-world)) - (scrub-control-stack) - (setf *need-to-collect-garbage* nil) - (dolist (h *after-gc-hooks*) (carefully-funcall h)))) - (values)) - - + (loop + (sb!thread:with-mutex (*already-in-gc*) + (unless *need-to-collect-garbage* (return-from sub-gc nil)) + (without-interrupts + (gc-stop-the-world) + (collect-garbage gen) + (incf *n-bytes-freed-or-purified* + (max 0 (- pre-gc-dynamic-usage (dynamic-usage)))) + (scrub-control-stack) + (setf *need-to-collect-garbage* nil) + (dolist (h *after-gc-hooks*) (carefully-funcall h)) + (gc-start-the-world))))))) ;;; This is the user-advertised garbage collection function. (defun gc (&key (gen 0) (full nil) &allow-other-keys) Index: target-thread.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/src/code/target-thread.lisp,v retrieving revision 1.12 retrieving revision 1.12.2.1 diff -u -d -r1.12 -r1.12.2.1 --- target-thread.lisp 2 Oct 2003 23:13:09 -0000 1.12 +++ target-thread.lisp 23 Nov 2003 19:41:49 -0000 1.12.2.1 @@ -1,9 +1,18 @@ (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 + (sb!alien::define-alien-routine ("create_thread" %create-thread) sb!alien:unsigned-long (lisp-fun-address sb!alien:unsigned-long)) +(sb!alien::define-alien-routine "signal_thread_to_dequeue" + sb!alien:unsigned-int + (thread-pid sb!alien:unsigned-long)) + + (defun make-thread (function) (let ((real-function (coerce function 'function))) (%create-thread @@ -106,17 +115,43 @@ ;;;; 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-base-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)))) + (sb!alien:define-alien-routine "block_sigcont" void) (sb!alien:define-alien-routine "unblock_sigcont_and_sleep" void) +#!+sb-futex +(declaim (inline futex-wait futex-wake)) +#!+sb-futex +(sb!alien:define-alien-routine + "futex_wait" int (word unsigned-long) (old-value unsigned-long)) +#!+sb-futex +(sb!alien:define-alien-routine + "futex_wake" int (word unsigned-long) (n unsigned-long)) ;;; this should only be called while holding the queue spinlock. ;;; it releases the spinlock before sleeping @@ -140,13 +175,14 @@ ;;; this should only be called while holding the queue spinlock. (defun signal-queue-head (queue) (let ((p (car (waitqueue-data queue)))) - (when p (sb!unix:unix-kill p sb!unix::sig-dequeue)))) + (when p (signal-thread-to-dequeue p)))) ;;;; mutex +;;; i suspect there may be a race still in this: the futex version requires +;;; the old mutex value before sleeping, so how do we get away without it (defun get-mutex (lock &optional new-value (wait-p t)) - (declare (type mutex lock) - (optimize (speed 3))) + (declare (type mutex lock) (optimize (speed 3))) (let ((pid (current-thread-id))) (unless new-value (setf new-value pid)) (assert (not (eql new-value (mutex-value lock)))) @@ -163,6 +199,21 @@ (return nil)) (wait-on-queue lock nil)))) +#!+sb-futex +(defun get-mutex/futex (lock &optional new-value (wait-p t)) + (declare (type mutex lock) (optimize (speed 3))) + (let ((pid (current-thread-id)) + old) + (unless new-value (setf new-value pid)) + (assert (not (eql new-value (mutex-value 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 &optional (new-value nil)) (declare (type mutex lock)) ;; we assume the lock is ours to release @@ -170,6 +221,12 @@ (setf (mutex-value lock) new-value) (signal-queue-head lock))) +#!+sb-futex +(defun release-mutex/futex (lock) + (declare (type mutex lock)) + (setf (mutex-value lock) nil) + (futex-wake (mutex-value-address lock) 1)) + (defmacro with-mutex ((mutex &key value (wait-p t)) &body body) (with-unique-names (got) @@ -200,10 +257,64 @@ (dequeue queue)) (get-mutex lock value)))) +#!+sb-futex +(defun condition-wait/futex (queue lock) + (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" (with-spinlock (queue) (signal-queue-head queue))) +#!+sb-futex +(defun condition-notify/futex (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))) + +;; FIXME need non-futex variant of this too +#!+sb-futex +(defun condition-broadcast (queue) + "Notify all of the processes waiting on QUEUE." + (let ((me (current-thread-id))) + (setf (waitqueue-data queue) me) + (futex-wake (waitqueue-data-address queue) (ash 1 30)))) + +;;; Futexes may be available at compile time but not runtime, so we +;;; default to not using them unless os_init says they're available +(defun maybe-install-futex-functions () + #!+sb-futex + (unless (zerop (extern-alien "linux_supports_futex" int)) + (setf (fdefinition 'get-mutex) #'get-mutex/futex + (fdefinition 'release-mutex) #'release-mutex/futex + (fdefinition 'condition-wait) #'condition-wait/futex + (fdefinition 'condition-notify) #'condition-notify/futex) + t)) ;;;; multiple independent listeners @@ -239,28 +350,16 @@ ;;;; job control -(defvar *background-threads-wait-for-debugger* t) -;;; may be T, NIL, or a function called with a stream and thread id -;;; as its two arguments, returning NIl or T - ;;; 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 -already the foreground thread, or transfers control to the first applicable -restart if *BACKGROUND-THREADS-WAIT-FOR-DEBUGGER* says to do that instead" - (let* ((wait-p *background-threads-wait-for-debugger*) - (*background-threads-wait-for-debugger* nil) - (lock *session-lock*)) +already the foreground thread." + (let ((lock *session-lock*)) (when (not (eql (mutex-value lock) (CURRENT-THREAD-ID))) - (when (functionp wait-p) - (setf wait-p - (funcall wait-p stream (CURRENT-THREAD-ID)))) - (cond (wait-p (get-foreground)) - (t (invoke-restart (car (compute-restarts)))))))) + (get-foreground)))) -;;; install this with -;;; (setf SB-INT:*REPL-PROMPT-FUN* #'sb-thread::thread-repl-prompt-fun) -;;; One day it will be default +;;; note that this is broken in a futex world as no way to find out +;;; which threads are on a kernel queue (defun thread-repl-prompt-fun (out-stream) (let ((lock *session-lock*)) (get-foreground) @@ -268,141 +367,5 @@ (when stopped-threads (format out-stream "~{~&Thread ~A suspended~}~%" stopped-threads)) (sb!impl::repl-prompt-fun out-stream)))) - -(defun resume-stopped-thread (id) - (let ((lock *session-lock*)) - (with-spinlock (lock) - (setf (waitqueue-data lock) - (cons id (delete id (waitqueue-data lock))))) - (release-foreground))) - -(defstruct rwlock - (name nil :type (or null simple-base-string)) - (value 0 :type fixnum) - (max-readers nil :type (or fixnum null)) - (max-writers 1 :type fixnum)) -#+nil -(macrolet - ((make-rwlocking-function (lock-fn unlock-fn increment limit test) - (let ((do-update '(when (eql old-value - (sb!vm::%instance-set-conditional - lock 2 old-value new-value)) - (return (values t old-value)))) - (vars `((timeout (and timeout (+ (get-internal-real-time) timeout))) - old-value - new-value - (limit ,limit)))) - (labels ((do-setfs (v) `(setf old-value (rwlock-value lock) - new-value (,v old-value ,increment)))) - `(progn - (defun ,lock-fn (lock timeout) - (declare (type rwlock lock)) - (let ,vars - (loop - ,(do-setfs '+) - (when ,test - ,do-update) - (when (sleep-a-bit timeout) (return nil)) ;expired - ))) - ;; unlock doesn't need timeout or test-in-range - (defun ,unlock-fn (lock) - (declare (type rwlock lock)) - (declare (ignorable limit)) - (let ,(cdr vars) - (loop - ,(do-setfs '-) - ,do-update)))))))) - - (make-rwlocking-function %lock-for-reading %unlock-for-reading 1 - (rwlock-max-readers lock) - (and (>= old-value 0) - (or (null limit) (<= new-value limit)))) - (make-rwlocking-function %lock-for-writing %unlock-for-writing -1 - (- (rwlock-max-writers lock)) - (and (<= old-value 0) - (>= new-value limit)))) -#+nil -(defun get-rwlock (lock direction &optional timeout) - (ecase direction - (:read (%lock-for-reading lock timeout)) - (:write (%lock-for-writing lock timeout)))) -#+nil -(defun free-rwlock (lock direction) - (ecase direction - (:read (%unlock-for-reading lock)) - (:write (%unlock-for-writing lock)))) - -;;;; beyond this point all is commented. - -;;; Lock-Wait-With-Timeout -- Internal -;;; -;;; Wait with a timeout for the lock to be free and acquire it for the -;;; *current-process*. -;;; -#+nil -(defun lock-wait-with-timeout (lock whostate timeout) - (declare (type lock lock)) - (process-wait-with-timeout - whostate timeout - #'(lambda () - (declare (optimize (speed 3))) - #-i486 - (unless (lock-process lock) - (setf (lock-process lock) *current-process*)) - #+i486 - (null (kernel:%instance-set-conditional - lock 2 nil *current-process*))))) - -;;; With-Lock-Held -- Public -;;; -#+nil -(defmacro with-lock-held ((lock &optional (whostate "Lock Wait") - &key (wait t) timeout) - &body body) - "Execute the body with the lock held. If the lock is held by another - process then the current process waits until the lock is released or - an optional timeout is reached. The optional wait timeout is a time in - seconds acceptable to process-wait-with-timeout. The results of the - body are return upon success and NIL is return if the timeout is - reached. When the wait key is NIL and the lock is held by another - process then NIL is return immediately without processing the body." - (let ((have-lock (gensym))) - `(let ((,have-lock (eq (lock-process ,lock) *current-process*))) - (unwind-protect - ,(cond ((and timeout wait) - `(progn - (when (and (error-check-lock-p ,lock) ,have-lock) - (error "Dead lock")) - (when (or ,have-lock - #+i486 (null (kernel:%instance-set-conditional - ,lock 2 nil *current-process*)) - #-i486 (seize-lock ,lock) - (if ,timeout - (lock-wait-with-timeout - ,lock ,whostate ,timeout) - (lock-wait ,lock ,whostate))) - ,@body))) - (wait - `(progn - (when (and (error-check-lock-p ,lock) ,have-lock) - (error "Dead lock")) - (unless (or ,have-lock - #+i486 (null (kernel:%instance-set-conditional - ,lock 2 nil *current-process*)) - #-i486 (seize-lock ,lock)) - (lock-wait ,lock ,whostate)) - ,@body)) - (t - `(when (or (and (recursive-lock-p ,lock) ,have-lock) - #+i486 (null (kernel:%instance-set-conditional - ,lock 2 nil *current-process*)) - #-i486 (seize-lock ,lock)) - ,@body))) - (unless ,have-lock - #+i486 (kernel:%instance-set-conditional - ,lock 2 *current-process* nil) - #-i486 (when (eq (lock-process ,lock) *current-process*) - (setf (lock-process ,lock) nil))))))) - |