X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Ftarget-thread.lisp;h=c2fe73c43a1948ed1ba6b347b6c8969e4805bd0f;hb=d8978f48b6c8b583612f6adbe33d3030f862ef87;hp=be8eeb4c4d95cc631585898e42a611b081ca8393;hpb=a7409fa0a69f733ea2460a1aeddbe04b5c4c0888;p=sbcl.git diff --git a/src/code/target-thread.lisp b/src/code/target-thread.lisp index be8eeb4..c2fe73c 100644 --- a/src/code/target-thread.lisp +++ b/src/code/target-thread.lisp @@ -163,7 +163,8 @@ in future versions." (declaim (inline futex-wait futex-wake)) (sb!alien:define-alien-routine "futex_wait" - int (word unsigned-long) (old-value unsigned-long)) + int (word unsigned-long) (old-value unsigned-long) + (to-sec long) (to-usec unsigned-long)) (sb!alien:define-alien-routine "futex_wake" int (word unsigned-long) (n unsigned-long)))) @@ -182,46 +183,29 @@ in future versions." (sb!vm::current-thread-offset-sap n)) ;;;; spinlocks -#!+sb-thread -(define-structure-slot-compare-and-exchange - compare-and-exchange-spinlock-value +(define-structure-slot-compare-and-swap + compare-and-swap-spinlock-value :structure spinlock :slot value) (declaim (inline get-spinlock release-spinlock)) (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))) + (declare (optimize (speed 3) (safety 0))) + (let* ((new *current-thread*) + (old (compare-and-swap-spinlock-value spinlock nil new))) + (when old + (when (eq old new) + (error "Recursive lock attempt on ~S." spinlock)) + #!+sb-thread + (loop while (compare-and-swap-spinlock-value spinlock nil new)))) 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) -(defmacro with-spinlock ((spinlock) &body body) - (sb!int:with-unique-names (lock got-it) - `(let ((,lock ,spinlock) - (,got-it nil)) - (unwind-protect - (progn - (setf ,got-it (get-spinlock ,lock)) - (locally ,@body)) - (when ,got-it - (release-spinlock ,lock)))))) - ;;;; mutexes #!+sb-doc @@ -237,26 +221,26 @@ in future versions." (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-compare-and-swap + compare-and-swap-mutex-value :structure mutex :slot value)) -(defun get-mutex (mutex &optional (new-value *current-thread*) (wait-p t)) +(defun get-mutex (mutex &optional (new-value *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 +value if NIL. If WAITP 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 ~ + (let ((old (mutex-value mutex))) + (when (and old waitp) + (error "In unithread mode, mutex ~S was requested with WAITP ~S and ~ new-value ~S, but has already been acquired (with value ~S)." - mutex wait-p new-value old-value)) + mutex waitp new-value old)) (setf (mutex-value mutex) new-value) t) #!+sb-thread @@ -266,23 +250,30 @@ until it is available." (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. #!+sb-lutex (when (zerop (with-lutex-address (lutex (mutex-lutex mutex)) - (if wait-p + (if waitp (%lutex-lock lutex) (%lutex-trylock lutex)))) (setf (mutex-value mutex) new-value)) #!-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))))))) + (when (and (setf old (compare-and-swap-mutex-value mutex nil new-value)) + waitp) + (loop while old + do (multiple-value-bind (to-sec to-usec) (decode-timeout nil) + (when (= 1 (with-pinned-objects (mutex old) + (futex-wait (mutex-value-address mutex) + (get-lisp-obj-address old) + (or to-sec -1) + (or to-usec 0)))) + (signal-deadline))) + (setf old (compare-and-swap-mutex-value mutex nil new-value)))) + (not old)))) (defun release-mutex (mutex) #!+sb-doc @@ -353,10 +344,15 @@ time we reacquire MUTEX and return to the caller." ;; 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 @@ -731,13 +727,15 @@ return DEFAULT if given or else signal JOIN-THREAD-ERROR." (with-mutex ((thread-interruptions-lock ,thread)) ,@body))) -;; Called from the signal handler. +;; Called from the signal handler in C. (defun run-interruption () (in-interruption () (loop (let ((interruption (with-interruptions-lock (*current-thread*) (pop (thread-interruptions *current-thread*))))) (if interruption + ;; This is safe because it's the IN-INTERRUPTION that + ;; has disabled interrupts. (with-interrupts (funcall interruption)) (return)))))) @@ -757,21 +755,29 @@ 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 - (if (eq thread *current-thread*) - (funcall function) - (let ((os-thread (thread-os-thread thread))) - (cond ((not os-thread) - (error 'interrupt-thread-error :thread thread)) - (t - (with-interruptions-lock (thread) - (push function (thread-interruptions thread))) - (when (minusp (signal-interrupt-thread os-thread)) - (error 'interrupt-thread-error :thread thread))))))) + (flet ((interrupt-self () + ;; *IN-INTERRUPTION* is true IFF we're being called as an + ;; interruption without an intervening WITHOUT-INTERRUPTS, + ;; in which case it is safe to enable interrupts. Otherwise + ;; interrupts are either already enabled, or there is an outer + ;; WITHOUT-INTERRUPTS we know nothing about, which makes it + ;; unsafe to enable interrupts. + (if *in-interruption* + (with-interrupts (funcall function)) + (funcall function)))) + #!-sb-thread + (interrupt-self) + #!+sb-thread + (if (eq thread *current-thread*) + (interrupt-self) + (let ((os-thread (thread-os-thread thread))) + (cond ((not os-thread) + (error 'interrupt-thread-error :thread thread)) + (t + (with-interruptions-lock (thread) + (push function (thread-interruptions thread))) + (when (minusp (signal-interrupt-thread os-thread)) + (error 'interrupt-thread-error :thread thread)))))))) (defun terminate-thread (thread) #!+sb-doc