X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Ftarget-thread.lisp;h=19f27472de6112166f58a4ee7404e1f662c9d7e7;hb=8643c93d4db277f6e1cb880a42407ff29e19f618;hp=57747fc659d91427c23f84e155bdaf67524cb4db;hpb=78c2361d1d9e680230df412f4d1489725781c6d2;p=sbcl.git diff --git a/src/code/target-thread.lisp b/src/code/target-thread.lisp index 57747fc..19f2747 100644 --- a/src/code/target-thread.lisp +++ b/src/code/target-thread.lisp @@ -19,7 +19,7 @@ ;;; set the doc here because in early-thread FDOCUMENTATION is not ;;; available, yet #!+sb-doc -(setf (sb!kernel:fdocumentation '*current-thread* 'variable) +(setf (fdocumentation '*current-thread* 'variable) "Bound in each thread to the thread itself.") (defstruct (thread (:constructor %make-thread)) @@ -35,7 +35,7 @@ in future versions." (result-lock (make-mutex :name "thread result lock"))) #!+sb-doc -(setf (sb!kernel:fdocumentation 'thread-name 'function) +(setf (fdocumentation 'thread-name 'function) "The name of the thread. Setfable.") (def!method print-object ((thread thread) stream) @@ -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 @@ -143,7 +138,7 @@ in future versions." (defmacro with-lutex-address ((name lutex) &body body) `(let ((,name ,lutex)) (with-pinned-objects (,name) - (let ((,name (sb!kernel:get-lisp-obj-address ,name))) + (let ((,name (get-lisp-obj-address ,name))) ,@body)))) (defun make-lutex () @@ -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,75 +181,63 @@ in future versions." (declare (type (unsigned-byte 27) n)) (sb!vm::current-thread-offset-sap n)) -;;;; spinlocks - (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 +;; Should always be called with interrupts disabled. (defun get-spinlock (spinlock) - (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 1) 0))) + (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 - ;; (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) - (unwind-protect - (progn ,@body) - (release-spinlock ,lock))))) + (declare (optimize (speed 3) (safety 0))) + (setf (spinlock-value spinlock) nil) + nil) ;;;; mutexes #!+sb-doc -(setf (sb!kernel:fdocumentation 'make-mutex 'function) +(setf (fdocumentation 'make-mutex 'function) "Create a mutex." - (sb!kernel:fdocumentation 'mutex-name 'function) + (fdocumentation 'mutex-name 'function) "The name of the mutex. Setfable." - (sb!kernel:fdocumentation 'mutex-value 'function) + (fdocumentation 'mutex-value 'function) "The value of the mutex. NIL if the mutex is free. Setfable.") #!+(and sb-thread (not sb-lutex)) -(progn - (declaim (inline mutex-value-address)) - (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 *current-thread*) (wait-p t)) +(define-structure-slot-addressor mutex-value-address + :structure mutex + :slot value) + +(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 -until it is available" + "Acquire MUTEX, setting it to NEW-VALUE or some suitable default 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 @@ -259,23 +247,35 @@ 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. + ;; + ;; 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 value. #!+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)) #!-sb-lutex (let (old) - (loop - (unless - (setf old (sb!vm::%instance-set-conditional mutex 2 nil - new-value)) - (return t)) - (unless wait-p (return nil)) - (with-pinned-objects (mutex old) - (futex-wait (mutex-value-address mutex) - (sb!kernel:get-lisp-obj-address old))))))) + (when (and (setf old (sb!ext: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 (sb!ext:compare-and-swap (mutex-value mutex) nil new-value)))) + (not old)))) (defun release-mutex (mutex) #!+sb-doc @@ -309,18 +309,13 @@ this mutex." (%make-waitqueue :name name)) #!+sb-doc -(setf (sb!kernel:fdocumentation 'waitqueue-name 'function) +(setf (fdocumentation 'waitqueue-name 'function) "The name of the waitqueue. Setfable.") #!+(and sb-thread (not sb-lutex)) -(progn - (declaim (inline waitqueue-data-address)) - (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))))) +(define-structure-slot-addressor waitqueue-data-address + :structure waitqueue + :slot data) (defun condition-wait (queue mutex) #!+sb-doc @@ -335,6 +330,7 @@ time we reacquire MUTEX and return to the caller." (/show0 "CONDITION-WAITing") #!+sb-lutex (progn + ;; FIXME: This doesn't look interrupt safe! (setf (mutex-value mutex) nil) (with-lutex-address (queue-lutex-address (waitqueue-lutex queue)) (with-lutex-address (mutex-lutex-address (mutex-lutex mutex)) @@ -343,18 +339,23 @@ time we reacquire MUTEX and return to the caller." #!-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) - (sb!kernel: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 @@ -410,7 +411,7 @@ time we reacquire MUTEX and return to the caller." "Create a semaphore with the supplied COUNT." (%make-semaphore :name name :count count)) -(setf (sb!kernel:fdocumentation 'semaphore-name 'function) +(setf (fdocumentation 'semaphore-name 'function) "The name of the semaphore. Setfable.") (defun wait-on-semaphore (sem) @@ -447,13 +448,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*) @@ -497,7 +492,7 @@ this semaphore, then N of them is woken up." (when *session* (%delete-thread-from-session thread *session*))) #!+sb-lutex - (when (thread-interruptions-lock thread) + (without-gcing (/show0 "FREEING MUTEX LUTEX") (with-lutex-address (lutex (mutex-lutex (thread-interruptions-lock thread))) (%lutex-destroy lutex)))) @@ -629,9 +624,9 @@ around and can be retrieved by JOIN-THREAD." ;; least accessible to users to secure their own libraries. ;; --njf, 2006-07-15 (let ((*current-thread* thread) - (sb!kernel::*restart-clusters* nil) - (sb!kernel::*handler-clusters* nil) - (sb!kernel::*condition-restarts* nil) + (*restart-clusters* nil) + (*handler-clusters* nil) + (*condition-restarts* nil) (sb!impl::*step-out* nil) ;; internal printer variables (sb!impl::*previous-case* nil) @@ -675,7 +670,7 @@ around and can be retrieved by JOIN-THREAD." (with-pinned-objects (initial-function) (let ((os-thread (%create-thread - (sb!kernel:get-lisp-obj-address initial-function)))) + (get-lisp-obj-address initial-function)))) (when (zerop os-thread) (error "Can't create a new thread")) (wait-on-semaphore setup-sem) @@ -691,7 +686,7 @@ around and can be retrieved by JOIN-THREAD." (join-thread-error-thread c))))) #!+sb-doc -(setf (sb!kernel:fdocumentation 'join-thread-error-thread 'function) +(setf (fdocumentation 'join-thread-error-thread 'function) "The thread that we failed to join.") (defun join-thread (thread &key (default nil defaultp)) @@ -721,15 +716,13 @@ return DEFAULT if given or else signal JOIN-THREAD-ERROR." (interrupt-thread-error-thread c))))) #!+sb-doc -(setf (sb!kernel:fdocumentation 'interrupt-thread-error-thread 'function) +(setf (fdocumentation 'interrupt-thread-error-thread 'function) "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 @@ -755,13 +748,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)) @@ -801,7 +794,7 @@ SB-EXT:QUIT - the usual cleanup forms will be evaluated" (* sb!vm:n-word-bytes index)))) (if (eql tl-val sb!vm::no-tls-value-marker-widetag) (sb!vm::symbol-global-value symbol) - (sb!kernel:make-lisp-obj tl-val)))) + (make-lisp-obj tl-val)))) (defun sb!vm::locked-symbol-global-value-add (symbol-name delta) (sb!vm::locked-symbol-global-value-add symbol-name delta)) @@ -809,11 +802,11 @@ SB-EXT:QUIT - the usual cleanup forms will be evaluated" ;;; Stepping (defun thread-stepping () - (sb!kernel:make-lisp-obj + (make-lisp-obj (sap-ref-word (current-thread-sap) (* sb!vm::thread-stepping-slot sb!vm:n-word-bytes)))) (defun (setf thread-stepping) (value) (setf (sap-ref-word (current-thread-sap) (* sb!vm::thread-stepping-slot sb!vm:n-word-bytes)) - (sb!kernel:get-lisp-obj-address value))) + (get-lisp-obj-address value)))