X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Ftarget-thread.lisp;h=06002df4aed862289ec1b714dfcb01614e6a251c;hb=25fe91bf63fd473d9316675b0e0ca9be0079e9eb;hp=c5b6fcb1954a08e307dff5c683f9757d685cab5d;hpb=60ce532301c8f4b7ed289d049717ee16639bc4d4;p=sbcl.git diff --git a/src/code/target-thread.lisp b/src/code/target-thread.lisp index c5b6fcb..06002df 100644 --- a/src/code/target-thread.lisp +++ b/src/code/target-thread.lisp @@ -57,10 +57,18 @@ in future versions." (defvar *all-threads* ()) (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))) + (defun list-all-threads () #!+sb-doc "Return a list of the live threads." - (with-mutex (*all-threads-lock*) + (with-all-threads-lock (copy-list *all-threads*))) (declaim (inline current-thread-sap)) @@ -97,7 +105,7 @@ in future versions." (define-alien-routine "signal_interrupt_thread" integer (os-thread unsigned-long)) - (define-alien-routine "block_blockable_signals" + (define-alien-routine "block_deferrable_signals" void) #!+sb-lutex @@ -117,6 +125,9 @@ in future versions." (sb!alien:define-alien-routine ("lutex_lock" %lutex-lock) int (lutex unsigned-long)) + (sb!alien:define-alien-routine ("lutex_trylock" %lutex-trylock) + int (lutex unsigned-long)) + (sb!alien:define-alien-routine ("lutex_unlock" %lutex-unlock) int (lutex unsigned-long)) @@ -156,13 +167,18 @@ in future versions." int (word unsigned-long) (n unsigned-long)))) ;;; used by debug-int.lisp to access interrupt contexts -#!-(and sb-fluid sb-thread) (declaim (inline sb!vm::current-thread-offset-sap)) +#!-(or sb-fluid sb-thread) (declaim (inline sb!vm::current-thread-offset-sap)) #!-sb-thread (defun sb!vm::current-thread-offset-sap (n) (declare (type (unsigned-byte 27) n)) (sap-ref-sap (alien-sap (extern-alien "all_threads" (* t))) (* n sb!vm:n-word-bytes))) +#!+sb-thread +(defun sb!vm::current-thread-offset-sap (n) + (declare (type (unsigned-byte 27) n)) + (sb!vm::current-thread-offset-sap n)) + ;;;; spinlocks (declaim (inline get-spinlock release-spinlock)) @@ -241,11 +257,11 @@ until it is available" (format *debug-io* "Thread: ~A~%" *current-thread*) (sb!debug:backtrace most-positive-fixnum *debug-io*) (force-output *debug-io*)) - ;; FIXME: sb-lutex and (not wait-p) #!+sb-lutex - (when wait-p - (with-lutex-address (lutex (mutex-lutex mutex)) - (%lutex-lock lutex)) + (when (zerop (with-lutex-address (lutex (mutex-lutex mutex)) + (if wait-p + (%lutex-lock lutex) + (%lutex-trylock lutex)))) (setf (mutex-value mutex) new-value)) #!-sb-lutex (let (old) @@ -467,16 +483,22 @@ this semaphore, then N of them is woken up." ;;; Remove thread from its session, if it has one. #!+sb-thread (defun handle-thread-exit (thread) - (with-mutex (*all-threads-lock*) - (/show0 "HANDLING THREAD EXIT") - #!+sb-lutex - (when (thread-interruptions-lock thread) - (/show0 "FREEING MUTEX LUTEX") - (with-lutex-address (lutex (mutex-lutex (thread-interruptions-lock thread))) - (%lutex-destroy lutex))) - (setq *all-threads* (delete thread *all-threads*))) - (when *session* - (%delete-thread-from-session thread *session*))) + (/show0 "HANDLING THREAD EXIT") + ;; We're going down, can't handle interrupts sanely anymore. + ;; GC remains enabled. + (block-deferrable-signals) + ;; Lisp-side cleanup + (with-all-threads-lock + (setf (thread-%alive-p thread) nil) + (setf (thread-os-thread thread) nil) + (setq *all-threads* (delete thread *all-threads*)) + (when *session* + (%delete-thread-from-session thread *session*))) + #!+sb-lutex + (when (thread-interruptions-lock thread) + (/show0 "FREEING MUTEX LUTEX") + (with-lutex-address (lutex (mutex-lutex (thread-interruptions-lock thread))) + (%lutex-destroy lutex)))) (defun terminate-session () #!+sb-doc @@ -607,6 +629,7 @@ returns the thread exits." (sb!kernel::*restart-clusters* nil) (sb!kernel::*handler-clusters* nil) (sb!kernel::*condition-restarts* nil) + (sb!impl::*step-out* nil) ;; internal printer variables (sb!impl::*previous-case* nil) (sb!impl::*previous-readtable-case* nil) @@ -615,7 +638,7 @@ returns the thread exits." (sb!impl::*internal-symbol-output-fun* nil) (sb!impl::*descriptor-handlers* nil)) ; serve-event (setf (thread-os-thread thread) (current-thread-sap-id)) - (with-mutex (*all-threads-lock*) + (with-all-threads-lock (push thread *all-threads*)) (with-session-lock (*session*) (push thread (session-threads *session*))) @@ -638,15 +661,7 @@ returns the thread exits." ;; threads, it's time to enable signals (sb!unix::reset-signal-mask) (funcall real-function)) - ;; we're going down, can't handle - ;; interrupts sanely anymore - (let ((sb!impl::*gc-inhibit* t)) - (block-blockable-signals) - (setf (thread-%alive-p thread) nil) - (setf (thread-os-thread thread) nil) - ;; and remove what can be the last - ;; reference to this thread - (handle-thread-exit thread))))))) + (handle-thread-exit thread)))))) (values)))) ;; Keep INITIAL-FUNCTION pinned until the child thread is ;; initialized properly. @@ -754,3 +769,18 @@ SB-EXT:QUIT - the usual cleanup forms will be evaluated" (if (eql tl-val sb!vm::no-tls-value-marker-widetag) (sb!vm::symbol-global-value symbol) (sb!kernel: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)) + +;;; Stepping + +(defun thread-stepping () + (sb!kernel: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)))