X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Ftarget-thread.lisp;h=61ea1af1e7680405c26c5f54f06318d10546413b;hb=5423b2e0f7e7643001ed3ef2f66681c0114a72a6;hp=c99c30b5a255eae13dcb48b8ebb89cfff606bc5a;hpb=960a53636bf8784e44740d8673b3abc2c4c08594;p=sbcl.git diff --git a/src/code/target-thread.lisp b/src/code/target-thread.lisp index c99c30b..61ea1af 100644 --- a/src/code/target-thread.lisp +++ b/src/code/target-thread.lisp @@ -39,14 +39,22 @@ in future versions." "The name of the thread. Setfable.") (def!method print-object ((thread thread) stream) - (if (thread-name thread) - (print-unreadable-object (thread stream :type t :identity t) - (prin1 (thread-name thread) stream)) - (print-unreadable-object (thread stream :type t :identity t) - ;; body is empty => there is only one space between type and - ;; identity - )) - thread) + (print-unreadable-object (thread stream :type t :identity t) + (let* ((cookie (list thread)) + (info (if (thread-alive-p thread) + :running + (multiple-value-list (join-thread thread :default cookie)))) + (state (if (eq :running info) + info + (if (eq cookie (car info)) + :aborted + :finished))) + (values (when (eq :finished state) info))) + (format stream "~@[~S ~]~:[~A~;~A~:[ no values~; values: ~:*~{~S~^, ~}~]~]" + (thread-name thread) + (eq :finished state) + state + values)))) (defun thread-alive-p (thread) #!+sb-doc @@ -59,8 +67,11 @@ in future versions." (defvar *all-threads* ()) (defvar *all-threads-lock* (make-mutex :name "all threads lock")) +(defvar *default-alloc-signal* nil) + (defmacro with-all-threads-lock (&body body) - `(call-with-system-mutex (lambda () ,@body) *all-threads-lock*)) + `(with-system-mutex (*all-threads-lock*) + ,@body)) (defun list-all-threads () #!+sb-doc @@ -72,8 +83,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))) @@ -81,7 +92,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 @@ -500,11 +511,21 @@ on this semaphore, then N of them is woken up." (defvar *session* nil) -;;; the debugger itself tries to acquire the session lock, don't let +;;; The debugger itself tries to acquire the session lock, don't let ;;; funny situations (like getting a sigint while holding the session -;;; lock) occur +;;; lock) occur. At the same time we need to allow interrupts while +;;; *waiting* for the session lock for things like GET-FOREGROUND +;;; to be interruptible. +;;; +;;; Take care: we sometimes need to obtain the session lock while holding +;;; on to *ALL-THREADS-LOCK*, so we must _never_ obtain it _after_ getting +;;; a session lock! (Deadlock risk.) +;;; +;;; FIXME: It would be good to have ordered locks to ensure invariants like +;;; the above. (defmacro with-session-lock ((session) &body body) - `(call-with-system-mutex (lambda () ,@body) (session-lock ,session))) + `(with-system-mutex ((session-lock ,session) :allow-with-interrupts t) + ,@body)) (defun new-session () (make-session :threads (list *current-thread*) @@ -693,7 +714,9 @@ 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)) + ;; Binding from C + (setf sb!vm:*alloc-signal* *default-alloc-signal*) + (setf (thread-os-thread thread) (current-thread-os-thread)) (with-mutex ((thread-result-lock thread)) (with-all-threads-lock (push thread *all-threads*)) @@ -778,7 +801,8 @@ return DEFAULT if given or else signal JOIN-THREAD-ERROR." "The thread that was not interrupted.") (defmacro with-interruptions-lock ((thread) &body body) - `(call-with-system-mutex (lambda () ,@body) (thread-interruptions-lock ,thread))) + `(with-system-mutex ((thread-interruptions-lock ,thread)) + ,@body)) ;; Called from the signal handler in C. (defun run-interruption () @@ -828,37 +852,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))