(in-package "SB!THREAD")
+;;; Of the WITH-PINNED-OBJECTS in this file, not every single one is
+;;; necessary because threads are only supported with the conservative
+;;; gencgc and numbers on the stack (returned by GET-LISP-OBJ-ADDRESS)
+;;; are treated as references.
+
;;; set the doc here because in early-thread FDOCUMENTATION is not
;;; available, yet
#!+sb-doc
"Thread type. Do not rely on threads being structs as it may change
in future versions."
name
- %sap)
+ %alive-p
+ os-thread
+ interruptions
+ (interruptions-lock (make-mutex :name "thread interruptions lock")))
#!+sb-doc
(setf (sb!kernel:fdocumentation 'thread-name 'function)
))
thread)
-(defun thread-state (thread)
- (let ((state
- (sb!sys:sap-int
- (sb!sys:sap-ref-sap (thread-%sap thread)
- (* sb!vm::thread-state-slot
- sb!vm::n-word-bytes)))))
- (ecase state
- (#.(sb!vm:fixnumize 0) :starting)
- (#.(sb!vm:fixnumize 1) :running)
- (#.(sb!vm:fixnumize 2) :suspended)
- (#.(sb!vm:fixnumize 3) :dead))))
-
-(defun %set-thread-state (thread state)
- (setf (sb!sys:sap-ref-sap (thread-%sap thread)
- (* sb!vm::thread-state-slot
- sb!vm::n-word-bytes))
- (sb!sys:int-sap
- (ecase state
- (:starting #.(sb!vm:fixnumize 0))
- (:running #.(sb!vm:fixnumize 1))
- (:suspended #.(sb!vm:fixnumize 2))
- (:dead #.(sb!vm:fixnumize 3))))))
-
(defun thread-alive-p (thread)
#!+sb-doc
"Check if THREAD is running."
- (not (eq :dead (thread-state thread))))
+ (thread-%alive-p thread))
;; A thread is eligible for gc iff it has finished and there are no
;; more references to it. This list is supposed to keep a reference to
(declaim (inline current-thread-sap-id))
(defun current-thread-sap-id ()
- (sb!sys:sap-int
+ (sap-int
(sb!vm::current-thread-offset-sap sb!vm::thread-os-thread-slot)))
(defun init-initial-thread ()
(let ((initial-thread (%make-thread :name "initial thread"
- :%sap (current-thread-sap))))
+ :%alive-p t
+ :os-thread (current-thread-sap-id))))
(setq *current-thread* initial-thread)
;; Either *all-threads* is empty or it contains exactly one thread
;; in case we are in reinit since saving core with multiple
#!+sb-thread
(progn
+ ;; FIXME it would be good to define what a thread id is or isn't
+ ;; (our current assumption is that it's a fixnum). It so happens
+ ;; that on Linux it's a pid, but it might not be on posix thread
+ ;; implementations.
(define-alien-routine ("create_thread" %create-thread)
- system-area-pointer
- (lisp-fun-address unsigned-long))
+ unsigned-long (lisp-fun-address unsigned-long))
- (define-alien-routine reap-dead-thread void
- (thread-sap system-area-pointer))
+ (define-alien-routine "signal_interrupt_thread"
+ integer (os-thread unsigned-long))
+
+ (define-alien-routine "block_blockable_signals"
+ void)
(declaim (inline futex-wait futex-wake))
#!-sb-thread
(defun sb!vm::current-thread-offset-sap (n)
(declare (type (unsigned-byte 27) n))
- (sb!sys:sap-ref-sap (alien-sap (extern-alien "all_threads" (* t)))
+ (sap-ref-sap (alien-sap (extern-alien "all_threads" (* t)))
(* n sb!vm:n-word-bytes)))
;;;; spinlocks
-(defstruct spinlock
- #!+sb-doc
- "Spinlock type."
- (name nil :type (or null simple-string))
- (value 0))
-
(declaim (inline get-spinlock release-spinlock))
;;; The bare 2 here and below are offsets of the slots in the struct.
;;; There ought to be some better way to get these numbers
-(defun get-spinlock (spinlock new-value)
+(defun get-spinlock (spinlock)
(declare (optimize (speed 3) (safety 0))
#!-sb-thread
(ignore spinlock new-value))
;; store any value
#!+sb-thread
(loop until
- (eql (sb!vm::%instance-set-conditional spinlock 2 0 new-value) 0)))
+ (eql (sb!vm::%instance-set-conditional spinlock 2 0 1) 0)))
(defun release-spinlock (spinlock)
(declare (optimize (speed 3) (safety 0))
(defmacro with-spinlock ((spinlock) &body body)
(sb!int:with-unique-names (lock)
`(let ((,lock ,spinlock))
- (get-spinlock ,lock *current-thread*)
+ (get-spinlock ,lock)
(unwind-protect
(progn ,@body)
(release-spinlock ,lock)))))
;;;; mutexes
-(defstruct mutex
- #!+sb-doc
- "Mutex type."
- (name nil :type (or null simple-string))
- (value nil))
-
#!+sb-doc
(setf (sb!kernel:fdocumentation 'make-mutex 'function)
"Create a mutex."
(+ (sb!kernel:get-lisp-obj-address mutex)
(- (* 3 sb!vm:n-word-bytes) sb!vm:instance-pointer-lowtag))))
-(defun get-mutex (mutex &optional new-value (wait-p t))
+(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"
(declare (type mutex mutex) (optimize (speed 3)))
- (unless new-value (setf new-value *current-thread*))
+ (unless new-value
+ (setq new-value *current-thread*))
#!-sb-thread
(let ((old-value (mutex-value mutex)))
(when (and old-value wait-p)
(setf old (sb!vm::%instance-set-conditional mutex 2 nil new-value))
(return t))
(unless wait-p (return nil))
- (futex-wait (mutex-value-address mutex)
- (sb!kernel:get-lisp-obj-address old)))))
+ (with-pinned-objects (mutex old)
+ (futex-wait (mutex-value-address mutex)
+ (sb!kernel:get-lisp-obj-address old))))))
(defun release-mutex (mutex)
#!+sb-doc
;; this comment, it will change queue->data, and so
;; futex-wait returns immediately instead of sleeping.
;; Ergo, no lost wakeup
- (futex-wait (waitqueue-data-address queue)
- (sb!kernel:get-lisp-obj-address me)))
+ (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))))
-(defun condition-notify (queue)
+(defun condition-notify (queue &optional (n 1))
#!+sb-doc
- "Notify one of the threads waiting on QUEUE."
- #!-sb-thread (declare (ignore queue))
+ "Notify N threads waiting on QUEUE."
+ #!-sb-thread (declare (ignore queue n))
#!-sb-thread (error "Not supported in unithread builds.")
#!+sb-thread
+ (declare (type (and fixnum (integer 1)) n))
+ #!+sb-thread
(let ((me *current-thread*))
;; no problem if >1 thread notifies during the comment in
;; condition-wait: as long as the value in queue-data isn't the
;; XXX we should do something to ensure that the result of this setf
;; is visible to all CPUs
(setf (waitqueue-data queue) me)
- (futex-wake (waitqueue-data-address queue) 1)))
+ (with-pinned-objects (queue)
+ (futex-wake (waitqueue-data-address queue) n))))
(defun condition-broadcast (queue)
#!+sb-doc
"Notify all threads waiting on QUEUE."
- #!-sb-thread (declare (ignore queue))
- #!-sb-thread (error "Not supported in unithread builds.")
- #!+sb-thread
- (let ((me *current-thread*))
- (setf (waitqueue-data queue) me)
- (futex-wake (waitqueue-data-address queue) (ash 1 30))))
+ (condition-notify queue most-positive-fixnum))
+
+;;;; semaphores
+
+(defstruct (semaphore (:constructor %make-semaphore))
+ #!+sb-doc
+ "Semaphore type."
+ (name nil :type (or null simple-string))
+ (count 0 :type (integer 0))
+ (mutex (make-mutex))
+ (queue (make-waitqueue)))
+
+(defun make-semaphore (&key name (count 0))
+ #!+sb-doc
+ "Create a semaphore with the supplied COUNT."
+ (%make-semaphore :name name :count count))
+
+(setf (sb!kernel:fdocumentation 'semaphore-name 'function)
+ "The name of the semaphore. Setfable.")
+
+(defun wait-on-semaphore (sem)
+ #!+sb-doc
+ "Decrement the count of SEM if the count would not be negative. Else
+block until the semaphore can be decremented."
+ ;; a more direct implementation based directly on futexes should be
+ ;; possible
+ (with-mutex ((semaphore-mutex sem))
+ (loop until (> (semaphore-count sem) 0)
+ do (condition-wait (semaphore-queue sem) (semaphore-mutex sem))
+ finally (decf (semaphore-count sem)))))
+
+(defun signal-semaphore (sem &optional (n 1))
+ #!+sb-doc
+ "Increment the count of SEM by N. If there are threads waiting on
+this semaphore, then N of them is woken up."
+ (declare (type (and fixnum (integer 1)) n))
+ (with-mutex ((semaphore-mutex sem))
+ (when (= n (incf (semaphore-count sem) n))
+ (condition-notify (semaphore-queue sem) n))))
;;;; job control, independent listeners
#!-sb-thread
`(locally ,@body)
#!+sb-thread
- `(sb!sys:without-interrupts
+ `(without-interrupts
(with-mutex ((session-lock ,session))
,@body)))
(labels ((thread-repl ()
(sb!unix::unix-setsid)
(let* ((sb!impl::*stdin*
- (sb!sys:make-fd-stream in :input t :buffering :line
+ (make-fd-stream in :input t :buffering :line
:dual-channel-p t))
(sb!impl::*stdout*
- (sb!sys:make-fd-stream out :output t :buffering :line
+ (make-fd-stream out :output t :buffering :line
:dual-channel-p t))
(sb!impl::*stderr*
- (sb!sys:make-fd-stream err :output t :buffering :line
+ (make-fd-stream err :output t :buffering :line
:dual-channel-p t))
(sb!impl::*tty*
- (sb!sys:make-fd-stream err :input t :output t
+ (make-fd-stream err :input t :output t
:buffering :line
:dual-channel-p t))
(sb!impl::*descriptor-handlers* nil))
#!-sb-thread (error "Not supported in unithread builds.")
#!+sb-thread
(let* ((thread (%make-thread :name name))
- (setup-p nil)
+ (setup-sem (make-semaphore :name "Thread setup semaphore"))
(real-function (coerce function 'function))
- (thread-sap
- (%create-thread
- (sb!kernel:get-lisp-obj-address
- (lambda ()
- ;; FIXME: use semaphores?
- (loop until setup-p)
- ;; in time we'll move some of the binding presently done in C
- ;; here too
- (let ((*current-thread* thread)
- (sb!kernel::*restart-clusters* nil)
- (sb!kernel::*handler-clusters* nil)
- (sb!kernel::*condition-restarts* nil)
- (sb!impl::*descriptor-handlers* nil)) ; serve-event
- ;; can't use handling-end-of-the-world, because that flushes
- ;; output streams, and we don't necessarily have any (or we
- ;; could be sharing them)
- (unwind-protect
- (catch 'sb!impl::toplevel-catcher
- (catch 'sb!impl::%end-of-the-world
- (with-simple-restart
- (terminate-thread
- (format nil "~~@<Terminate this thread (~A)~~@:>"
- *current-thread*))
- ;; now that most things have a chance to work
- ;; properly without messing up other threads, it's
- ;; time to enable signals
+ (initial-function
+ (lambda ()
+ ;; in time we'll move some of the binding presently done in C
+ ;; here too
+ (let ((*current-thread* thread)
+ (sb!kernel::*restart-clusters* nil)
+ (sb!kernel::*handler-clusters* nil)
+ (sb!kernel::*condition-restarts* nil)
+ (sb!impl::*descriptor-handlers* nil)) ; serve-event
+ (setf (thread-os-thread thread) (current-thread-sap-id))
+ (with-mutex (*all-threads-lock*)
+ (push thread *all-threads*))
+ (with-session-lock (*session*)
+ (push thread (session-threads *session*)))
+ (setf (thread-%alive-p thread) t)
+ (signal-semaphore setup-sem)
+ ;; can't use handling-end-of-the-world, because that flushes
+ ;; output streams, and we don't necessarily have any (or we
+ ;; could be sharing them)
+ (catch 'sb!impl::toplevel-catcher
+ (catch 'sb!impl::%end-of-the-world
+ (with-simple-restart
+ (terminate-thread
+ (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)
- (unwind-protect
- (funcall real-function)
- ;; we're going down, can't handle
- ;; interrupts sanely anymore
- (sb!unix::block-blockable-signals)))))
- ;; mark the thread dead, so that the gc does not
- ;; wait for it to handle sig-stop-for-gc
- (%set-thread-state thread :dead)
- ;; and remove what can be the last reference to
- ;; the thread object
- (handle-thread-exit thread)
- 0))
- (values))))))
- (when (sb!sys:sap= thread-sap (sb!sys:int-sap 0))
- (error "Can't create a new thread"))
- (setf (thread-%sap thread) thread-sap)
- (with-mutex (*all-threads-lock*)
- (push thread *all-threads*))
- (with-session-lock (*session*)
- (push thread (session-threads *session*)))
- (setq setup-p t)
- (sb!impl::finalize thread (lambda () (reap-dead-thread thread-sap)))
- thread))
+ (funcall real-function))
+ ;; we're going down, can't handle
+ ;; interrupts sanely anymore
+ (let ((sb!impl::*gc-inhibit* t))
+ (block-blockable-signals)
+ (setf (thread-%alive-p thread) nil)
+ (setf (thread-os-thread thread) nil)
+ ;; and remove what can be the last
+ ;; reference to this thread
+ (handle-thread-exit thread)))))))
+ (values))))
+ ;; 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))))
(defun destroy-thread (thread)
#!+sb-doc
(terminate-thread thread))
(define-condition interrupt-thread-error (error)
- ((thread :reader interrupt-thread-error-thread :initarg :thread)
- (errno :reader interrupt-thread-error-errno :initarg :errno))
+ ((thread :reader interrupt-thread-error-thread :initarg :thread))
#!+sb-doc
(:documentation "Interrupting thread failed.")
(:report (lambda (c s)
- (format s "interrupt thread ~A failed (~A: ~A)"
- (interrupt-thread-error-thread c)
- (interrupt-thread-error-errno c)
- (strerror (interrupt-thread-error-errno c))))))
+ (format s "Interrupt thread failed: thread ~A has exited."
+ (interrupt-thread-error-thread c)))))
#!+sb-doc
(setf (sb!kernel:fdocumentation 'interrupt-thread-error-thread 'function)
- "The thread that was not interrupted."
- (sb!kernel:fdocumentation 'interrupt-thread-error-errno 'function)
- "The reason why the interruption failed.")
-
+ "The thread that was not interrupted.")
+
+(defmacro with-interruptions-lock ((thread) &body body)
+ `(without-interrupts
+ (with-mutex ((thread-interruptions-lock ,thread))
+ ,@body)))
+
+;; Called from the signal handler.
+(defun run-interruption ()
+ (in-interruption ()
+ (let ((interruption (with-interruptions-lock (*current-thread*)
+ (pop (thread-interruptions *current-thread*)))))
+ (with-interrupts
+ (funcall interruption)))))
+
+;; The order of interrupt execution is peculiar. If thread A
+;; interrupts thread B with I1, I2 and B for some reason receives I1
+;; when FUN2 is already on the list, then it is FUN2 that gets to run
+;; first. But when FUN2 is run SIG_INTERRUPT_THREAD is enabled again
+;; and I2 hits pretty soon in FUN2 and run FUN1. This is of course
+;; just one scenario, and the order of thread interrupt execution is
+;; undefined.
(defun interrupt-thread (thread function)
#!+sb-doc
"Interrupt the live THREAD and make it run FUNCTION. A moderate
-degree of care is expected for use of interrupt-thread, due to its
+degree of care is expected for use of INTERRUPT-THREAD, due to its
nature: if you interrupt a thread that was holding important locks
then do something that turns out to need those locks, you probably
won't like the effect."
#!-sb-thread
(funcall function)
#!+sb-thread
- (let ((function (coerce function 'function)))
- (multiple-value-bind (res err)
- (sb!unix::syscall ("interrupt_thread"
- system-area-pointer sb!alien:unsigned-long)
- thread
- (thread-%sap thread)
- (sb!kernel:get-lisp-obj-address function))
- (unless res
- (error 'interrupt-thread-error :thread thread :errno err)))))
+ (if (eq thread *current-thread*)
+ (funcall function)
+ (let ((os-thread (thread-os-thread thread)))
+ (cond ((not os-thread)
+ (error 'interrupt-thread-error :thread thread))
+ (t
+ (with-interruptions-lock (thread)
+ (push function (thread-interruptions thread)))
+ (when (minusp (signal-interrupt-thread os-thread))
+ (error 'interrupt-thread-error :thread thread)))))))
(defun terminate-thread (thread)
#!+sb-doc
;;; with an SBCL developer first, or are doing something that you
;;; should probably discuss with a professional psychiatrist first
#!+sb-thread
-(defun symbol-value-in-thread (symbol thread)
- (let ((thread-sap (thread-%sap thread)))
- (let* ((index (sb!vm::symbol-tls-index symbol))
- (tl-val (sb!sys:sap-ref-word thread-sap
- (* sb!vm:n-word-bytes index))))
- (if (eql tl-val sb!vm::unbound-marker-widetag)
- (sb!vm::symbol-global-value symbol)
- (sb!kernel:make-lisp-obj tl-val)))))
+(defun thread-sap-for-id (id)
+ (let ((thread-sap (alien-sap (extern-alien "all_threads" (* t)))))
+ (loop
+ (when (sap= thread-sap (int-sap 0)) (return nil))
+ (let ((os-thread (sap-ref-word thread-sap
+ (* sb!vm:n-word-bytes
+ sb!vm::thread-os-thread-slot))))
+ (when (= os-thread id) (return thread-sap))
+ (setf thread-sap
+ (sap-ref-sap thread-sap (* sb!vm:n-word-bytes
+ sb!vm::thread-next-slot)))))))
+
+#!+sb-thread
+(defun symbol-value-in-thread (symbol thread-sap)
+ (let* ((index (sb!vm::symbol-tls-index symbol))
+ (tl-val (sap-ref-word thread-sap
+ (* sb!vm:n-word-bytes index))))
+ (if (eql tl-val sb!vm::no-tls-value-marker-widetag)
+ (sb!vm::symbol-global-value symbol)
+ (sb!kernel:make-lisp-obj tl-val))))
projects / sbcl.git / blobdiff