From 1b71a50ae370d903265bf3bc8387518641b2a78b Mon Sep 17 00:00:00 2001 From: Nikodemus Siivola Date: Mon, 19 May 2008 16:46:36 +0000 Subject: [PATCH] 1.0.16.40: implement %SET-SYMBOL-VALUE-IN-THREAD MIME-Version: 1.0 Content-Type: text/plain; charset=utf8 Content-Transfer-Encoding: 8bit * Eventually we may want to export this, but let's keep it internal for now... * Rename SB-THREAD::SYMBOL-VALUE-IN-THREAD to %SYMBOL-VALUE-IN-THREAD, and make it work with thread objects instead of SAPs. Also, never return the global value, but instead signal an error if the symbol is unbound in the thread. * Similarly, rename THREAD-SAP-FOR-ID to %THREAD-SAP, and make it work with thread objects instead of os-thread pointer values (née thread ids). * Rename CURRENT-THREAD-SAP-ID to CURRENT-THREAD-OS-THREAD. --- src/code/target-thread.lisp | 80 +++++++++++++++++++++++++++++---------------- version.lisp-expr | 2 +- 2 files changed, 53 insertions(+), 29 deletions(-) diff --git a/src/code/target-thread.lisp b/src/code/target-thread.lisp index e2a6cfce7..1ddd0a1af 100644 --- a/src/code/target-thread.lisp +++ b/src/code/target-thread.lisp @@ -73,8 +73,8 @@ in future versions." (defun current-thread-sap () (sb!vm::current-thread-offset-sap sb!vm::thread-this-slot)) -(declaim (inline current-thread-sap-id)) -(defun current-thread-sap-id () +(declaim (inline current-thread-os-thread)) +(defun current-thread-os-thread () (sap-int (sb!vm::current-thread-offset-sap sb!vm::thread-os-thread-slot))) @@ -82,7 +82,7 @@ in future versions." (/show0 "Entering INIT-INITIAL-THREAD") (let ((initial-thread (%make-thread :name "initial thread" :%alive-p t - :os-thread (current-thread-sap-id)))) + :os-thread (current-thread-os-thread)))) (setq *current-thread* initial-thread) ;; Either *all-threads* is empty or it contains exactly one thread ;; in case we are in reinit since saving core with multiple @@ -704,7 +704,7 @@ around and can be retrieved by JOIN-THREAD." (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)) + (setf (thread-os-thread thread) (current-thread-os-thread)) (with-mutex ((thread-result-lock thread)) (with-all-threads-lock (push thread *all-threads*)) @@ -840,37 +840,61 @@ won't like the effect." SB-EXT:QUIT - the usual cleanup forms will be evaluated" (interrupt-thread thread 'sb!ext:quit)) -;;; internal use only. If you think you need to use this, either you -;;; are an SBCL developer, are doing something that you should discuss -;;; with an SBCL developer first, or are doing something that you -;;; should probably discuss with a professional psychiatrist first -#!+sb-thread -(defun thread-sap-for-id (id) - (let ((thread-sap (alien-sap (extern-alien "all_threads" (* t))))) - (loop - (when (sap= thread-sap (int-sap 0)) (return nil)) - (let ((os-thread (sap-ref-word thread-sap - (* sb!vm:n-word-bytes - sb!vm::thread-os-thread-slot)))) - (when (= os-thread id) (return thread-sap)) - (setf thread-sap - (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.") +;;; internal use only. If you think you need to use these, either you +;;; are an SBCL developer, are doing something that you should discuss +;;; with an SBCL developer first, or are doing something that you +;;; should probably discuss with a professional psychiatrist first #!+sb-thread -(defun symbol-value-in-thread (symbol thread-sap) - (let* ((index (sb!vm::symbol-tls-index symbol)) - (tl-val (sap-ref-word thread-sap - (* sb!vm:n-word-bytes index)))) - (if (eql tl-val sb!vm::no-tls-value-marker-widetag) - (sb!vm::symbol-global-value symbol) - (make-lisp-obj tl-val)))) +(progn + (defun %thread-sap (thread) + (let ((thread-sap (alien-sap (extern-alien "all_threads" (* t)))) + (target (thread-os-thread thread))) + (loop + (when (sap= thread-sap (int-sap 0)) (return nil)) + (let ((os-thread (sap-ref-word thread-sap + (* sb!vm:n-word-bytes + sb!vm::thread-os-thread-slot)))) + (when (= os-thread target) (return thread-sap)) + (setf thread-sap + (sap-ref-sap thread-sap (* sb!vm:n-word-bytes + sb!vm::thread-next-slot))))))) + + (defun %symbol-value-in-thread (symbol thread) + (tagbody + ;; Prevent the dead from dying completely while we look for the TLS area... + (with-all-threads-lock + (if (thread-alive-p thread) + (let* ((offset (* sb!vm:n-word-bytes (sb!vm::symbol-tls-index symbol))) + (tl-val (sap-ref-word (%thread-sap thread) offset))) + (if (eql tl-val sb!vm::no-tls-value-marker-widetag) + (go :unbound) + (return-from %symbol-value-in-thread (values (make-lisp-obj tl-val) t)))) + (return-from %symbol-value-in-thread (values nil nil)))) + :unbound + (error "Cannot read thread-local symbol value: ~S unbound in ~S" symbol thread))) + + (defun %set-symbol-value-in-thread (symbol thread value) + (tagbody + (with-pinned-objects (value) + ;; Prevent the dead from dying completely while we look for the TLS area... + (with-all-threads-lock + (if (thread-alive-p thread) + (let* ((offset (* sb!vm:n-word-bytes (sb!vm::symbol-tls-index symbol))) + (sap (%thread-sap thread)) + (tl-val (sap-ref-word sap offset))) + (if (eql tl-val sb!vm::no-tls-value-marker-widetag) + (go :unbound) + (setf (sap-ref-word sap offset) (get-lisp-obj-address value))) + (return-from %set-symbol-value-in-thread (values value t))) + (return-from %set-symbol-value-in-thread (values nil nil))))) + :unbound + (error "Cannot set thread-local symbol value: ~S unbound in ~S" symbol thread)))) (defun sb!vm::locked-symbol-global-value-add (symbol-name delta) (sb!vm::locked-symbol-global-value-add symbol-name delta)) diff --git a/version.lisp-expr b/version.lisp-expr index d795dbd4f..c8d3d6a84 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -17,4 +17,4 @@ ;;; checkins which aren't released. (And occasionally for internal ;;; versions, especially for internal versions off the main CVS ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".) -"1.0.16.39" +"1.0.16.40" -- 2.11.4.GIT