X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Ftarget-thread.lisp;h=218e355a878b089198e2d0efb45fbc1be4caab1f;hb=fe420bb47ea909070ee82c6e48642c9ff41dbcc8;hp=2ad4674f70bbc6bca1711f65bf4b282d27fdbcb5;hpb=5d811ef35f080723cfe2aacd128db320620c759c;p=sbcl.git diff --git a/src/code/target-thread.lisp b/src/code/target-thread.lisp index 2ad4674..218e355 100644 --- a/src/code/target-thread.lisp +++ b/src/code/target-thread.lisp @@ -60,12 +60,7 @@ in future versions." (defvar *all-threads-lock* (make-mutex :name "all threads lock")) (defmacro with-all-threads-lock (&body body) - #!-sb-thread - `(locally ,@body) - #!+sb-thread - `(without-interrupts - (with-mutex (*all-threads-lock*) - ,@body))) + `(call-with-system-mutex (lambda () ,@body) *all-threads-lock*)) (defun list-all-threads () #!+sb-doc @@ -115,25 +110,25 @@ in future versions." (declaim (inline %lutex-init %lutex-wait %lutex-wake %lutex-lock %lutex-unlock)) - (sb!alien:define-alien-routine ("lutex_init" %lutex-init) + (define-alien-routine ("lutex_init" %lutex-init) int (lutex unsigned-long)) - (sb!alien:define-alien-routine ("lutex_wait" %lutex-wait) + (define-alien-routine ("lutex_wait" %lutex-wait) int (queue-lutex unsigned-long) (mutex-lutex unsigned-long)) - (sb!alien:define-alien-routine ("lutex_wake" %lutex-wake) + (define-alien-routine ("lutex_wake" %lutex-wake) int (lutex unsigned-long) (n int)) - (sb!alien:define-alien-routine ("lutex_lock" %lutex-lock) + (define-alien-routine ("lutex_lock" %lutex-lock) int (lutex unsigned-long)) - (sb!alien:define-alien-routine ("lutex_trylock" %lutex-trylock) + (define-alien-routine ("lutex_trylock" %lutex-trylock) int (lutex unsigned-long)) - (sb!alien:define-alien-routine ("lutex_unlock" %lutex-unlock) + (define-alien-routine ("lutex_unlock" %lutex-unlock) int (lutex unsigned-long)) - (sb!alien:define-alien-routine ("lutex_destroy" %lutex-destroy) + (define-alien-routine ("lutex_destroy" %lutex-destroy) int (lutex unsigned-long)) ;; FIXME: Defining a whole bunch of alien-type machinery just for @@ -160,12 +155,17 @@ in future versions." #!-sb-lutex (progn - (declaim (inline futex-wait futex-wake)) + (declaim (inline futex-wait %futex-wait futex-wake)) + + (define-alien-routine ("futex_wait" %futex-wait) + int (word unsigned-long) (old-value unsigned-long) + (to-sec long) (to-usec unsigned-long)) - (sb!alien:define-alien-routine "futex_wait" - int (word unsigned-long) (old-value unsigned-long)) + (defun futex-wait (word old to-sec to-usec) + (with-interrupts + (%futex-wait word old to-sec to-usec))) - (sb!alien:define-alien-routine "futex_wake" + (define-alien-routine "futex_wake" int (word unsigned-long) (n unsigned-long)))) ;;; used by debug-int.lisp to access interrupt contexts @@ -181,34 +181,32 @@ in future versions." (declare (type (unsigned-byte 27) n)) (sb!vm::current-thread-offset-sap n)) -;;;; spinlocks -#!+sb-thread -(define-structure-slot-compare-and-exchange - compare-and-exchange-spinlock-value - :structure spinlock - :slot value) - (declaim (inline get-spinlock release-spinlock)) +;; Should always be called with interrupts disabled. (defun get-spinlock (spinlock) - (declare (optimize (speed 3) (safety 0)) - #!-sb-thread - (ignore spinlock)) - ;; %instance-set-conditional can test for 0 (which is a fixnum) and - ;; store any value - #!+sb-thread - (loop until - (eql 0 (compare-and-exchange-spinlock-value spinlock 0 1))) - t) + (declare (optimize (speed 3) (safety 0))) + (let* ((new *current-thread*) + (old (sb!ext:compare-and-swap (spinlock-value spinlock) nil new))) + (when old + (when (eq old new) + (error "Recursive lock attempt on ~S." spinlock)) + #!+sb-thread + (flet ((cas () + (unless (sb!ext:compare-and-swap (spinlock-value spinlock) nil new) + (return-from get-spinlock t)))) + (if (and (not *interrupts-enabled*) *allow-with-interrupts*) + ;; If interrupts are enabled, but we are allowed to enabled them, + ;; check for pending interrupts every once in a while. + (loop + (loop repeat 128 do (cas)) ; 128 is arbitrary here + (sb!unix::%check-interrupts)) + (loop (cas))))) + t)) (defun release-spinlock (spinlock) - (declare (optimize (speed 3) (safety 0)) - #!-sb-thread (ignore spinlock)) - ;; %instance-set-conditional cannot compare arbitrary objects - ;; meaningfully, so (compare-and-exchange-spinlock-value our-value 0) - ;; does not work for bignum thread ids. - #!+sb-thread - (setf (spinlock-value spinlock) 0) + (declare (optimize (speed 3) (safety 0))) + (setf (spinlock-value spinlock) nil) nil) ;;;; mutexes @@ -217,76 +215,131 @@ in future versions." (setf (fdocumentation 'make-mutex 'function) "Create a mutex." (fdocumentation 'mutex-name 'function) - "The name of the mutex. Setfable." - (fdocumentation 'mutex-value 'function) - "The value of the mutex. NIL if the mutex is free. Setfable.") + "The name of the mutex. Setfable.") #!+(and sb-thread (not sb-lutex)) (progn - (define-structure-slot-addressor mutex-value-address - :structure mutex - :slot value) - (define-structure-slot-compare-and-exchange - compare-and-exchange-mutex-value + (define-structure-slot-addressor mutex-state-address :structure mutex - :slot value)) - -(defun get-mutex (mutex &optional (new-value *current-thread*) (wait-p t)) + :slot state) + ;; Important: current code assumes these are fixnums or other + ;; lisp objects that don't need pinning. + (defconstant +lock-free+ 0) + (defconstant +lock-taken+ 1) + (defconstant +lock-contested+ 2)) + +(defun get-mutex (mutex &optional (new-owner *current-thread*) (waitp 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))) - (/show0 "Entering GET-MUTEX") - (unless new-value - (setq 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) + "Acquire MUTEX for NEW-OWNER, which must be a thread or NIL. If +NEW-OWNER is NIL, it defaults to the current thread. If WAITP is +non-NIL and the mutex is in use, sleep until it is available. + +Note: using GET-MUTEX to assign a MUTEX to another thread then the +current one is not recommended, and liable to be deprecated. + +GET-MUTEX is not interrupt safe. The correct way to call it is: + + (WITHOUT-INTERRUPTS + ... + (ALLOW-WITH-INTERRUPTS (GET-MUTEX ...)) + ...) + +WITHOUT-INTERRUPTS is necessary to avoid an interrupt unwinding the +call while the mutex is in an inconsistent state while +ALLOW-WITH-INTERRUPTS allows the call to be interrupted from sleep. + +It is recommended that you use WITH-MUTEX instead of calling GET-MUTEX +directly." + (declare (type mutex mutex) (optimize (speed 3)) + #!-sb-thread (ignore waitp)) + (unless new-owner + (setq new-owner *current-thread*)) + (when (eql new-owner (mutex-%owner mutex)) + (error "Recursive lock attempt ~S." mutex)) #!+sb-thread (progn - (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*)) + ;; FIXME: Lutexes do not currently support deadlines, as at least + ;; on Darwin pthread_foo_timedbar functions are not supported: + ;; this means that we probably need to use the Carbon multiprocessing + ;; functions on Darwin. + ;; + ;; FIXME: This is definitely not interrupt safe: what happens if + ;; we get hit (1) during the lutex calls (ok, they may be safe, + ;; but has that been checked?) (2) after the lutex call, but + ;; before setting the mutex owner. #!+sb-lutex (when (zerop (with-lutex-address (lutex (mutex-lutex mutex)) - (if wait-p - (%lutex-lock lutex) + (if waitp + (with-interrupts (%lutex-lock lutex)) (%lutex-trylock lutex)))) - (setf (mutex-value mutex) new-value)) + (setf (mutex-%owner mutex) new-owner) + t) #!-sb-lutex - (let (old) - (loop - (unless - (setf old - (compare-and-exchange-mutex-value mutex nil new-value)) - (return t)) - (unless wait-p (return nil)) - (with-pinned-objects (mutex old) - (futex-wait (mutex-value-address mutex) - (get-lisp-obj-address old))))))) + (let ((old (sb!ext:compare-and-swap (mutex-state mutex) + +lock-free+ + +lock-taken+))) + (unless (or (eql +lock-free+ old) (not waitp)) + (tagbody + :retry + (when (or (eql +lock-contested+ old) + (not (eql +lock-free+ + (sb!ext:compare-and-swap (mutex-state mutex) + +lock-taken+ + +lock-contested+)))) + ;; Wait on the contested lock. + (multiple-value-bind (to-sec to-usec) (decode-timeout nil) + (when (= 1 (with-pinned-objects (mutex) + (futex-wait (mutex-state-address mutex) + (get-lisp-obj-address +lock-contested+) + (or to-sec -1) + (or to-usec 0)))) + (signal-deadline)))) + (setf old (sb!ext:compare-and-swap (mutex-state mutex) + +lock-free+ + +lock-contested+)) + ;; Did we get it? + (unless (eql +lock-free+ old) + (go :retry)))) + (cond ((eql +lock-free+ old) + (let ((prev (sb!ext:compare-and-swap (mutex-%owner mutex) + nil new-owner))) + (when prev + (bug "Old owner in free mutex: ~S" prev)) + t)) + (waitp + (bug "Failed to acquire lock with WAITP.")))))) (defun release-mutex (mutex) #!+sb-doc "Release MUTEX by setting it to NIL. Wake up threads waiting for -this mutex." +this mutex. + +RELEASE-MUTEX is not interrupt safe: interrupts should be disabled +around calls to it. + +Signals a WARNING is current thread is not the current owner of the +mutex." (declare (type mutex mutex)) - (/show0 "Entering RELEASE-MUTEX") - (setf (mutex-value mutex) nil) + ;; Order matters: set owner to NIL before releasing state. + (let* ((self *current-thread*) + (old-owner (sb!ext:compare-and-swap (mutex-%owner mutex) self nil))) + (unless (eql self old-owner) + (warn "Releasing ~S, owned by another thread: ~S" mutex old-owner) + (setf (mutex-%owner mutex) nil))) #!+sb-thread (progn #!+sb-lutex (with-lutex-address (lutex (mutex-lutex mutex)) (%lutex-unlock lutex)) #!-sb-lutex - (futex-wake (mutex-value-address mutex) 1))) + (let ((old (sb!ext:compare-and-swap (mutex-state mutex) + +lock-taken+ +lock-free+))) + (when (eql old +lock-contested+) + (sb!ext:compare-and-swap (mutex-state mutex) + +lock-contested+ +lock-free+) + (with-pinned-objects (mutex) + (futex-wake (mutex-state-address mutex) 1)))) + nil)) ;;;; waitqueues/condition variables @@ -322,35 +375,41 @@ time we reacquire MUTEX and return to the caller." (assert mutex) #!-sb-thread (error "Not supported in unithread builds.") #!+sb-thread - (let ((value (mutex-value mutex))) + (let ((owner (mutex-%owner mutex))) (/show0 "CONDITION-WAITing") #!+sb-lutex (progn - (setf (mutex-value mutex) nil) + ;; FIXME: This doesn't look interrupt safe! + (setf (mutex-%owner mutex) nil) (with-lutex-address (queue-lutex-address (waitqueue-lutex queue)) (with-lutex-address (mutex-lutex-address (mutex-lutex mutex)) (%lutex-wait queue-lutex-address mutex-lutex-address))) - (setf (mutex-value mutex) value)) + (setf (mutex-%owner mutex) owner)) #!-sb-lutex (unwind-protect (let ((me *current-thread*)) - ;; XXX we should do something to ensure that the result of this setf - ;; is visible to all CPUs + ;; FIXME: should we 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 - (with-pinned-objects (queue me) - (futex-wait (waitqueue-data-address queue) - (get-lisp-obj-address me)))) + ;; Ergo, no lost wakeup. We may get spurious wakeups, + ;; but that's ok. + (multiple-value-bind (to-sec to-usec) (decode-timeout nil) + (when (= 1 (with-pinned-objects (queue me) + (futex-wait (waitqueue-data-address queue) + (get-lisp-obj-address me) + (or to-sec -1) ;; our way if saying "no timeout" + (or to-usec 0)))) + (signal-deadline)))) ;; 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)))) + (get-mutex mutex owner)))) (defun condition-notify (queue &optional (n 1)) #!+sb-doc @@ -388,41 +447,48 @@ time we reacquire MUTEX and return to the caller." ;;;; semaphores -(defstruct (semaphore (:constructor %make-semaphore)) +(defstruct (semaphore (:constructor %make-semaphore (name %count))) #!+sb-doc - "Semaphore type." + "Semaphore type. The fact that a SEMAPHORE is a STRUCTURE-OBJECT +should be considered an implementation detail, and may change in the +future." (name nil :type (or null simple-string)) - (count 0 :type (integer 0)) + (%count 0 :type (integer 0)) (mutex (make-mutex)) (queue (make-waitqueue))) +(setf (fdocumentation 'semaphore-name 'function) + "The name of the semaphore INSTANCE. Setfable.") + +(declaim (inline semaphore-count)) +(defun semaphore-count (instance) + "Returns the current count of the semaphore INSTANCE." + (semaphore-%count instance)) + (defun make-semaphore (&key name (count 0)) #!+sb-doc - "Create a semaphore with the supplied COUNT." - (%make-semaphore :name name :count count)) + "Create a semaphore with the supplied COUNT and NAME." + (%make-semaphore name count)) -(setf (fdocumentation 'semaphore-name 'function) - "The name of the semaphore. Setfable.") - -(defun wait-on-semaphore (sem) +(defun wait-on-semaphore (semaphore) #!+sb-doc - "Decrement the count of SEM if the count would not be negative. Else -block until the semaphore can be decremented." + "Decrement the count of SEMAPHORE if the count would not be +negative. Else blocks until the semaphore can be decremented." ;; a more direct implementation based directly on futexes should be ;; possible - (with-mutex ((semaphore-mutex sem)) - (loop until (> (semaphore-count sem) 0) - do (condition-wait (semaphore-queue sem) (semaphore-mutex sem)) - finally (decf (semaphore-count sem))))) + (with-mutex ((semaphore-mutex semaphore)) + (loop until (> (semaphore-%count semaphore) 0) + do (condition-wait (semaphore-queue semaphore) (semaphore-mutex semaphore)) + finally (decf (semaphore-%count semaphore))))) -(defun signal-semaphore (sem &optional (n 1)) +(defun signal-semaphore (semaphore &optional (n 1)) #!+sb-doc - "Increment the count of SEM by N. If there are threads waiting on -this semaphore, then N of them is woken up." - (declare (type (and fixnum (integer 1)) n)) - (with-mutex ((semaphore-mutex sem)) - (when (= n (incf (semaphore-count sem) n)) - (condition-notify (semaphore-queue sem) n)))) + "Increment the count of SEMAPHORE by N. If there are threads waiting +on this semaphore, then N of them is woken up." + (declare (type (integer 1) n)) + (with-mutex ((semaphore-mutex semaphore)) + (when (= n (incf (semaphore-%count semaphore) n)) + (condition-notify (semaphore-queue semaphore) n)))) ;;;; job control, independent listeners @@ -438,13 +504,7 @@ this semaphore, then N of them is woken up." ;;; 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 - `(without-interrupts - (with-mutex ((session-lock ,session)) - ,@body))) + `(call-with-system-mutex (lambda () ,@body) (session-lock ,session))) (defun new-session () (make-session :threads (list *current-thread*) @@ -623,12 +683,14 @@ around and can be retrieved by JOIN-THREAD." (*restart-clusters* nil) (*handler-clusters* nil) (*condition-restarts* nil) + (sb!impl::*deadline* nil) (sb!impl::*step-out* nil) ;; internal printer variables (sb!impl::*previous-case* nil) (sb!impl::*previous-readtable-case* nil) - (sb!impl::*merge-sort-temp-vector* (vector)) ; keep these small! - (sb!impl::*zap-array-data-temp* (vector)) ; + (empty (vector)) + (sb!impl::*merge-sort-temp-vector* empty) + (sb!impl::*zap-array-data-temp* empty) (sb!impl::*internal-symbol-output-fun* nil) (sb!impl::*descriptor-handlers* nil)) ; serve-event (setf (thread-os-thread thread) (current-thread-sap-id)) @@ -716,11 +778,9 @@ return DEFAULT if given or else signal JOIN-THREAD-ERROR." "The thread that was not interrupted.") (defmacro with-interruptions-lock ((thread) &body body) - `(without-interrupts - (with-mutex ((thread-interruptions-lock ,thread)) - ,@body))) + `(call-with-system-mutex (lambda () ,@body) (thread-interruptions-lock ,thread))) -;; Called from the signal handler. +;; Called from the signal handler in C. (defun run-interruption () (in-interruption () (loop @@ -746,13 +806,13 @@ 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) + (with-interrupt-bindings + (with-interrupts (funcall function))) #!+sb-thread (if (eq thread *current-thread*) - (funcall function) + (with-interrupt-bindings + (with-interrupts (funcall function))) (let ((os-thread (thread-os-thread thread))) (cond ((not os-thread) (error 'interrupt-thread-error :thread thread)) @@ -785,6 +845,12 @@ SB-EXT:QUIT - the usual cleanup forms will be evaluated" (sap-ref-sap thread-sap (* sb!vm:n-word-bytes sb!vm::thread-next-slot))))))) +(define-alien-routine "thread_yield" int) + +#!+sb-doc +(setf (fdocumentation 'thread-yield 'function) + "Yield the processor to other threads.") + #!+sb-thread (defun symbol-value-in-thread (symbol thread-sap) (let* ((index (sb!vm::symbol-tls-index symbol))