X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Ftarget-thread.lisp;h=995847e245f8a4a1370251189a7d969756df9d10;hb=fe962ba01d267b92f638c8f0d19be41054219f04;hp=81e349ea2e3bf49f8af0b286db67a65121a57432;hpb=a3c94d7bfa65c1bed8ce77a65f25c2408c1c2802;p=sbcl.git diff --git a/src/code/target-thread.lisp b/src/code/target-thread.lisp index 81e349e..995847e 100644 --- a/src/code/target-thread.lisp +++ b/src/code/target-thread.lisp @@ -11,10 +11,15 @@ (in-package "SB!THREAD") +;;; Of the WITH-PINNED-OBJECTS in this file, not every single one is +;;; necessary because threads are only supported with the conservative +;;; gencgc and numbers on the stack (returned by GET-LISP-OBJ-ADDRESS) +;;; are treated as references. + ;;; 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)) @@ -22,10 +27,15 @@ "Thread type. Do not rely on threads being structs as it may change in future versions." name - %sap) + %alive-p + os-thread + interruptions + (interruptions-lock (make-mutex :name "thread interruptions lock")) + result + (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) @@ -38,22 +48,10 @@ in future versions." )) thread) -(defun thread-state (thread) - (let ((state - (sb!sys:sap-int - (sb!sys:sap-ref-sap (thread-%sap thread) - (* sb!vm::thread-state-slot - sb!vm::n-word-bytes))))) - (ecase state - (#.(sb!vm:fixnumize 0) :starting) - (#.(sb!vm:fixnumize 1) :running) - (#.(sb!vm:fixnumize 2) :suspended) - (#.(sb!vm:fixnumize 3) :dead)))) - (defun thread-alive-p (thread) #!+sb-doc "Check if THREAD is running." - (not (eq :dead (thread-state thread)))) + (thread-%alive-p thread)) ;; A thread is eligible for gc iff it has finished and there are no ;; more references to it. This list is supposed to keep a reference to @@ -61,10 +59,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)) @@ -73,12 +79,14 @@ in future versions." (declaim (inline current-thread-sap-id)) (defun current-thread-sap-id () - (sb!sys:sap-int + (sap-int (sb!vm::current-thread-offset-sap sb!vm::thread-os-thread-slot))) (defun init-initial-thread () + (/show0 "Entering INIT-INITIAL-THREAD") (let ((initial-thread (%make-thread :name "initial thread" - :%sap (current-thread-sap)))) + :%alive-p t + :os-thread (current-thread-sap-id)))) (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 @@ -89,133 +97,203 @@ in future versions." #!+sb-thread (progn + ;; FIXME it would be good to define what a thread id is or isn't + ;; (our current assumption is that it's a fixnum). It so happens + ;; that on Linux it's a pid, but it might not be on posix thread + ;; implementations. (define-alien-routine ("create_thread" %create-thread) - system-area-pointer - (lisp-fun-address unsigned-long)) + unsigned-long (lisp-fun-address unsigned-long)) + + (define-alien-routine "signal_interrupt_thread" + integer (os-thread unsigned-long)) + + (define-alien-routine "block_deferrable_signals" + void) + + #!+sb-lutex + (progn + (declaim (inline %lutex-init %lutex-wait %lutex-wake + %lutex-lock %lutex-unlock)) + + (sb!alien:define-alien-routine ("lutex_init" %lutex-init) + int (lutex unsigned-long)) + + (sb!alien: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) + int (lutex unsigned-long) (n int)) + + (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)) + + (sb!alien:define-alien-routine ("lutex_destroy" %lutex-destroy) + int (lutex unsigned-long)) - (define-alien-routine reap-dead-thread void - (thread-sap system-area-pointer)) + ;; FIXME: Defining a whole bunch of alien-type machinery just for + ;; passing primitive lutex objects directly to foreign functions + ;; doesn't seem like fun right now. So instead we just manually + ;; pin the lutex, get its address, and let the callee untag it. + (defmacro with-lutex-address ((name lutex) &body body) + `(let ((,name ,lutex)) + (with-pinned-objects (,name) + (let ((,name (get-lisp-obj-address ,name))) + ,@body)))) - (declaim (inline futex-wait futex-wake)) + (defun make-lutex () + (/show0 "Entering MAKE-LUTEX") + ;; Suppress GC until the lutex has been properly registered with + ;; the GC. + (without-gcing + (let ((lutex (sb!vm::%make-lutex))) + (/show0 "LUTEX=..") + (/hexstr lutex) + (with-lutex-address (lutex lutex) + (%lutex-init lutex)) + lutex)))) - (sb!alien:define-alien-routine "futex_wait" - int (word unsigned-long) (old-value unsigned-long)) + #!-sb-lutex + (progn + (declaim (inline futex-wait futex-wake)) - (sb!alien:define-alien-routine "futex_wake" - int (word unsigned-long) (n unsigned-long))) + (sb!alien:define-alien-routine "futex_wait" + int (word unsigned-long) (old-value unsigned-long) + (to-sec long) (to-usec unsigned-long)) + + (sb!alien:define-alien-routine "futex_wake" + 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)) - (sb!sys:sap-ref-sap (alien-sap (extern-alien "all_threads" (* t))) + (sap-ref-sap (alien-sap (extern-alien "all_threads" (* t))) (* n sb!vm:n-word-bytes))) -;;;; spinlocks +#!+sb-thread +(defun sb!vm::current-thread-offset-sap (n) + (declare (type (unsigned-byte 27) n)) + (sb!vm::current-thread-offset-sap n)) -(defstruct spinlock - #!+sb-doc - "Spinlock type." - (name nil :type (or null simple-string)) - (value 0)) +;;;; spinlocks +#!+sb-thread +(define-structure-slot-compare-and-swap + compare-and-swap-spinlock-value + :structure spinlock + :slot value) (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 -(defun get-spinlock (spinlock new-value) +(defun get-spinlock (spinlock) (declare (optimize (speed 3) (safety 0)) #!-sb-thread - (ignore spinlock new-value)) + (ignore spinlock)) ;; %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 new-value) 0))) + (eql 0 (compare-and-swap-spinlock-value spinlock 0 1))) + 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) + ;; meaningfully, so (compare-and-swap-spinlock-value 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 *current-thread*) - (unwind-protect - (progn ,@body) - (release-spinlock ,lock))))) + (setf (spinlock-value spinlock) 0) + nil) ;;;; mutexes -(defstruct mutex - #!+sb-doc - "Mutex type." - (name nil :type (or null simple-string)) - (value nil)) - #!+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.") -#!+sb-thread -(declaim (inline mutex-value-address)) -#!+sb-thread -(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 (wait-p t)) +#!+(and sb-thread (not sb-lutex)) +(progn + (define-structure-slot-addressor mutex-value-address + :structure mutex + :slot value) + (define-structure-slot-compare-and-swap + compare-and-swap-mutex-value + :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" +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))) - (unless new-value (setf new-value *current-thread*)) + (/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 + (when (eql new-value (mutex-value mutex)) + (warn "recursive lock attempt ~S~%" mutex) + (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. + #!+sb-lutex + (when (zerop (with-lutex-address (lutex (mutex-lutex mutex)) + (if waitp + (%lutex-lock lutex) + (%lutex-trylock lutex)))) + (setf (mutex-value mutex) new-value)) + #!-sb-lutex (let (old) - (when (eql new-value (mutex-value mutex)) - (warn "recursive lock attempt ~S~%" mutex) - (format *debug-io* "Thread: ~A~%" *current-thread*) - (sb!debug:backtrace most-positive-fixnum *debug-io*) - (force-output *debug-io*)) - (loop - (unless - (setf old (sb!vm::%instance-set-conditional mutex 2 nil new-value)) - (return t)) - (unless wait-p (return nil)) - (futex-wait (mutex-value-address mutex) - (sb!kernel:get-lisp-obj-address old))))) + (when (and (setf old (compare-and-exchange-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 (compare-and-exchange-mutex-value mutex nil new-value)))) + (not old))) (defun release-mutex (mutex) #!+sb-doc "Release MUTEX by setting it to NIL. Wake up threads waiting for this mutex." (declare (type mutex mutex)) + (/show0 "Entering RELEASE-MUTEX") (setf (mutex-value mutex) nil) #!+sb-thread - (futex-wake (mutex-value-address mutex) 1)) + (progn + #!+sb-lutex + (with-lutex-address (lutex (mutex-lutex mutex)) + (%lutex-unlock lutex)) + #!-sb-lutex + (futex-wake (mutex-value-address mutex) 1))) ;;;; waitqueues/condition variables @@ -223,6 +301,9 @@ this mutex." #!+sb-doc "Waitqueue type." (name nil :type (or null simple-string)) + #!+(and sb-lutex sb-thread) + (lutex (make-lutex)) + #!-sb-lutex (data nil)) (defun make-waitqueue (&key name) @@ -231,18 +312,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.") -#!+sb-thread -(declaim (inline waitqueue-data-address)) -#!+sb-thread -(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)))) +#!+(and sb-thread (not sb-lutex)) +(define-structure-slot-addressor waitqueue-data-address + :structure waitqueue + :slot data) (defun condition-wait (queue mutex) #!+sb-doc @@ -254,6 +330,15 @@ time we reacquire MUTEX and return to the caller." #!-sb-thread (error "Not supported in unithread builds.") #!+sb-thread (let ((value (mutex-value mutex))) + (/show0 "CONDITION-WAITing") + #!+sb-lutex + (progn + (setf (mutex-value mutex) nil) + (with-lutex-address (queue-lutex-address (waitqueue-lutex queue)) + (with-lutex-address (mutex-lutex-address (mutex-lutex mutex)) + (%lutex-wait queue-lutex-address mutex-lutex-address))) + (setf (mutex-value mutex) value)) + #!-sb-lutex (unwind-protect (let ((me *current-thread*)) ;; XXX we should do something to ensure that the result of this setf @@ -264,39 +349,92 @@ time we reacquire MUTEX and return to the caller." ;; 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 - (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 ;; better than nothing. (get-mutex mutex value)))) -(defun condition-notify (queue) +(defun condition-notify (queue &optional (n 1)) #!+sb-doc - "Notify one of the threads waiting on QUEUE." - #!-sb-thread (declare (ignore queue)) + "Notify N threads waiting on QUEUE." + #!-sb-thread (declare (ignore queue n)) #!-sb-thread (error "Not supported in unithread builds.") #!+sb-thread - (let ((me *current-thread*)) + (declare (type (and fixnum (integer 1)) n)) + (/show0 "Entering CONDITION-NOTIFY") + #!+sb-thread + (progn + #!+sb-lutex + (with-lutex-address (lutex (waitqueue-lutex queue)) + (%lutex-wake lutex n)) ;; no problem if >1 thread notifies during the comment in ;; condition-wait: as long as the value in queue-data isn't the ;; waiting thread's id, it matters not what it is ;; XXX we should do something to ensure that the result of this setf ;; is visible to all CPUs - (setf (waitqueue-data queue) me) - (futex-wake (waitqueue-data-address queue) 1))) + #!-sb-lutex + (let ((me *current-thread*)) + (progn + (setf (waitqueue-data queue) me) + (with-pinned-objects (queue) + (futex-wake (waitqueue-data-address queue) n)))))) (defun condition-broadcast (queue) #!+sb-doc "Notify all threads waiting on QUEUE." - #!-sb-thread (declare (ignore queue)) - #!-sb-thread (error "Not supported in unithread builds.") - #!+sb-thread - (let ((me *current-thread*)) - (setf (waitqueue-data queue) me) - (futex-wake (waitqueue-data-address queue) (ash 1 30)))) + (condition-notify queue + ;; On a 64-bit platform truncating M-P-F to an int results + ;; in -1, which wakes up only one thread. + (ldb (byte 29 0) + most-positive-fixnum))) + +;;;; semaphores + +(defstruct (semaphore (:constructor %make-semaphore)) + #!+sb-doc + "Semaphore type." + (name nil :type (or null simple-string)) + (count 0 :type (integer 0)) + (mutex (make-mutex)) + (queue (make-waitqueue))) + +(defun make-semaphore (&key name (count 0)) + #!+sb-doc + "Create a semaphore with the supplied COUNT." + (%make-semaphore :name name :count count)) + +(setf (fdocumentation 'semaphore-name 'function) + "The name of the semaphore. Setfable.") + +(defun wait-on-semaphore (sem) + #!+sb-doc + "Decrement the count of SEM if the count would not be negative. Else +block until the semaphore can be decremented." + ;; a more direct implementation based directly on futexes should be + ;; possible + (with-mutex ((semaphore-mutex sem)) + (loop until (> (semaphore-count sem) 0) + do (condition-wait (semaphore-queue sem) (semaphore-mutex sem)) + finally (decf (semaphore-count sem))))) + +(defun signal-semaphore (sem &optional (n 1)) + #!+sb-doc + "Increment the count of SEM by N. If there are threads waiting on +this semaphore, then N of them is woken up." + (declare (type (and fixnum (integer 1)) n)) + (with-mutex ((semaphore-mutex sem)) + (when (= n (incf (semaphore-count sem) n)) + (condition-notify (semaphore-queue sem) n)))) ;;;; job control, independent listeners @@ -316,16 +454,18 @@ time we reacquire MUTEX and return to the caller." #!-sb-thread `(locally ,@body) #!+sb-thread - `(sb!sys:without-interrupts - (with-mutex ((session-lock ,session)) - ,@body))) + `(without-interrupts + (with-mutex ((session-lock ,session)) + ,@body))) (defun new-session () (make-session :threads (list *current-thread*) :interactive-threads (list *current-thread*))) (defun init-job-control () - (setf *session* (new-session))) + (/show0 "Entering INIT-JOB-CONTROL") + (setf *session* (new-session)) + (/show0 "Exiting INIT-JOB-CONTROL")) (defun %delete-thread-from-session (thread session) (with-session-lock (session) @@ -348,10 +488,22 @@ time we reacquire MUTEX and return to the caller." ;;; Remove thread from its session, if it has one. #!+sb-thread (defun handle-thread-exit (thread) - (with-mutex (*all-threads-lock*) - (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 + (without-gcing + (/show0 "FREEING MUTEX LUTEX") + (with-lutex-address (lutex (mutex-lutex (thread-interruptions-lock thread))) + (%lutex-destroy lutex)))) (defun terminate-session () #!+sb-doc @@ -390,6 +542,7 @@ interactive." #!+sb-thread (let ((was-foreground t)) (loop + (/show0 "Looping in GET-FOREGROUND") (with-session-lock (*session*) (let ((int-t (session-interactive-threads *session*))) (when (eq (car int-t) *current-thread*) @@ -432,16 +585,16 @@ have the foreground next." (labels ((thread-repl () (sb!unix::unix-setsid) (let* ((sb!impl::*stdin* - (sb!sys:make-fd-stream in :input t :buffering :line - :dual-channel-p t)) + (make-fd-stream in :input t :buffering :line + :dual-channel-p t)) (sb!impl::*stdout* - (sb!sys:make-fd-stream out :output t :buffering :line + (make-fd-stream out :output t :buffering :line :dual-channel-p t)) (sb!impl::*stderr* - (sb!sys:make-fd-stream err :output t :buffering :line + (make-fd-stream err :output t :buffering :line :dual-channel-p t)) (sb!impl::*tty* - (sb!sys:make-fd-stream err :input t :output t + (make-fd-stream err :input t :output t :buffering :line :dual-channel-p t)) (sb!impl::*descriptor-handlers* nil)) @@ -456,60 +609,106 @@ have the foreground next." (defun make-thread (function &key name) #!+sb-doc "Create a new thread of NAME that runs FUNCTION. When the function -returns the thread exits." +returns the thread exits. The return values of FUNCTION are kept +around and can be retrieved by JOIN-THREAD." #!-sb-thread (declare (ignore function name)) #!-sb-thread (error "Not supported in unithread builds.") #!+sb-thread (let* ((thread (%make-thread :name name)) - (setup-p nil) + (setup-sem (make-semaphore :name "Thread setup semaphore")) (real-function (coerce function 'function)) - (thread-sap - (%create-thread - (sb!kernel:get-lisp-obj-address - (lambda () - ;; FIXME: use semaphores? - (loop until setup-p) - ;; in time we'll move some of the binding presently done in C - ;; here too - (let ((*current-thread* thread) - (sb!kernel::*restart-clusters* nil) - (sb!kernel::*handler-clusters* nil) - (sb!kernel::*condition-restarts* nil) - (sb!impl::*descriptor-handlers* nil)) ; serve-event + (initial-function + (lambda () + ;; In time we'll move some of the binding presently done in C + ;; here too. + ;; + ;; KLUDGE: Here we have a magic list of variables that are + ;; not thread-safe for one reason or another. As people + ;; report problems with the thread safety of certain + ;; variables, (e.g. "*print-case* in multiple threads + ;; broken", sbcl-devel 2006-07-14), we add a few more + ;; bindings here. The Right Thing is probably some variant + ;; of Allegro's *cl-default-special-bindings*, as that is at + ;; least accessible to users to secure their own libraries. + ;; --njf, 2006-07-15 + (let ((*current-thread* thread) + (*restart-clusters* nil) + (*handler-clusters* nil) + (*condition-restarts* nil) + (sb!impl::*step-out* nil) + ;; internal printer variables + (sb!impl::*previous-case* nil) + (sb!impl::*previous-readtable-case* nil) + (sb!impl::*merge-sort-temp-vector* (vector)) ; keep these small! + (sb!impl::*zap-array-data-temp* (vector)) ; + (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 ((thread-result-lock thread)) + (with-all-threads-lock + (push thread *all-threads*)) + (with-session-lock (*session*) + (push thread (session-threads *session*))) + (setf (thread-%alive-p thread) t) + (signal-semaphore setup-sem) ;; can't use handling-end-of-the-world, because that flushes ;; output streams, and we don't necessarily have any (or we ;; could be sharing them) - (unwind-protect - (catch 'sb!impl::toplevel-catcher - (catch 'sb!impl::%end-of-the-world - (with-simple-restart - (terminate-thread - (format nil "~~@" - *current-thread*)) - ;; now that most things have a chance to work - ;; properly without messing up other threads, it's - ;; time to enable signals - (sb!unix::reset-signal-mask) - (unwind-protect - (funcall real-function) - ;; we're going down, can't handle - ;; interrupts sanely anymore - (sb!unix::block-blockable-signals))))) - ;; and remove what can be the last reference to - ;; the thread object - (handle-thread-exit thread) - 0)) - (values)))))) - (when (sb!sys:sap= thread-sap (sb!sys:int-sap 0)) - (error "Can't create a new thread")) - (setf (thread-%sap thread) thread-sap) - (with-mutex (*all-threads-lock*) - (push thread *all-threads*)) - (with-session-lock (*session*) - (push thread (session-threads *session*))) - (setq setup-p t) - (sb!impl::finalize thread (lambda () (reap-dead-thread thread-sap))) - thread)) + (catch 'sb!impl::toplevel-catcher + (catch 'sb!impl::%end-of-the-world + (with-simple-restart + (terminate-thread + (format nil + "~~@" + *current-thread*)) + (unwind-protect + (progn + ;; now that most things have a chance to + ;; work properly without messing up other + ;; threads, it's time to enable signals + (sb!unix::reset-signal-mask) + (setf (thread-result thread) + (cons t + (multiple-value-list + (funcall real-function))))) + (handle-thread-exit thread))))))) + (values)))) + ;; Keep INITIAL-FUNCTION pinned until the child thread is + ;; initialized properly. + (with-pinned-objects (initial-function) + (let ((os-thread + (%create-thread + (get-lisp-obj-address initial-function)))) + (when (zerop os-thread) + (error "Can't create a new thread")) + (wait-on-semaphore setup-sem) + thread)))) + +(define-condition join-thread-error (error) + ((thread :reader join-thread-error-thread :initarg :thread)) + #!+sb-doc + (:documentation "Joining thread failed.") + (:report (lambda (c s) + (format s "Joining thread failed: thread ~A ~ + has not returned normally." + (join-thread-error-thread c))))) + +#!+sb-doc +(setf (fdocumentation 'join-thread-error-thread 'function) + "The thread that we failed to join.") + +(defun join-thread (thread &key (default nil defaultp)) + #!+sb-doc + "Suspend current thread until THREAD exits. Returns the result +values of the thread function. If the thread does not exit normally, +return DEFAULT if given or else signal JOIN-THREAD-ERROR." + (with-mutex ((thread-result-lock thread)) + (cond ((car (thread-result thread)) + (values-list (cdr (thread-result thread)))) + (defaultp + default) + (t + (error 'join-thread-error :thread thread))))) (defun destroy-thread (thread) #!+sb-doc @@ -517,26 +716,44 @@ returns the thread exits." (terminate-thread thread)) (define-condition interrupt-thread-error (error) - ((thread :reader interrupt-thread-error-thread :initarg :thread) - (errno :reader interrupt-thread-error-errno :initarg :errno)) + ((thread :reader interrupt-thread-error-thread :initarg :thread)) #!+sb-doc (:documentation "Interrupting thread failed.") (:report (lambda (c s) - (format s "interrupt thread ~A failed (~A: ~A)" - (interrupt-thread-error-thread c) - (interrupt-thread-error-errno c) - (strerror (interrupt-thread-error-errno c)))))) + (format s "Interrupt thread failed: thread ~A has exited." + (interrupt-thread-error-thread c))))) #!+sb-doc -(setf (sb!kernel:fdocumentation 'interrupt-thread-error-thread 'function) - "The thread that was not interrupted." - (sb!kernel:fdocumentation 'interrupt-thread-error-errno 'function) - "The reason why the interruption failed.") +(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))) + +;; Called from the signal handler. +(defun run-interruption () + (in-interruption () + (loop + (let ((interruption (with-interruptions-lock (*current-thread*) + (pop (thread-interruptions *current-thread*))))) + (if interruption + (with-interrupts + (funcall interruption)) + (return)))))) + +;; The order of interrupt execution is peculiar. If thread A +;; interrupts thread B with I1, I2 and B for some reason receives I1 +;; when FUN2 is already on the list, then it is FUN2 that gets to run +;; first. But when FUN2 is run SIG_INTERRUPT_THREAD is enabled again +;; and I2 hits pretty soon in FUN2 and run FUN1. This is of course +;; just one scenario, and the order of thread interrupt execution is +;; undefined. (defun interrupt-thread (thread function) #!+sb-doc "Interrupt the live THREAD and make it run FUNCTION. A moderate -degree of care is expected for use of interrupt-thread, due to its +degree of care is expected for use of INTERRUPT-THREAD, due to its 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." @@ -546,15 +763,16 @@ won't like the effect." #!-sb-thread (funcall function) #!+sb-thread - (let ((function (coerce function 'function))) - (multiple-value-bind (res err) - (sb!unix::syscall ("interrupt_thread" - system-area-pointer sb!alien:unsigned-long) - thread - (thread-%sap thread) - (sb!kernel:get-lisp-obj-address function)) - (unless res - (error 'interrupt-thread-error :thread thread :errno err))))) + (if (eq thread *current-thread*) + (funcall function) + (let ((os-thread (thread-os-thread thread))) + (cond ((not os-thread) + (error 'interrupt-thread-error :thread thread)) + (t + (with-interruptions-lock (thread) + (push function (thread-interruptions thread))) + (when (minusp (signal-interrupt-thread os-thread)) + (error 'interrupt-thread-error :thread thread))))))) (defun terminate-thread (thread) #!+sb-doc @@ -567,11 +785,38 @@ SB-EXT:QUIT - the usual cleanup forms will be evaluated" ;;; 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) - (let ((thread-sap (thread-%sap thread))) - (let* ((index (sb!vm::symbol-tls-index symbol)) - (tl-val (sb!sys:sap-ref-word thread-sap - (* sb!vm:n-word-bytes index)))) - (if (eql tl-val sb!vm::unbound-marker-widetag) - (sb!vm::symbol-global-value symbol) - (sb!kernel:make-lisp-obj tl-val))))) +(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))))))) + +#!+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)))) + +(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 () + (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)) + (get-lisp-obj-address value)))