(#.(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."
system-area-pointer
(lisp-fun-address unsigned-long))
+ (define-alien-routine "block_blockable_signals"
+ void)
+
(define-alien-routine reap-dead-thread void
(thread-sap system-area-pointer))
;; 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)))
+ (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
(defun release-foreground (&optional next)
#!+sb-doc
"Background this thread. If NEXT is supplied, arrange for it to
-have the foreground next"
+have the foreground next."
#!-sb-thread (declare (ignore next))
#!-sb-thread nil
#!+sb-thread
(with-session-lock (*session*)
- (setf (session-interactive-threads *session*)
- (delete *current-thread* (session-interactive-threads *session*)))
+ (when (rest (session-interactive-threads *session*))
+ (setf (session-interactive-threads *session*)
+ (delete *current-thread* (session-interactive-threads *session*))))
(when next
(setf (session-interactive-threads *session*)
(list* next
#!-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
- (sb!impl::*available-buffers* nil)) ;for fd-stream
- ;; 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
- (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))))))
+ ;; don't let the child inherit *CURRENT-THREAD* because that
+ ;; can prevent gc'ing this thread while the child runs
+ (let ((*current-thread* nil))
+ (%create-thread
+ (sb!kernel:get-lisp-obj-address
+ (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
+ (wait-on-semaphore setup-sem)
+ ;; can't use handling-end-of-the-world, because that flushes
+ ;; output streams, and we don't necessarily have any (or we
+ ;; could be sharing them)
+ (unwind-protect
+ (catch 'sb!impl::toplevel-catcher
+ (catch 'sb!impl::%end-of-the-world
+ (with-simple-restart
+ (terminate-thread
+ (format nil
+ "~~@<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
+ (sb!unix::reset-signal-mask)
+ (unwind-protect
+ (funcall real-function)
+ ;; we're going down, can't handle
+ ;; interrupts sanely anymore
+ (let ((sb!impl::*gc-inhibit* t))
+ (block-blockable-signals)
+ ;; and remove what can be the last
+ ;; reference to this thread
+ (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)
(push thread *all-threads*))
(with-session-lock (*session*)
(push thread (session-threads *session*)))
- (setq setup-p t)
+ (signal-semaphore setup-sem)
(sb!impl::finalize thread (lambda () (reap-dead-thread thread-sap)))
thread))
#!-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 ((function (coerce function 'function)))
+ (multiple-value-bind (res err)
+ ;; protect against gcing just when the ub32 address is
+ ;; just ready to be passed to C
+ (sb!sys::with-pinned-objects (function)
+ (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))))))
(defun terminate-thread (thread)
#!+sb-doc
(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)
+ (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