X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Ftarget-thread.lisp;h=0d0ccb96d94dcf77bc647b02e9aa7ca05f986d35;hb=b56c1a4dc22aa0ac827343667584aa6090b15f02;hp=59d056219348d69de722be3281956e6500076010;hpb=ea3a2433c72ee97c5691c29d882a63e4d86f0a32;p=sbcl.git diff --git a/src/code/target-thread.lisp b/src/code/target-thread.lisp index 59d0562..0d0ccb9 100644 --- a/src/code/target-thread.lisp +++ b/src/code/target-thread.lisp @@ -11,6 +11,138 @@ (in-package "SB!THREAD") +;;; CAS Lock +;;; +;;; Locks don't come any simpler -- or more lightweight than this. While +;;; this is probably a premature optimization for most users, we still +;;; need it internally for implementing condition variables outside Futex +;;; builds. + +(defmacro with-cas-lock ((place) &body body) + #!+sb-doc + "Runs BODY with interrupts disabled and *CURRENT-THREAD* compare-and-swapped +into PLACE instead of NIL. PLACE must be a place acceptable to +COMPARE-AND-SWAP, and must initially hold NIL. + +WITH-CAS-LOCK is suitable mostly when the critical section needing protection +is very small, and cost of allocating a separate lock object would be +prohibitive. While it is the most lightweight locking constructed offered by +SBCL, it is also the least scalable if the section is heavily contested or +long. + +WITH-CAS-LOCK can be entered recursively." + `(without-interrupts + (%with-cas-lock (,place) ,@body))) + +(defmacro %with-cas-lock ((place) &body body &environment env) + (with-unique-names (self owner) + ;; Take care not to multiply-evaluate anything. + ;; + ;; FIXME: Once we get DEFCAS this can use GET-CAS-EXPANSION. + (let* ((placex (sb!xc:macroexpand place env)) + (place-op (if (consp placex) + (car placex) + (error "~S: ~S is not a valid place for ~S" + 'with-cas-lock + place 'sb!ext:compare-and-swap))) + (place-args (cdr placex)) + (temps (make-gensym-list (length place-args) t)) + (place `(,place-op ,@temps))) + `(let* (,@(mapcar #'list temps place-args) + (,self *current-thread*) + (,owner ,place)) + (unwind-protect + (progn + (unless (eq ,owner ,self) + (loop while (setf ,owner + (or ,place + (sb!ext:compare-and-swap ,place nil ,self))) + do (thread-yield))) + ,@body) + (unless (eq ,owner ,self) + (sb!ext:compare-and-swap ,place ,self nil))))))) + +;;; Conditions + +(define-condition thread-error (error) + ((thread :reader thread-error-thread :initarg :thread)) + #!+sb-doc + (:documentation + "Conditions of type THREAD-ERROR are signalled when thread operations fail. +The offending thread is initialized by the :THREAD initialization argument and +read by the function THREAD-ERROR-THREAD.")) + +(define-condition thread-deadlock (thread-error) + ((cycle :initarg :cycle :reader thread-deadlock-cycle)) + (:report + (lambda (condition stream) + (let ((*print-circle* t)) + (format stream "Deadlock cycle detected:~%~@< ~@;~ + ~{~:@_~S~:@_~}~:@>" + (mapcar #'car (thread-deadlock-cycle condition))))))) + +#!+sb-doc +(setf + (fdocumentation 'thread-error-thread 'function) + "Return the offending thread that the THREAD-ERROR pertains to.") + +(define-condition symbol-value-in-thread-error (cell-error thread-error) + ((info :reader symbol-value-in-thread-error-info :initarg :info)) + (:report + (lambda (condition stream) + (destructuring-bind (op problem) + (symbol-value-in-thread-error-info condition) + (format stream "Cannot ~(~A~) value of ~S in ~S: ~S" + op + (cell-error-name condition) + (thread-error-thread condition) + (ecase problem + (:unbound-in-thread "the symbol is unbound in thread.") + (:no-tls-value "the symbol has no thread-local value.") + (:thread-dead "the thread has exited.") + (:invalid-tls-value "the thread-local value is not valid.")))))) + #!+sb-doc + (:documentation + "Signalled when SYMBOL-VALUE-IN-THREAD or its SETF version fails due to eg. +the symbol not having a thread-local value, or the target thread having +exited. The offending symbol can be accessed using CELL-ERROR-NAME, and the +offending thread using THREAD-ERROR-THREAD.")) + +(define-condition join-thread-error (thread-error) + ((problem :initarg :problem :reader join-thread-problem)) + (:report (lambda (c s) + (ecase (join-thread-problem c) + (:abort + (format s "Joining thread failed: thread ~A ~ + did not return normally." + (thread-error-thread c))) + (:timeout + (format s "Joining thread timed out: thread ~A ~ + did not exit in time." + (thread-error-thread c)))))) + #!+sb-doc + (:documentation + "Signalled when joining a thread fails due to abnormal exit of the thread +to be joined. The offending thread can be accessed using +THREAD-ERROR-THREAD.")) + +(define-deprecated-function :late "1.0.29.17" join-thread-error-thread thread-error-thread + (condition) + (thread-error-thread condition)) + +(define-condition interrupt-thread-error (thread-error) () + (:report (lambda (c s) + (format s "Interrupt thread failed: thread ~A has exited." + (thread-error-thread c)))) + #!+sb-doc + (:documentation + "Signalled when interrupting a thread fails because the thread has already +exited. The offending thread can be accessed using THREAD-ERROR-THREAD.")) + +(define-deprecated-function :late "1.0.29.17" interrupt-thread-error-thread thread-error-thread + (condition) + (thread-error-thread condition)) + ;;; 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) @@ -22,35 +154,57 @@ (setf (fdocumentation '*current-thread* 'variable) "Bound in each thread to the thread itself.") -(defstruct (thread (:constructor %make-thread)) - #!+sb-doc - "Thread type. Do not rely on threads being structs as it may change -in future versions." - name - %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 (fdocumentation 'thread-name 'function) - "The name of the thread. Setfable.") +(setf + (fdocumentation 'thread-name 'function) + "Name of the thread. Can be assigned to using SETF. Thread names can be +arbitrary printable objects, and need not be unique.") (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) + (let* ((thing (thread-waiting-for thread))) + (typecase thing + (cons + (list "waiting on:" (cdr thing) + "timeout: " (car thing))) + (null + (list info)) + (t + (list "waiting on:" thing)))) + (if (eq cookie (car info)) + (list :aborted) + :finished))) + (values (when (eq :finished state) + info)) + (*print-level* 4)) + (format stream + "~@[~S ~]~:[~{~I~A~^~2I~_ ~}~_~;~A~:[ no values~; values: ~:*~{~S~^, ~}~]~]" + (thread-name thread) + (eq :finished state) + state + values)))) + +(defun print-lock (lock name owner stream) + (let ((*print-circle* t)) + (print-unreadable-object (lock stream :type t :identity (not name)) + (if owner + (format stream "~@[~S ~]~2I~_owner: ~S" name owner) + (format stream "~@[~S ~](free)" name))))) + +(def!method print-object ((mutex mutex) stream) + (print-lock mutex (mutex-name mutex) (mutex-owner mutex) stream)) (defun thread-alive-p (thread) #!+sb-doc - "Check if THREAD is running." + "Return T if THREAD is still alive. Note that the return value is +potentially stale even before the function returns, as the thread may exit at +any time." (thread-%alive-p thread)) ;; A thread is eligible for gc iff it has finished and there are no @@ -59,17 +213,17 @@ 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) - #!-sb-thread - `(locally ,@body) - #!+sb-thread - `(without-interrupts - (with-mutex (*all-threads-lock*) - ,@body))) + `(with-system-mutex (*all-threads-lock*) + ,@body)) (defun list-all-threads () #!+sb-doc - "Return a list of the live threads." + "Return a list of the live threads. Note that the return value is +potentially stale even before the function returns, as new threads may be +created and old ones may exit at any time." (with-all-threads-lock (copy-list *all-threads*))) @@ -77,23 +231,31 @@ 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 () - (sap-int - (sb!vm::current-thread-offset-sap sb!vm::thread-os-thread-slot))) +(declaim (inline current-thread-os-thread)) +(defun current-thread-os-thread () + #!+sb-thread + (sap-int (sb!vm::current-thread-offset-sap sb!vm::thread-os-thread-slot)) + #!-sb-thread + 0) (defun init-initial-thread () (/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 ;; threads doesn't work. (setq *all-threads* (list initial-thread)))) + -;;;; +;;;; Aliens, low level stuff + +(define-alien-routine "kill_safely" + integer + (os-thread #!-alpha unsigned-long #!+alpha unsigned-int) + (signal int)) #!+sb-thread (progn @@ -104,68 +266,28 @@ in future versions." (define-alien-routine ("create_thread" %create-thread) unsigned-long (lisp-fun-address unsigned-long)) - (define-alien-routine "signal_interrupt_thread" - integer (os-thread unsigned-long)) + (declaim (inline %block-deferrable-signals)) + (define-alien-routine ("block_deferrable_signals" %block-deferrable-signals) + void + (where sb!alien:unsigned-long) + (old sb!alien:unsigned-long)) - (define-alien-routine "block_deferrable_signals" - void) + (defun block-deferrable-signals () + (%block-deferrable-signals 0 0)) - #!+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)) - - ;; 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)))) - - (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-lutex + #!+sb-futex (progn - (declaim (inline futex-wait futex-wake)) + (declaim (inline futex-wait %futex-wait futex-wake)) + + (define-alien-routine ("futex_wait" %futex-wait) + int (word unsigned-long) (old-value unsigned-long) + (to-sec long) (to-usec unsigned-long)) - (sb!alien:define-alien-routine "futex_wait" - int (word unsigned-long) (old-value unsigned-long)) + (defun futex-wait (word old to-sec to-usec) + (with-interrupts + (%futex-wait word old to-sec to-usec))) - (sb!alien:define-alien-routine "futex_wake" + (define-alien-routine "futex_wake" int (word unsigned-long) (n unsigned-long)))) ;;; used by debug-int.lisp to access interrupt contexts @@ -180,124 +302,383 @@ in future versions." (defun sb!vm::current-thread-offset-sap (n) (declare (type (unsigned-byte 27) n)) (sb!vm::current-thread-offset-sap n)) - -;;;; spinlocks -#!+sb-thread -(define-structure-slot-compare-and-swap - compare-and-swap-spinlock-value - :structure spinlock - :slot value) - -(declaim (inline get-spinlock release-spinlock)) - -(defun get-spinlock (spinlock) - (declare (optimize (speed 3) (safety 0)) - #!-sb-thread - (ignore spinlock)) - ;; %instance-set-conditional can test for 0 (which is a fixnum) and - ;; store any value - #!+sb-thread - (loop until - (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 (compare-and-swap-spinlock-value our-value 0) - ;; does not work for bignum thread ids. - #!+sb-thread - (setf (spinlock-value spinlock) 0) - nil) - -;;;; mutexes + + +(defmacro with-deadlocks ((thread lock &optional (timeout nil timeoutp)) &body forms) + (with-unique-names (n-thread n-lock new n-timeout) + `(let* ((,n-thread ,thread) + (,n-lock ,lock) + (,n-timeout ,(when timeoutp + `(or ,timeout + (when sb!impl::*deadline* + sb!impl::*deadline-seconds*)))) + (,new (if ,n-timeout + ;; Using CONS tells the rest of the system there's a + ;; timeout in place, so it isn't considered a deadlock. + (cons ,n-timeout ,n-lock) + ,n-lock))) + (declare (dynamic-extent ,new)) + ;; No WITHOUT-INTERRUPTS, since WITH-DEADLOCKS is used + ;; in places where interrupts should already be disabled. + (unwind-protect + (progn + (setf (thread-waiting-for ,n-thread) ,new) + ,@forms) + ;; Interrupt handlers and GC save and restore any + ;; previous wait marks using WITHOUT-DEADLOCKS below. + (setf (thread-waiting-for ,n-thread) nil))))) + +;;;; Mutexes #!+sb-doc (setf (fdocumentation 'make-mutex 'function) "Create a mutex." (fdocumentation 'mutex-name 'function) - "The name of the mutex. Setfable." - (fdocumentation 'mutex-value 'function) - "The value of the mutex. NIL if the mutex is free. Setfable.") + "The name of the mutex. Setfable.") -#!+(and sb-thread (not sb-lutex)) +#!+(and sb-thread sb-futex) (progn - (define-structure-slot-addressor mutex-value-address + (define-structure-slot-addressor mutex-state-address :structure mutex - :slot value) - (define-structure-slot-compare-and-swap - compare-and-swap-mutex-value - :structure mutex - :slot value)) + :slot state) + ;; Important: current code assumes these are fixnums or other + ;; lisp objects that don't need pinning. + (defconstant +lock-free+ 0) + (defconstant +lock-taken+ 1) + (defconstant +lock-contested+ 2)) + +(defun mutex-owner (mutex) + "Current owner of the mutex, NIL if the mutex is free. Naturally, +this is racy by design (another thread may acquire the mutex after +this function returns), it is intended for informative purposes. For +testing whether the current thread is holding a mutex see +HOLDING-MUTEX-P." + ;; Make sure to get the current value. + (sb!ext:compare-and-swap (mutex-%owner mutex) nil nil)) + +;;; Signals an error if owner of LOCK is waiting on a lock whose release +;;; depends on the current thread. Does not detect deadlocks from sempahores. +(defun check-deadlock () + (let* ((self *current-thread*) + (origin (thread-waiting-for self))) + (labels ((detect-deadlock (lock) + (let ((other-thread (mutex-%owner lock))) + (cond ((not other-thread)) + ((eq self other-thread) + (let* ((chain (deadlock-chain self origin)) + (barf + (format nil + "~%WARNING: DEADLOCK CYCLE DETECTED:~%~@< ~@;~ + ~{~:@_~S~:@_~}~:@>~ + ~%END OF CYCLE~%" + (mapcar #'car chain)))) + ;; Barf to stderr in case the system is too tied up + ;; to report the error properly -- to avoid cross-talk + ;; build the whole string up first. + (write-string barf sb!sys:*stderr*) + (finish-output sb!sys:*stderr*) + (error 'thread-deadlock + :thread *current-thread* + :cycle chain))) + (t + (let ((other-lock (thread-waiting-for other-thread))) + ;; If the thread is waiting with a timeout OTHER-LOCK + ;; is a cons, and we don't consider it a deadlock -- since + ;; it will time out on its own sooner or later. + (when (mutex-p other-lock) + (detect-deadlock other-lock))))))) + (deadlock-chain (thread lock) + (let* ((other-thread (mutex-owner lock)) + (other-lock (when other-thread + (thread-waiting-for other-thread)))) + (cond ((not other-thread) + ;; The deadlock is gone -- maybe someone unwound + ;; from the same deadlock already? + (return-from check-deadlock nil)) + ((consp other-lock) + ;; There's a timeout -- no deadlock. + (return-from check-deadlock nil)) + ((waitqueue-p other-lock) + ;; Not a lock. + (return-from check-deadlock nil)) + ((eq self other-thread) + ;; Done + (list (list thread lock))) + (t + (if other-lock + (cons (list thread lock) + (deadlock-chain other-thread other-lock)) + ;; Again, the deadlock is gone? + (return-from check-deadlock nil))))))) + ;; Timeout means there is no deadlock + (when (mutex-p origin) + (detect-deadlock origin) + t)))) + +(defun %try-mutex (mutex new-owner) + (declare (type mutex mutex) (optimize (speed 3))) + (barrier (:read)) + (let ((old (mutex-%owner mutex))) + (when (eq new-owner old) + (error "Recursive lock attempt ~S." mutex)) + #!-sb-thread + (when old + (error "Strange deadlock on ~S in an unithreaded build?" mutex)) + #!-sb-futex + (and (not (mutex-%owner mutex)) + (not (sb!ext:compare-and-swap (mutex-%owner mutex) nil new-owner))) + #!+sb-futex + ;; From the Mutex 2 algorithm from "Futexes are Tricky" by Ulrich Drepper. + (when (eql +lock-free+ (sb!ext:compare-and-swap (mutex-state mutex) + +lock-free+ + +lock-taken+)) + (let ((prev (sb!ext:compare-and-swap (mutex-%owner mutex) nil new-owner))) + (when prev + (bug "Old owner in free mutex: ~S" prev)) + t)))) -(defun get-mutex (mutex &optional (new-value *current-thread*) (wait-p 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." +#!+sb-thread +(defun %%wait-for-mutex (mutex new-owner to-sec to-usec stop-sec stop-usec) (declare (type mutex mutex) (optimize (speed 3))) - (/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 ~ - new-value ~S, but has already been acquired (with value ~S)." - mutex wait-p new-value old-value)) - (setf (mutex-value mutex) new-value) - t) - #!+sb-thread - (progn - (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*)) - #!+sb-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) - (loop - (unless - (setf old - (compare-and-swap-mutex-value mutex nil new-value)) - (return t)) - (unless wait-p (return nil)) - (with-pinned-objects (mutex old) - (futex-wait (mutex-value-address mutex) - (get-lisp-obj-address old))))))) - -(defun release-mutex (mutex) + #!-sb-futex + (declare (ignore to-sec to-usec)) + #!-sb-futex + (flet ((cas () + (loop repeat 24 + when (and (not (mutex-%owner mutex)) + (not (sb!ext:compare-and-swap (mutex-%owner mutex) nil + new-owner))) + do (return-from cas t)) + ;; Check for pending interrupts. + (with-interrupts nil))) + (declare (dynamic-extent #'cas)) + (sb!impl::%%wait-for #'cas stop-sec stop-usec)) + #!+sb-futex + ;; This is a fairly direct translation of the Mutex 2 algorithm from + ;; "Futexes are Tricky" by Ulrich Drepper. + (flet ((maybe (old) + (when (eql +lock-free+ old) + (let ((prev (sb!ext:compare-and-swap (mutex-%owner mutex) + nil new-owner))) + (when prev + (bug "Old owner in free mutex: ~S" prev)) + (return-from %%wait-for-mutex t))))) + (prog ((old (sb!ext:compare-and-swap (mutex-state mutex) + +lock-free+ +lock-taken+))) + ;; Got it right off the bat? + (maybe old) + :retry + ;; Mark it as contested, and sleep. (Exception: it was just released.) + (when (or (eql +lock-contested+ old) + (not (eql +lock-free+ + (sb!ext:compare-and-swap + (mutex-state mutex) +lock-taken+ +lock-contested+)))) + (when (eql 1 (with-pinned-objects (mutex) + (futex-wait (mutex-state-address mutex) + (get-lisp-obj-address +lock-contested+) + (or to-sec -1) + (or to-usec 0)))) + ;; -1 = EWOULDBLOCK, possibly spurious wakeup + ;; 0 = normal wakeup + ;; 1 = ETIMEDOUT ***DONE*** + ;; 2 = EINTR, a spurious wakeup + (return-from %%wait-for-mutex nil))) + ;; Try to get it, still marking it as contested. + (maybe + (sb!ext:compare-and-swap (mutex-state mutex) +lock-free+ +lock-contested+)) + ;; Update timeout if necessary. + (when stop-sec + (setf (values to-sec to-usec) + (sb!impl::relative-decoded-times stop-sec stop-usec))) + ;; Spin. + (go :retry)))) + +(defun %wait-for-mutex (mutex self timeout to-sec to-usec stop-sec stop-usec deadlinep) + (with-deadlocks (self mutex timeout) + (with-interrupts (check-deadlock)) + (tagbody + :again + (return-from %wait-for-mutex + (or (%%wait-for-mutex mutex self to-sec to-usec stop-sec stop-usec) + (when deadlinep + (signal-deadline) + ;; FIXME: substract elapsed time from timeout... + (setf (values to-sec to-usec stop-sec stop-usec deadlinep) + (decode-timeout timeout)) + (go :again))))))) + +(defun get-mutex (mutex &optional new-owner (waitp t) (timeout nil)) + #!+sb-doc + "Deprecated in favor of GRAB-MUTEX." + (declare (ignorable waitp timeout)) + (let ((new-owner (or new-owner *current-thread*))) + (or (%try-mutex mutex new-owner) + #!+sb-thread + (when waitp + (multiple-value-call #'%wait-for-mutex + mutex new-owner timeout (decode-timeout timeout)))))) + +(defun grab-mutex (mutex &key (waitp t) (timeout nil)) + #!+sb-doc + "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. + +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 NIL which denotes +that GRAB-MUTEX did -not- acquire the lock. + +Notes: + + - GRAB-MUTEX is not interrupt safe. The correct way to call it is: + + (WITHOUT-INTERRUPTS + ... + (ALLOW-WITH-INTERRUPTS (GRAB-MUTEX ...)) + ...) + + WITHOUT-INTERRUPTS is necessary to avoid an interrupt unwinding the call + while the mutex is in an inconsistent state while ALLOW-WITH-INTERRUPTS + allows the call to be interrupted from sleep. + + - (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 entering + GRAB-MUTEX. + + The exact interplay of GRAB-MUTEX and deadlines are reserved to change in + future versions. + + - It is recommended that you use WITH-MUTEX instead of calling GRAB-MUTEX + directly. +" + (declare (ignorable waitp timeout)) + (let ((self *current-thread*)) + (or (%try-mutex mutex self) + #!+sb-thread + (when waitp + (multiple-value-call #'%wait-for-mutex + mutex self timeout (decode-timeout timeout)))))) + +(defun release-mutex (mutex &key (if-not-owner :punt)) #!+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 - (progn - #!+sb-lutex - (with-lutex-address (lutex (mutex-lutex mutex)) - (%lutex-unlock lutex)) - #!-sb-lutex - (futex-wake (mutex-value-address mutex) 1))) +this mutex. -;;;; waitqueues/condition variables +RELEASE-MUTEX is not interrupt safe: interrupts should be disabled +around calls to it. +If the current thread is not the owner of the mutex then it silently +returns without doing anything (if IF-NOT-OWNER is :PUNT), signals a +WARNING (if IF-NOT-OWNER is :WARN), or releases the mutex anyway (if +IF-NOT-OWNER is :FORCE)." + (declare (type mutex mutex)) + ;; Order matters: set owner to NIL before releasing state. + (let* ((self *current-thread*) + (old-owner (sb!ext:compare-and-swap (mutex-%owner mutex) self nil))) + (unless (eq self old-owner) + (ecase if-not-owner + ((:punt) (return-from release-mutex nil)) + ((:warn) + (warn "Releasing ~S, owned by another thread: ~S" mutex old-owner)) + ((:force))) + (setf (mutex-%owner mutex) nil) + ;; FIXME: Is a :memory barrier too strong here? Can we use a :write + ;; barrier instead? + (barrier (:memory))) + #!+sb-futex + (when old-owner + ;; FIXME: once ATOMIC-INCF supports struct slots with word sized + ;; unsigned-byte type this can be used: + ;; + ;; (let ((old (sb!ext:atomic-incf (mutex-state mutex) -1))) + ;; (unless (eql old +lock-free+) + ;; (setf (mutex-state mutex) +lock-free+) + ;; (with-pinned-objects (mutex) + ;; (futex-wake (mutex-state-address mutex) 1)))) + (let ((old (sb!ext:compare-and-swap (mutex-state mutex) + +lock-taken+ +lock-free+))) + (when (eql old +lock-contested+) + (sb!ext:compare-and-swap (mutex-state mutex) + +lock-contested+ +lock-free+) + (with-pinned-objects (mutex) + (futex-wake (mutex-state-address mutex) 1)))) + nil))) + + +;;;; Waitqueues/condition variables + +#!+(or (not sb-thread) sb-futex) (defstruct (waitqueue (:constructor %make-waitqueue)) #!+sb-doc "Waitqueue type." - (name nil :type (or null simple-string)) - #!+(and sb-lutex sb-thread) - (lutex (make-lutex)) - #!-sb-lutex - (data nil)) + (name nil :type (or null thread-name)) + #!+sb-futex + (token nil)) + +#!+(and sb-thread (not sb-futex)) +(progn + (defstruct (waitqueue (:constructor %make-waitqueue)) + #!+sb-doc + "Waitqueue type." + (name nil :type (or null thread-name)) + ;; For WITH-CAS-LOCK: because CONDITION-WAIT must be able to call + ;; %WAITQUEUE-WAKEUP without re-aquiring the mutex, we need a separate + ;; lock. In most cases this should be uncontested thanks to the mutex -- + ;; the only case where that might not be true is when CONDITION-WAIT + ;; unwinds and %WAITQUEUE-DROP is called. + %owner + %head + %tail) + + (defun %waitqueue-enqueue (thread queue) + (setf (thread-waiting-for thread) queue) + (let ((head (waitqueue-%head queue)) + (tail (waitqueue-%tail queue)) + (new (list thread))) + (unless head + (setf (waitqueue-%head queue) new)) + (when tail + (setf (cdr tail) new)) + (setf (waitqueue-%tail queue) new) + nil)) + (defun %waitqueue-drop (thread queue) + (setf (thread-waiting-for thread) nil) + (let ((head (waitqueue-%head queue))) + (do ((list head (cdr list)) + (prev nil)) + ((eq (car list) thread) + (let ((rest (cdr list))) + (cond (prev + (setf (cdr prev) rest)) + (t + (setf (waitqueue-%head queue) rest + prev rest))) + (unless rest + (setf (waitqueue-%tail queue) prev)))) + (setf prev list))) + nil) + (defun %waitqueue-wakeup (queue n) + (declare (fixnum n)) + (loop while (plusp n) + for next = (let ((head (waitqueue-%head queue)) + (tail (waitqueue-%tail queue))) + (when head + (if (eq head tail) + (setf (waitqueue-%head queue) nil + (waitqueue-%tail queue) nil) + (setf (waitqueue-%head queue) (cdr head))) + (car head))) + while next + do (when (eq queue (sb!ext:compare-and-swap (thread-waiting-for next) queue nil)) + (decf n))) + 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 @@ -308,123 +689,279 @@ this mutex." (setf (fdocumentation 'waitqueue-name 'function) "The name of the waitqueue. Setfable.") -#!+(and sb-thread (not sb-lutex)) -(define-structure-slot-addressor waitqueue-data-address +#!+(and sb-thread sb-futex) +(define-structure-slot-addressor waitqueue-token-address :structure waitqueue - :slot data) + :slot token) -(defun condition-wait (queue mutex) +(defun condition-wait (queue mutex &key timeout) #!+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." - #!-sb-thread (declare (ignore queue)) + "Atomically release MUTEX and start waiting on QUEUE for till another thread +wakes us up using either CONDITION-NOTIFY or CONDITION-BROADCAST on that +queue, at which point we re-acquire MUTEX and return T. + +Spurious wakeups are possible. + +If TIMEOUT is given, it is the maximum number of seconds to wait, including +both waiting for the wakeup and the time to re-acquire MUTEX. Unless both +wakeup and re-acquisition do not occur within the given time, returns NIL +without re-acquiring the mutex. + +If CONDITION-WAIT unwinds, it may do so with or without the mutex being held. + +Important: Since 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 (&optional timeout) + (with-mutex (*lock*) + (loop until *data* + do (or (condition-wait *queue* *lock* :timeout timeout) + ;; Lock not held, must unwind without touching *data*. + (return-from pop-data nil))) + (pop *data*))) + + ;; Producer + (defun push-data (data) + (with-mutex (*lock*) + (push data *data*) + (condition-notify *queue*))) +" + #!-sb-thread (declare (ignore queue timeout)) (assert mutex) - #!-sb-thread (error "Not supported in unithread builds.") + #!-sb-thread + (wait-for nil :timeout timeout) ; Yeah... #!+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 - ;; is visible to all CPUs - (setf (waitqueue-data queue) me) - (release-mutex mutex) - ;; Now we go to sleep using futex-wait. If anyone else - ;; 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 - (with-pinned-objects (queue me) - (futex-wait (waitqueue-data-address queue) - (get-lisp-obj-address me)))) - ;; 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)))) + (let ((me *current-thread*)) + (barrier (:read)) + (assert (eq me (mutex-%owner mutex))) + (multiple-value-bind (to-sec to-usec stop-sec stop-usec deadlinep) + (decode-timeout timeout) + (let ((status :interrupted)) + ;; Need to disable interrupts so that we don't miss grabbing the + ;; mutex on our way out. + (without-interrupts + (unwind-protect + (progn + #!-sb-futex + (progn + (%waitqueue-enqueue me queue) + (release-mutex mutex) + (setf status + (or (flet ((wakeup () + (when (neq queue (thread-waiting-for me)) + :ok))) + (declare (dynamic-extent #'wakeup)) + (allow-with-interrupts + (sb!impl::%%wait-for #'wakeup stop-sec stop-usec))) + :timeout))) + #!+sb-futex + (with-pinned-objects (queue me) + (setf (waitqueue-token queue) me) + (release-mutex mutex) + ;; Now we go to sleep using futex-wait. If anyone else + ;; manages to grab MUTEX and call CONDITION-NOTIFY during + ;; this comment, it will change the token, and so futex-wait + ;; returns immediately instead of sleeping. Ergo, no lost + ;; wakeup. We may get spurious wakeups, but that's ok. + (setf status + (case (allow-with-interrupts + (futex-wait (waitqueue-token-address queue) + (get-lisp-obj-address me) + ;; our way of saying "no + ;; timeout": + (or to-sec -1) + (or to-usec 0))) + ((1) + ;; 1 = ETIMEDOUT + :timeout) + (t + ;; -1 = EWOULDBLOCK, possibly spurious wakeup + ;; 0 = normal wakeup + ;; 2 = EINTR, a spurious wakeup + :ok))))) + #!-sb-futex + (%with-cas-lock ((waitqueue-%owner queue)) + (if (eq queue (thread-waiting-for me)) + (%waitqueue-drop me queue) + (unless (eq :ok status) + ;; CONDITION-NOTIFY thinks we've been woken up, but really + ;; we're unwinding. Wake someone else up. + (%waitqueue-wakeup queue 1)))) + ;; Update timeout for mutex re-aquisition. + (when (and (eq :ok status) to-sec) + (setf (values to-sec to-usec) + (sb!impl::relative-decoded-times stop-sec stop-usec))) + ;; If we ran into deadline, try to get the mutex before + ;; signaling. If we don't unwind it will look like a normal + ;; return from user perspective. + (when (and (eq :timeout status) deadlinep) + (let ((got-it (%try-mutex mutex me))) + (allow-with-interrupts + (signal-deadline) + (cond (got-it + (return-from condition-wait t)) + (t + ;; The deadline may have changed. + (setf (values to-sec to-usec stop-sec stop-usec deadlinep) + (decode-timeout timeout)) + (setf status :ok)))))) + ;; Re-acquire the mutex for normal return. + (when (eq :ok status) + (unless (or (%try-mutex mutex me) + (allow-with-interrupts + (%wait-for-mutex mutex me timeout + to-sec to-usec + stop-sec stop-usec deadlinep))) + (setf status :timeout))))) + (or (eq :ok status) + (unless (eq :timeout status) + ;; The only case we return normally without re-acquiring the + ;; mutex is when there is a :TIMEOUT that runs out. + (bug "CONDITION-WAIT: invalid status on normal return: ~S" status))))))) (defun condition-notify (queue &optional (n 1)) #!+sb-doc - "Notify N threads waiting on QUEUE." - #!-sb-thread (declare (ignore queue n)) - #!-sb-thread (error "Not supported in unithread builds.") + "Notify N threads waiting on QUEUE. + +IMPORTANT: The same mutex that is used in the corresponding CONDITION-WAIT +must be held by this thread during this call." + #!-sb-thread + (declare (ignore queue n)) + #!-sb-thread + (error "Not supported in unithread builds.") #!+sb-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 + #!-sb-futex + (with-cas-lock ((waitqueue-%owner queue)) + (%waitqueue-wakeup queue n)) + #!+sb-futex + (progn + ;; 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 -- using the queue object itself is handy. + ;; ;; XXX we should do something to ensure that the result of this setf - ;; is visible to all CPUs - #!-sb-lutex - (let ((me *current-thread*)) - (progn - (setf (waitqueue-data queue) me) - (with-pinned-objects (queue) - (futex-wake (waitqueue-data-address queue) n)))))) + ;; is visible to all CPUs. + ;; + ;; ^-- surely futex_wake() involves a memory barrier? + (setf (waitqueue-token queue) queue) + (with-pinned-objects (queue) + (futex-wake (waitqueue-token-address queue) n))))) (defun condition-broadcast (queue) #!+sb-doc - "Notify all threads waiting on QUEUE." + "Notify all threads waiting on QUEUE. + +IMPORTANT: The same mutex that is used in the corresponding CONDITION-WAIT +must be held by this thread during this call." (condition-notify queue - ;; On a 64-bit platform truncating M-P-F to an int results - ;; in -1, which wakes up only one thread. + ;; 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 +;;;; Semaphores -(defstruct (semaphore (:constructor %make-semaphore)) +(defstruct (semaphore (:constructor %make-semaphore (name %count))) #!+sb-doc - "Semaphore type." - (name nil :type (or null simple-string)) - (count 0 :type (integer 0)) + "Semaphore type. The fact that a SEMAPHORE is a STRUCTURE-OBJECT +should be considered an implementation detail, and may change in the +future." + (name nil :type (or null thread-name)) + (%count 0 :type (integer 0)) + (waitcount 0 :type sb!vm:word) (mutex (make-mutex)) (queue (make-waitqueue))) +(setf (fdocumentation 'semaphore-name 'function) + "The name of the semaphore INSTANCE. Setfable.") + +(declaim (inline semaphore-count)) +(defun semaphore-count (instance) + "Returns the current count of the semaphore INSTANCE." + (barrier (:read)) + (semaphore-%count instance)) + (defun make-semaphore (&key name (count 0)) #!+sb-doc - "Create a semaphore with the supplied COUNT." - (%make-semaphore :name name :count count)) + "Create a semaphore with the supplied COUNT and NAME." + (%make-semaphore name count)) -(setf (fdocumentation 'semaphore-name 'function) - "The name of the semaphore. Setfable.") +(defun wait-on-semaphore (semaphore &key timeout) + #!+sb-doc + "Decrement the count of SEMAPHORE if the count would not be negative. Else +blocks until the semaphore can be decremented. Returns T on success. + +If TIMEOUT is given, it is the maximum number of seconds to wait. If the count +cannot be decremented in that time, returns NIL without decrementing the +count." + ;; A more direct implementation based directly on futexes should be + ;; possible. + ;; + ;; We need to disable interrupts so that we don't forget to + ;; decrement the waitcount (which would happen if an asynch + ;; interrupt should catch us on our way out from the loop.) + ;; + ;; FIXME: No timeout on initial mutex acquisition. + (with-system-mutex ((semaphore-mutex semaphore) :allow-with-interrupts t) + ;; Quick check: is it positive? If not, enter the wait loop. + (let ((count (semaphore-%count semaphore))) + (if (plusp count) + (setf (semaphore-%count semaphore) (1- count)) + (unwind-protect + (progn + ;; Need to use ATOMIC-INCF despite the lock, because on our + ;; way out from here we might not be locked anymore -- so + ;; another thread might be tweaking this in parallel using + ;; ATOMIC-DECF. No danger over overflow, since there it + ;; at most one increment per thread waiting on the semaphore. + (sb!ext:atomic-incf (semaphore-waitcount semaphore)) + (loop until (plusp (setf count (semaphore-%count semaphore))) + do (or (condition-wait (semaphore-queue semaphore) + (semaphore-mutex semaphore) + :timeout timeout) + (return-from wait-on-semaphore nil))) + (setf (semaphore-%count semaphore) (1- count))) + ;; Need to use ATOMIC-DECF instead of DECF, as CONDITION-WAIT + ;; may unwind without the lock being held due to timeouts. + (sb!ext:atomic-decf (semaphore-waitcount semaphore)))))) + t) -(defun wait-on-semaphore (sem) +(defun try-semaphore (semaphore &optional (n 1)) #!+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)) + "Try to decrement the count of SEMAPHORE by N. If the count were to +become negative, punt and return NIL, otherwise return true." + (declare (type (integer 1) n)) + (with-system-mutex ((semaphore-mutex semaphore) :allow-with-interrupts t) + (let ((new-count (- (semaphore-%count semaphore) n))) + (when (not (minusp new-count)) + (setf (semaphore-%count semaphore) new-count))))) + +(defun signal-semaphore (semaphore &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 + "Increment the count of SEMAPHORE by N. If there are threads waiting +on this semaphore, then N of them is woken up." + (declare (type (integer 1) n)) + ;; Need to disable interrupts so that we don't lose a wakeup after + ;; we have incremented the count. + (with-system-mutex ((semaphore-mutex semaphore) :allow-with-interrupts t) + (let ((waitcount (semaphore-waitcount semaphore)) + (count (incf (semaphore-%count semaphore) n))) + (when (plusp waitcount) + (condition-notify (semaphore-queue semaphore) (min waitcount count)))))) + + +;;;; Job control, independent listeners (defstruct session (lock (make-mutex :name "session lock")) @@ -434,17 +971,21 @@ 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) - #!-sb-thread (declare (ignore session)) - #!-sb-thread - `(locally ,@body) - #!+sb-thread - `(without-interrupts - (with-mutex ((session-lock ,session)) - ,@body))) + `(with-system-mutex ((session-lock ,session) :allow-with-interrupts t) + ,@body)) (defun new-session () (make-session :threads (list *current-thread*) @@ -477,21 +1018,13 @@ this semaphore, then N of them is woken up." #!+sb-thread (defun handle-thread-exit (thread) (/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)))) + (%delete-thread-from-session thread *session*)))) (defun terminate-session () #!+sb-doc @@ -591,22 +1124,32 @@ have the foreground next." (sb!impl::toplevel-repl nil) (sb!int:flush-standard-output-streams)))))) (make-thread #'thread-repl)))) + -;;;; the beef +;;;; The beef -(defun make-thread (function &key name) +(defun make-thread (function &key name arguments) #!+sb-doc - "Create a new thread of NAME that runs FUNCTION. When the function + "Create a new thread of NAME that runs FUNCTION with the argument +list designator provided (defaults to no argument). When the function 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 (declare (ignore function name arguments)) #!-sb-thread (error "Not supported in unithread builds.") + #!+sb-thread (assert (or (atom arguments) + (null (cdr (last arguments)))) + (arguments) + "Argument passed to ~S, ~S, is an improper list." + 'make-thread arguments) #!+sb-thread (let* ((thread (%make-thread :name name)) (setup-sem (make-semaphore :name "Thread setup semaphore")) (real-function (coerce function 'function)) + (arguments (if (listp arguments) + arguments + (list arguments))) (initial-function - (lambda () + (named-lambda initial-thread-function () ;; In time we'll move some of the binding presently done in C ;; here too. ;; @@ -619,19 +1162,24 @@ around and can be retrieved by JOIN-THREAD." ;; 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)) + ;; + ;; As it is, this lambda must not cons until we are ready + ;; to run GC. Be very careful. + (let* ((*current-thread* thread) + (*restart-clusters* nil) + (*handler-clusters* (sb!kernel::initial-handler-clusters)) + (*condition-restarts* nil) + (sb!impl::*deadline* nil) + (sb!impl::*deadline-seconds* nil) + (sb!impl::*step-out* nil) + ;; internal printer variables + (sb!impl::*previous-case* nil) + (sb!impl::*previous-readtable-case* nil) + (sb!impl::*internal-symbol-output-fun* nil) + (sb!impl::*descriptor-handlers* nil)) ; serve-event + ;; 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*)) @@ -649,118 +1197,140 @@ around and can be retrieved by JOIN-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))))))) + (without-interrupts + (unwind-protect + (with-local-interrupts + ;; Now that most things have a chance + ;; to work properly without messing up + ;; other threads, it's time to enable + ;; signals. + (sb!unix::unblock-deferrable-signals) + (setf (thread-result thread) + (cons t + (multiple-value-list + (apply real-function arguments)))) + ;; Try to block deferrables. An + ;; interrupt may unwind it, but for a + ;; normal exit it prevents interrupt + ;; loss. + (block-deferrable-signals)) + ;; We're going down, can't handle interrupts + ;; sanely anymore. GC remains enabled. + (block-deferrable-signals) + ;; We don't want to run interrupts in a dead + ;; thread when we leave WITHOUT-INTERRUPTS. + ;; This potentially causes important + ;; interupts to be lost: SIGINT comes to + ;; mind. + (setq *interrupt-pending* nil) + (handle-thread-exit thread)))))))) (values)))) + ;; If the starting thread is stopped for gc before it signals the + ;; semaphore then we'd be stuck. + (assert (not *gc-inhibit*)) ;; 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)) + ;; initialized properly. Wrap the whole thing in + ;; WITHOUT-INTERRUPTS because we pass INITIAL-FUNCTION to another + ;; thread. + (without-interrupts + (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))))) + +(defun join-thread (thread &key (default nil defaultp) timeout) #!+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))))) + "Suspend current thread until THREAD exits. Return the result values of the +thread function. + +If the thread does not exit normally within TIMEOUT seconds return DEFAULT if +given, or else signal JOIN-THREAD-ERROR. + +NOTE: Return convention in case of a timeout is exprimental and subject to +change." + (let ((lock (thread-result-lock thread)) + (got-it nil) + (problem :timeout)) + (without-interrupts + (unwind-protect + (if (setf got-it + (allow-with-interrupts + ;; Don't use the timeout if the thread is not alive anymore. + (grab-mutex lock :timeout (and (thread-alive-p thread) timeout)))) + (cond ((car (thread-result thread)) + (return-from join-thread + (values-list (cdr (thread-result thread))))) + (defaultp + (return-from join-thread default)) + (t + (setf problem :abort))) + (when defaultp + (return-from join-thread default))) + (when got-it + (release-mutex lock)))) + (error 'join-thread-error :thread thread :problem problem))) (defun destroy-thread (thread) #!+sb-doc "Deprecated. Same as TERMINATE-THREAD." (terminate-thread thread)) -(define-condition interrupt-thread-error (error) - ((thread :reader interrupt-thread-error-thread :initarg :thread)) - #!+sb-doc - (:documentation "Interrupting thread failed.") - (:report (lambda (c s) - (format s "Interrupt thread failed: thread ~A has exited." - (interrupt-thread-error-thread c))))) - -#!+sb-doc -(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))) + `(with-system-mutex ((thread-interruptions-lock ,thread)) + ,@body)) -;; Called from the signal handler. +;;; Called from the signal handler. +#!-win32 (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. + (let ((interruption (with-interruptions-lock (*current-thread*) + (pop (thread-interruptions *current-thread*))))) + ;; If there is more to do, then resignal and let the normal + ;; interrupt deferral mechanism take care of the rest. From the + ;; OS's point of view the signal we are in the handler for is no + ;; longer pending, so the signal will not be lost. + (when (thread-interruptions *current-thread*) + (kill-safely (thread-os-thread *current-thread*) sb!unix:sigpipe)) + (when interruption + (funcall interruption)))) + (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 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." - #!-sb-thread (declare (ignore thread)) - ;; not quite perfect, because it does not take WITHOUT-INTERRUPTS - ;; into account - #!-sb-thread - (funcall function) - #!+sb-thread - (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))))))) +won't like the effect. FUNCTION runs with interrupts disabled, but +WITH-INTERRUPTS is allowed in it. Keep in mind that many things may +enable interrupts (GET-MUTEX when contended, for instance) so the +first thing to do is usually a WITH-INTERRUPTS or a +WITHOUT-INTERRUPTS. Within a thread interrupts are queued, they are +run in same the order they were sent." + #!+win32 + (declare (ignore thread)) + #!+win32 + (with-interrupt-bindings + (with-interrupts (funcall function))) + #!-win32 + (let ((os-thread (thread-os-thread thread))) + (cond ((not os-thread) + (error 'interrupt-thread-error :thread thread)) + (t + (with-interruptions-lock (thread) + ;; Append to the end of the interruptions queue. It's + ;; O(N), but it does not hurt to slow interruptors down a + ;; bit when the queue gets long. + (setf (thread-interruptions thread) + (append (thread-interruptions thread) + (list (lambda () + (without-interrupts + (allow-with-interrupts + (funcall function)))))))) + (when (minusp (kill-safely os-thread sb!unix:sigpipe)) + (error 'interrupt-thread-error :thread thread)))))) (defun terminate-thread (thread) #!+sb-doc @@ -768,36 +1338,163 @@ 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 +(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 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)))) +(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) + ;; Prevent the thread from dying completely while we look for the TLS + ;; area... + (with-all-threads-lock + (loop + (if (thread-alive-p thread) + (let* ((epoch sb!kernel::*gc-epoch*) + (offset (sb!kernel:get-lisp-obj-address + (sb!vm::symbol-tls-index symbol))) + (tl-val (sap-ref-word (%thread-sap thread) offset))) + (cond ((zerop offset) + (return (values nil :no-tls-value))) + ((or (eql tl-val sb!vm:no-tls-value-marker-widetag) + (eql tl-val sb!vm:unbound-marker-widetag)) + (return (values nil :unbound-in-thread))) + (t + (multiple-value-bind (obj ok) (make-lisp-obj tl-val nil) + ;; The value we constructed may be invalid if a GC has + ;; occurred. That is harmless, though, since OBJ is + ;; either in a register or on stack, and we are + ;; conservative on both on GENCGC -- so a bogus object + ;; is safe here as long as we don't return it. If we + ;; ever port threads to a non-conservative GC we must + ;; pin the TL-VAL address before constructing OBJ, or + ;; make WITH-ALL-THREADS-LOCK imply WITHOUT-GCING. + ;; + ;; The reason we don't just rely on TL-VAL pinning the + ;; object is that the call to MAKE-LISP-OBJ may cause + ;; bignum allocation, at which point TL-VAL might not + ;; be alive anymore -- hence the epoch check. + (when (eq epoch sb!kernel::*gc-epoch*) + (if ok + (return (values obj :ok)) + (return (values obj :invalid-tls-value)))))))) + (return (values nil :thread-dead)))))) + + (defun %set-symbol-value-in-thread (symbol thread value) + (with-pinned-objects (value) + ;; Prevent the thread from dying completely while we look for the TLS + ;; area... + (with-all-threads-lock + (if (thread-alive-p thread) + (let ((offset (sb!kernel:get-lisp-obj-address + (sb!vm::symbol-tls-index symbol)))) + (cond ((zerop offset) + (values nil :no-tls-value)) + (t + (setf (sap-ref-word (%thread-sap thread) offset) + (get-lisp-obj-address value)) + (values value :ok)))) + (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 +on success. + +If the value cannot be retrieved (because the thread has exited or because it +has no local binding for NAME) and ERRORP is true signals an error of type +SYMBOL-VALUE-IN-THREAD-ERROR; if ERRORP is false returns a primary value of +NIL, and a secondary value of NIL. + +Can also be used with SETF to change the thread-local value of SYMBOL. + +SYMBOL-VALUE-IN-THREAD is primarily intended as a debugging tool, and not as a +mechanism for inter-thread communication." + (declare (symbol symbol) (thread thread)) + #!+sb-thread + (multiple-value-bind (res status) (%symbol-value-in-thread symbol thread) + (if (eq :ok status) + (values res t) + (if errorp + (error 'symbol-value-in-thread-error + :name symbol + :thread thread + :info (list :read status)) + (values nil nil)))) + #!-sb-thread + (if (boundp symbol) + (values (symbol-value symbol) t) + (if errorp + (error 'symbol-value-in-thread-error + :name symbol + :thread thread + :info (list :read :unbound-in-thread)) + (values nil nil)))) + +(defun (setf symbol-value-in-thread) (value symbol thread &optional (errorp t)) + (declare (symbol symbol) (thread thread)) + #!+sb-thread + (multiple-value-bind (res status) (%set-symbol-value-in-thread symbol thread value) + (if (eq :ok status) + (values res t) + (if errorp + (error 'symbol-value-in-thread-error + :name symbol + :thread thread + :info (list :write status)) + (values nil nil)))) + #!-sb-thread + (if (boundp symbol) + (values (setf (symbol-value symbol) value) t) + (if errorp + (error 'symbol-value-in-thread-error + :name symbol + :thread thread + :info (list :write :unbound-in-thread)) + (values nil nil)))) (defun sb!vm::locked-symbol-global-value-add (symbol-name delta) (sb!vm::locked-symbol-global-value-add symbol-name delta)) + -;;; Stepping +;;;; Stepping (defun thread-stepping () (make-lisp-obj