X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Ftarget-thread.lisp;h=bc478fafc0c68ec77a95641d52c51d000a94e755;hb=85a570a6668fbca35a7a600ac3b2045bf2fb922a;hp=9ab61b18f7ca16ff07de83f872f693c1e02eaf1d;hpb=cf8e7223bce9948aaa764fd407871f0c441b3097;p=sbcl.git diff --git a/src/code/target-thread.lisp b/src/code/target-thread.lisp index 9ab61b1..bc478fa 100644 --- a/src/code/target-thread.lisp +++ b/src/code/target-thread.lisp @@ -59,17 +59,9 @@ offending thread using THREAD-ERROR-THREAD.")) to be joined. The offending thread can be accessed using THREAD-ERROR-THREAD.")) -(defun join-thread-error-thread (condition) +(define-deprecated-function :late "1.0.29.17" join-thread-error-thread thread-error-thread + (condition) (thread-error-thread condition)) -(define-compiler-macro join-thread-error-thread (condition) - (deprecation-warning 'join-thread-error-thread 'thread-error-thread) - `(thread-error-thread ,condition)) - -#!+sb-doc -(setf - (fdocumentation 'join-thread-error-thread 'function) - "The thread that we failed to join. Deprecated, use THREAD-ERROR-THREAD -instead.") (define-condition interrupt-thread-error (thread-error) () (:report (lambda (c s) @@ -80,17 +72,9 @@ instead.") "Signalled when interrupting a thread fails because the thread has already exited. The offending thread can be accessed using THREAD-ERROR-THREAD.")) -(defun interrupt-thread-error-thread (condition) +(define-deprecated-function :late "1.0.29.17" interrupt-thread-error-thread thread-error-thread + (condition) (thread-error-thread condition)) -(define-compiler-macro interrupt-thread-error-thread (condition) - (deprecation-warning 'join-thread-error-thread 'thread-error-thread) - `(thread-error-thread ,condition)) - -#!+sb-doc -(setf - (fdocumentation 'interrupt-thread-error-thread 'function) - "The thread that was not interrupted. Deprecated, use THREAD-ERROR-THREAD -instead.") ;;; Of the WITH-PINNED-OBJECTS in this file, not every single one is ;;; necessary because threads are only supported with the conservative @@ -325,7 +309,12 @@ created and old ones may exit at any time." ;; FIXME: this does not work on SMP Pentium Pro and OOSTORE systems, ;; neither on most non-x86 architectures (but we don't have threads ;; on those). - (setf (spinlock-value spinlock) nil)) + (setf (spinlock-value spinlock) nil) + + ;; FIXME: Is a :memory barrier too strong here? Can we use a :write + ;; barrier instead? + #!+(not (or x86 x86-64)) + (barrier (:memory))) ;;;; Mutexes @@ -361,10 +350,10 @@ HOLDING-MUTEX-P." #!+sb-doc "Deprecated in favor of GRAB-MUTEX." (declare (type mutex mutex) (optimize (speed 3)) - #!-sb-thread (ignore waitp timeout) - #!+sb-lutex (ignore timeout)) + #!-sb-thread (ignore waitp timeout)) (unless new-owner (setq new-owner *current-thread*)) + (barrier (:read)) (let ((old (mutex-%owner mutex))) (when (eq new-owner old) (error "Recursive lock attempt ~S." mutex)) @@ -385,12 +374,16 @@ HOLDING-MUTEX-P." ;; 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 waitp - (with-interrupts (%lutex-lock lutex)) - (%lutex-trylock lutex)))) - (setf (mutex-%owner mutex) new-owner) - t) + (progn + (when timeout + (error "Mutex timeouts not supported on this platform.")) + (when (zerop (with-lutex-address (lutex (mutex-lutex mutex)) + (if waitp + (with-interrupts (%lutex-lock lutex)) + (%lutex-trylock lutex)))) + (setf (mutex-%owner mutex) new-owner) + (barrier (:write)) + t)) #!-sb-lutex ;; This is a direct translation of the Mutex 2 algorithm from ;; "Futexes are Tricky" by Ulrich Drepper. @@ -435,16 +428,15 @@ HOLDING-MUTEX-P." (waitp (bug "Failed to acquire lock with WAITP.")))))) -(defun grab-mutex (mutex &key (new-owner *current-thread*) - (waitp t) (timeout nil)) +(defun grab-mutex (mutex &key (waitp t) (timeout nil)) #!+sb-doc - "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. + "Acquire MUTEX for the current thread. If WAITP is true (the default) and +the mutex is not immediately available, sleep until it is available. If TIMEOUT is given, it specifies a relative timeout, in seconds, on how long GRAB-MUTEX should try to acquire the lock in the contested -case. +case. Unsupported on :SB-LUTEX platforms (eg. Darwin), where a non-NIL +TIMEOUT signals an error. If GRAB-MUTEX returns T, the lock acquisition was successful. In case of WAITP being NIL, or an expired TIMEOUT, GRAB-MUTEX may also return @@ -452,10 +444,6 @@ NIL which denotes that GRAB-MUTEX did -not- acquire the lock. Notes: - - Using the NEW-OWNER parameter to assign a MUTEX to another thread - than the current one is not recommended, and liable to be - deprecated. - - GRAB-MUTEX is not interrupt safe. The correct way to call it is: (WITHOUT-INTERRUPTS @@ -468,9 +456,6 @@ Notes: ALLOW-WITH-INTERRUPTS allows the call to be interrupted from sleep. - - The TIMEOUT parameter is currently only supported on non-SB-LUTEX - platforms like Linux or BSD. - - (GRAB-MUTEX :timeout 0.0) differs from (GRAB-MUTEX :waitp nil) in that the former may signal a DEADLINE-TIMEOUT if the global deadline was due already on @@ -482,7 +467,7 @@ Notes: - It is recommended that you use WITH-MUTEX instead of calling GRAB-MUTEX directly. " - (get-mutex mutex new-owner waitp timeout)) + (get-mutex mutex nil waitp timeout)) (defun release-mutex (mutex &key (if-not-owner :punt)) #!+sb-doc @@ -542,6 +527,10 @@ IF-NOT-OWNER is :FORCE)." #!-sb-lutex (token nil)) +(def!method print-object ((waitqueue waitqueue) stream) + (print-unreadable-object (waitqueue stream :type t :identity t) + (format stream "~@[~A~]" (waitqueue-name waitqueue)))) + (defun make-waitqueue (&key name) #!+sb-doc "Create a waitqueue." @@ -558,17 +547,39 @@ IF-NOT-OWNER is :FORCE)." (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. - -Note that if CONDITION-WAIT unwinds (due to eg. a timeout) instead of + "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. + +Important: CONDITION-WAIT may return without CONDITION-NOTIFY having occurred. +The correct way to write code that uses CONDITION-WAIT is to loop around the +call, checking the the associated data: + + (defvar *data* nil) + (defvar *queue* (make-waitqueue)) + (defvar *lock* (make-mutex)) + + ;; Consumer + (defun pop-data () + (with-mutex (*lock*) + (loop until *data* + do (condition-wait *queue* *lock*)) + (pop *data*))) + + ;; Producer + (defun push-data (data) + (with-mutex (*lock*) + (push data *data*) + (condition-notify *queue*))) + +Also note that if CONDITION-WAIT unwinds (due to eg. a timeout) instead of returning normally, it may do so without holding the mutex." #!-sb-thread (declare (ignore queue)) (assert mutex) #!-sb-thread (error "Not supported in unithread builds.") #!+sb-thread (let ((me *current-thread*)) + (barrier (:read)) (assert (eq me (mutex-%owner mutex))) (/show0 "CONDITION-WAITing") #!+sb-lutex @@ -583,7 +594,8 @@ returning normally, it may do so without holding the mutex." (with-lutex-address (mutex-lutex-address (mutex-lutex mutex)) (with-local-interrupts (%lutex-wait queue-lutex-address mutex-lutex-address))))) - (setf (mutex-%owner mutex) me))) + (barrier (:write) + (setf (mutex-%owner mutex) me)))) #!-sb-lutex ;; Need to disable interrupts so that we don't miss grabbing the ;; mutex on our way out. @@ -1184,7 +1196,26 @@ SB-EXT:QUIT - the usual cleanup forms will be evaluated" (setf (sap-ref-word (%thread-sap thread) offset) (get-lisp-obj-address value)) (values value :ok)))) - (values nil :thread-dead)))))) + (values nil :thread-dead))))) + + (define-alien-variable tls-index-start unsigned-int) + + ;; Get values from the TLS area of the current thread. + (defun %thread-local-references () + (without-gcing + (let ((sap (%thread-sap *current-thread*))) + (loop for index from tls-index-start + below (symbol-value 'sb!vm::*free-tls-index*) + for value = (sap-ref-word sap (* sb!vm:n-word-bytes index)) + for (obj ok) = (multiple-value-list (sb!kernel:make-lisp-obj value nil)) + unless (or (not ok) + (typep obj '(or fixnum character)) + (member value + '(#.sb!vm:no-tls-value-marker-widetag + #.sb!vm:unbound-marker-widetag)) + (member obj seen :test #'eq)) + collect obj into seen + finally (return seen)))))) (defun symbol-value-in-thread (symbol thread &optional (errorp t)) "Return the local value of SYMBOL in THREAD, and a secondary value of T