;;; 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))
(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)
- (if (thread-name thread)
- (print-unreadable-object (thread stream :type t :identity t)
- (prin1 (thread-name thread) stream))
- (print-unreadable-object (thread stream :type t :identity t)
- ;; body is empty => there is only one space between type and
- ;; identity
- ))
- thread)
+ (print-unreadable-object (thread stream :type t :identity t)
+ (let* ((cookie (list thread))
+ (info (if (thread-alive-p thread)
+ :running
+ (multiple-value-list
+ (join-thread thread :default cookie))))
+ (state (if (eq :running info)
+ info
+ (if (eq cookie (car info))
+ :aborted
+ :finished)))
+ (values (when (eq :finished state) info)))
+ (format stream
+ "~@[~S ~]~:[~A~;~A~:[ no values~; values: ~:*~{~S~^, ~}~]~]"
+ (thread-name thread)
+ (eq :finished state)
+ state
+ values))))
(defun thread-alive-p (thread)
#!+sb-doc
(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
(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))))
+\f
-;;;;
+;;;; Aliens, low level stuff
#!+sb-thread
(progn
(declaim (inline %lutex-init %lutex-wait %lutex-wake
%lutex-lock %lutex-unlock))
- (sb!alien:define-alien-routine ("lutex_init" %lutex-init)
+ (define-alien-routine ("lutex_init" %lutex-init)
int (lutex unsigned-long))
- (sb!alien:define-alien-routine ("lutex_wait" %lutex-wait)
+ (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)
+ (define-alien-routine ("lutex_wake" %lutex-wake)
int (lutex unsigned-long) (n int))
- (sb!alien:define-alien-routine ("lutex_lock" %lutex-lock)
+ (define-alien-routine ("lutex_lock" %lutex-lock)
int (lutex unsigned-long))
- (sb!alien:define-alien-routine ("lutex_trylock" %lutex-trylock)
+ (define-alien-routine ("lutex_trylock" %lutex-trylock)
int (lutex unsigned-long))
- (sb!alien:define-alien-routine ("lutex_unlock" %lutex-unlock)
+ (define-alien-routine ("lutex_unlock" %lutex-unlock)
int (lutex unsigned-long))
- (sb!alien:define-alien-routine ("lutex_destroy" %lutex-destroy)
+ (define-alien-routine ("lutex_destroy" %lutex-destroy)
int (lutex unsigned-long))
;; FIXME: Defining a whole bunch of alien-type machinery just for
(defmacro with-lutex-address ((name lutex) &body body)
`(let ((,name ,lutex))
(with-pinned-objects (,name)
- (let ((,name (sb!kernel:get-lisp-obj-address ,name)))
+ (let ((,name (get-lisp-obj-address ,name)))
,@body))))
(defun make-lutex ()
#!-sb-lutex
(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
(defun sb!vm::current-thread-offset-sap (n)
(declare (type (unsigned-byte 27) n))
(sb!vm::current-thread-offset-sap n))
+\f
-;;;; spinlocks
+;;;; Spinlocks
(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
+;;; Should always be called with interrupts disabled.
(defun get-spinlock (spinlock)
- (declare (optimize (speed 3) (safety 0))
- #!-sb-thread
- (ignore spinlock new-value))
- ;; %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 1) 0))
- t)
+ (declare (optimize (speed 3) (safety 0)))
+ (let* ((new *current-thread*)
+ (old (sb!ext:compare-and-swap (spinlock-value spinlock) nil new)))
+ (when old
+ (when (eq old new)
+ (error "Recursive lock attempt on ~S." spinlock))
+ #!+sb-thread
+ (flet ((cas ()
+ (if (sb!ext:compare-and-swap (spinlock-value spinlock) nil new)
+ (thread-yield)
+ (return-from get-spinlock t))))
+ (if (and (not *interrupts-enabled*) *allow-with-interrupts*)
+ ;; If interrupts are disabled, but we are allowed to
+ ;; enabled them, check for pending interrupts every once
+ ;; in a while.
+ (loop
+ (loop repeat 128 do (cas)) ; 128 is arbitrary here
+ (sb!unix::%check-interrupts))
+ (loop (cas)))))
+ 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)
- ;; 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 got-it)
- `(let ((,lock ,spinlock)
- (,got-it nil))
- (unwind-protect
- (progn
- (setf ,got-it (get-spinlock ,lock))
- (locally ,@body))
- (when ,got-it
- (release-spinlock ,lock))))))
-
-;;;; mutexes
+ (declare (optimize (speed 3) (safety 0)))
+ ;; On x86 and x86-64 we can get away with no memory barriers, (see
+ ;; Linux kernel mailing list "spin_unlock optimization(i386)"
+ ;; thread, summary at
+ ;; http://kt.iserv.nl/kernel-traffic/kt19991220_47.html#1.
+ ;;
+ ;; If the compiler may reorder this with other instructions, insert
+ ;; compiler barrier here.
+ ;;
+ ;; FIXME: this does not work on SMP Pentium Pro and OOSTORE systems,
+ ;; neither on most non-x86 architectures (but we don't have threads
+ ;; on those).
+ (setf (spinlock-value spinlock) nil))
+\f
+
+;;;; Mutexes
#!+sb-doc
-(setf (sb!kernel:fdocumentation 'make-mutex 'function)
+(setf (fdocumentation 'make-mutex 'function)
"Create a mutex."
- (sb!kernel:fdocumentation 'mutex-name 'function)
- "The name of the mutex. Setfable."
- (sb!kernel:fdocumentation 'mutex-value 'function)
- "The value of the mutex. NIL if the mutex is free. Setfable.")
+ (fdocumentation 'mutex-name 'function)
+ "The name of the mutex. Setfable.")
#!+(and sb-thread (not sb-lutex))
(progn
- (declaim (inline mutex-value-address))
- (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 *current-thread*) (wait-p t))
+ (define-structure-slot-addressor mutex-state-address
+ :structure mutex
+ :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))
+
+(defun get-mutex (mutex &optional (new-owner *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"
- (declare (type mutex mutex) (optimize (speed 3)))
- (/show0 "Entering GET-MUTEX")
- (unless new-value
- (setq new-value *current-thread*))
+ "Acquire MUTEX for NEW-OWNER, which must be a thread or NIL. If
+NEW-OWNER is NIL, it defaults to the current thread. If WAITP is
+non-NIL and the mutex is in use, sleep until it is available.
+
+Note: using GET-MUTEX to assign a MUTEX to another thread then the
+current one is not recommended, and liable to be deprecated.
+
+GET-MUTEX is not interrupt safe. The correct way to call it is:
+
+ (WITHOUT-INTERRUPTS
+ ...
+ (ALLOW-WITH-INTERRUPTS (GET-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.
+
+It is recommended that you use WITH-MUTEX instead of calling GET-MUTEX
+directly."
+ (declare (type mutex mutex) (optimize (speed 3))
+ #!-sb-thread (ignore waitp))
+ (unless new-owner
+ (setq new-owner *current-thread*))
+ (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-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)
+ (setf (mutex-%owner mutex) new-owner)
#!+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*))
+ ;; 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.
+ ;;
+ ;; FIXME: This is definitely not interrupt safe: what happens if
+ ;; we get hit (1) during the lutex calls (ok, they may be safe,
+ ;; but has that been checked?) (2) after the lutex call, but
+ ;; before setting the mutex owner.
#!+sb-lutex
(when (zerop (with-lutex-address (lutex (mutex-lutex mutex))
- (if wait-p
- (%lutex-lock lutex)
+ (if waitp
+ (with-interrupts (%lutex-lock lutex))
(%lutex-trylock lutex))))
- (setf (mutex-value mutex) new-value))
+ (setf (mutex-%owner mutex) new-owner)
+ t)
#!-sb-lutex
- (let (old)
- (loop
- (unless
- (setf old (sb!vm::%instance-set-conditional mutex 2 nil
- new-value))
- (return t))
- (unless wait-p (return nil))
- (with-pinned-objects (mutex old)
- (futex-wait (mutex-value-address mutex)
- (sb!kernel:get-lisp-obj-address old)))))))
+ ;; This is a direct tranlation of the Mutex 2 algorithm from
+ ;; "Futexes are Tricky" by Ulrich Drepper.
+ (let ((old (sb!ext:compare-and-swap (mutex-state mutex)
+ +lock-free+
+ +lock-taken+)))
+ (unless (or (eql +lock-free+ old) (not waitp))
+ (tagbody
+ :retry
+ (when (or (eql +lock-contested+ old)
+ (not (eql +lock-free+
+ (sb!ext:compare-and-swap (mutex-state mutex)
+ +lock-taken+
+ +lock-contested+))))
+ ;; Wait on the contested lock.
+ (multiple-value-bind (to-sec to-usec) (decode-timeout nil)
+ (when (= 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))))
+ (signal-deadline))))
+ (setf old (sb!ext:compare-and-swap (mutex-state mutex)
+ +lock-free+
+ +lock-contested+))
+ ;; Did we get it?
+ (unless (eql +lock-free+ old)
+ (go :retry))))
+ (cond ((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))
+ t))
+ (waitp
+ (bug "Failed to acquire lock with WAITP."))))))
(defun release-mutex (mutex)
#!+sb-doc
"Release MUTEX by setting it to NIL. Wake up threads waiting for
-this mutex."
+this mutex.
+
+RELEASE-MUTEX is not interrupt safe: interrupts should be disabled
+around calls to it.
+
+Signals a WARNING if current thread is not the current owner of the
+mutex."
(declare (type mutex mutex))
- (/show0 "Entering RELEASE-MUTEX")
- (setf (mutex-value mutex) nil)
+ ;; 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 (eql self old-owner)
+ (warn "Releasing ~S, owned by another thread: ~S" mutex old-owner)
+ (setf (mutex-%owner 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)))
-
-;;;; waitqueues/condition variables
+ ;; 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))
+\f
+
+;;;; Waitqueues/condition variables
(defstruct (waitqueue (:constructor %make-waitqueue))
#!+sb-doc
(%make-waitqueue :name name))
#!+sb-doc
-(setf (sb!kernel:fdocumentation 'waitqueue-name 'function)
+(setf (fdocumentation 'waitqueue-name 'function)
"The name of the waitqueue. Setfable.")
#!+(and sb-thread (not sb-lutex))
-(progn
- (declaim (inline waitqueue-data-address))
- (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)))))
+(define-structure-slot-addressor waitqueue-data-address
+ :structure waitqueue
+ :slot data)
(defun condition-wait (queue mutex)
#!+sb-doc
(assert mutex)
#!-sb-thread (error "Not supported in unithread builds.")
#!+sb-thread
- (let ((value (mutex-value mutex)))
+ (let ((me *current-thread*))
+ (assert (eq me (mutex-%owner 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))
+ ;; Need to disable interrupts so that we don't miss setting the
+ ;; owner on our way out. (pthread_cond_wait handles the actual
+ ;; re-acquisition.)
+ (without-interrupts
+ (unwind-protect
+ (progn
+ (setf (mutex-%owner mutex) nil)
+ (with-lutex-address (queue-lutex-address (waitqueue-lutex queue))
+ (with-lutex-address (mutex-lutex-address (mutex-lutex mutex))
+ (with-local-interrupts
+ (%lutex-wait queue-lutex-address mutex-lutex-address)))))
+ (setf (mutex-%owner mutex) me)))
#!-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)
- (sb!kernel: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))))
+ ;; Need to disable interrupts so that we don't miss grabbing the
+ ;; mutex on our way out.
+ (without-interrupts
+ (unwind-protect
+ (let ((me *current-thread*))
+ ;; This setf becomes visible to other CPUS due to the
+ ;; usual memory barrier semantics of lock
+ ;; acquire/release.
+ (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. 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)
+ (allow-with-interrupts
+ (futex-wait (waitqueue-data-address queue)
+ (get-lisp-obj-address me)
+ ;; our way if saying "no
+ ;; timeout":
+ (or to-sec -1)
+ (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)))))
(defun condition-notify (queue &optional (n 1))
#!+sb-doc
- "Notify N threads waiting on QUEUE."
+ "Notify N threads waiting on QUEUE. The same mutex that is used in
+the correspoinding 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
#!+sb-doc
"Notify all threads waiting on QUEUE."
(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)))
+\f
-;;;; semaphores
+;;;; Semaphores
-(defstruct (semaphore (:constructor %make-semaphore))
+(defstruct (semaphore (:constructor %make-semaphore (name %count)))
#!+sb-doc
- "Semaphore type."
+ "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 simple-string))
- (count 0 :type (integer 0))
+ (%count 0 :type (integer 0))
+ (waitcount 0 :type (integer 0))
(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."
+ (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))
-
-(setf (sb!kernel:fdocumentation 'semaphore-name 'function)
- "The name of the semaphore. Setfable.")
+ "Create a semaphore with the supplied COUNT and NAME."
+ (%make-semaphore name count))
-(defun wait-on-semaphore (sem)
+(defun wait-on-semaphore (semaphore)
#!+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))
+ "Decrement the count of SEMAPHORE if the count would not be
+negative. Else blocks until the semaphore can be decremented."
+ ;; 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.)
+ (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
+ (incf (semaphore-waitcount semaphore))
+ (loop until (plusp (setf count (semaphore-%count semaphore)))
+ do (condition-wait (semaphore-queue semaphore)
+ (semaphore-mutex semaphore)))
+ (setf (semaphore-%count semaphore) (1- count)))
+ (decf (semaphore-waitcount semaphore)))))))
+
+(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))
+ (let ((waitcount (semaphore-waitcount semaphore))
+ (count (incf (semaphore-%count semaphore) n)))
+ (when (plusp waitcount)
+ (condition-notify (semaphore-queue semaphore) (min waitcount count))))))
+\f
+
+;;;; Job control, independent listeners
(defstruct session
(lock (make-mutex :name "session lock"))
(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*)
#!+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)
(when *session*
(%delete-thread-from-session thread *session*)))
#!+sb-lutex
- (when (thread-interruptions-lock thread)
+ (without-gcing
(/show0 "FREEING MUTEX LUTEX")
(with-lutex-address (lutex (mutex-lutex (thread-interruptions-lock thread)))
(%lutex-destroy lutex))))
(sb!impl::toplevel-repl nil)
(sb!int:flush-standard-output-streams))))))
(make-thread #'thread-repl))))
+\f
-;;;; the beef
+;;;; The beef
(defun make-thread (function &key name)
#!+sb-doc
;; 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)
- (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)
- (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::*step-out* nil)
+ ;; internal printer variables
+ (sb!impl::*previous-case* nil)
+ (sb!impl::*previous-readtable-case* nil)
+ (empty (vector))
+ (sb!impl::*merge-sort-temp-vector* empty)
+ (sb!impl::*zap-array-data-temp* empty)
+ (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*))
(format nil
"~~@<Terminate this thread (~A)~~@:>"
*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
+ (funcall real-function))))
+ ;; 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
- (sb!kernel:get-lisp-obj-address initial-function))))
- (when (zerop os-thread)
- (error "Can't create a new thread"))
- (wait-on-semaphore setup-sem)
- 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)))))
(define-condition join-thread-error (error)
((thread :reader join-thread-error-thread :initarg :thread))
(join-thread-error-thread c)))))
#!+sb-doc
-(setf (sb!kernel:fdocumentation 'join-thread-error-thread 'function)
+(setf (fdocumentation 'join-thread-error-thread 'function)
"The thread that we failed to join.")
(defun join-thread (thread &key (default nil defaultp))
"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))
+ (with-system-mutex ((thread-result-lock thread) :allow-with-interrupts t)
(cond ((car (thread-result thread))
- (values-list (cdr (thread-result thread))))
+ (return-from join-thread
+ (values-list (cdr (thread-result thread)))))
(defaultp
- default)
- (t
- (error 'join-thread-error :thread thread)))))
+ (return-from join-thread default))))
+ (error 'join-thread-error :thread thread))
(defun destroy-thread (thread)
#!+sb-doc
(interrupt-thread-error-thread c)))))
#!+sb-doc
-(setf (sb!kernel:fdocumentation 'interrupt-thread-error-thread 'function)
+(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 in C.
(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*)))))
+ ;; Resignalling after popping one works fine, because from the
+ ;; OS's point of view we have returned from the signal handler
+ ;; (thanks to arrange_return_to_lisp_function) so at least one
+ ;; more signal will be delivered.
+ (when (thread-interruptions *current-thread*)
+ (signal-interrupt-thread (thread-os-thread *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
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)
+ (with-interrupt-bindings
+ (with-interrupts (funcall function)))
#!+sb-thread
(if (eq thread *current-thread*)
- (funcall function)
+ (with-interrupt-bindings
+ (with-interrupts (funcall function)))
(let ((os-thread (thread-os-thread thread)))
(cond ((not os-thread)
(error 'interrupt-thread-error :thread thread))
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)
- (sb!kernel:make-lisp-obj tl-val))))
+(progn
+ (defun %thread-sap (thread)
+ (let ((thread-sap (alien-sap (extern-alien "all_threads" (* t))))
+ (target (thread-os-thread thread)))
+ (loop
+ (when (sap= thread-sap (int-sap 0)) (return nil))
+ (let ((os-thread (sap-ref-word thread-sap
+ (* sb!vm:n-word-bytes
+ sb!vm::thread-os-thread-slot))))
+ (when (= os-thread target) (return thread-sap))
+ (setf thread-sap
+ (sap-ref-sap thread-sap (* sb!vm:n-word-bytes
+ sb!vm::thread-next-slot)))))))
+
+ (defun %symbol-value-in-thread (symbol thread)
+ (tagbody
+ ;; Prevent the dead from dying completely while we look for the
+ ;; TLS area...
+ (with-all-threads-lock
+ (if (thread-alive-p thread)
+ (let* ((offset (* sb!vm:n-word-bytes
+ (sb!vm::symbol-tls-index symbol)))
+ (tl-val (sap-ref-word (%thread-sap thread) offset)))
+ (if (eql tl-val sb!vm::no-tls-value-marker-widetag)
+ (go :unbound)
+ (return-from %symbol-value-in-thread
+ (values (make-lisp-obj tl-val) t))))
+ (return-from %symbol-value-in-thread (values nil nil))))
+ :unbound
+ (error "Cannot read thread-local symbol value: ~S unbound in ~S"
+ symbol thread)))
+
+ (defun %set-symbol-value-in-thread (symbol thread value)
+ (tagbody
+ (with-pinned-objects (value)
+ ;; Prevent the dead from dying completely while we look for
+ ;; the TLS area...
+ (with-all-threads-lock
+ (if (thread-alive-p thread)
+ (let* ((offset (* sb!vm:n-word-bytes
+ (sb!vm::symbol-tls-index symbol)))
+ (sap (%thread-sap thread))
+ (tl-val (sap-ref-word sap offset)))
+ (if (eql tl-val sb!vm::no-tls-value-marker-widetag)
+ (go :unbound)
+ (setf (sap-ref-word sap offset)
+ (get-lisp-obj-address value)))
+ (return-from %set-symbol-value-in-thread (values value t)))
+ (return-from %set-symbol-value-in-thread (values nil nil)))))
+ :unbound
+ (error "Cannot set thread-local symbol value: ~S unbound in ~S"
+ symbol thread))))
(defun sb!vm::locked-symbol-global-value-add (symbol-name delta)
(sb!vm::locked-symbol-global-value-add symbol-name delta))
+\f
-;;; Stepping
+;;;; Stepping
(defun thread-stepping ()
- (sb!kernel:make-lisp-obj
+ (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)))
+ (get-lisp-obj-address value)))