(define-alien-routine reap-dead-thread void
(thread-sap system-area-pointer))
-(defvar *session* nil)
-
;;;; queues, locks
;; spinlocks use 0 as "free" value: higher-level locks use NIL
(setf (waitqueue-data queue) me)
(futex-wake (waitqueue-data-address queue) (ash 1 30))))
-(defun make-thread (function &key name)
- ;; ;; don't let them interrupt us because the child is waiting for setup-p
- ;; (sb!sys:without-interrupts
- (let* ((thread (%make-thread :name name))
- (setup-p nil)
- (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))))))
- (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-mutex ((session-lock *session*))
- (push thread (session-threads *session*)))
- (setq setup-p t)
- (sb!impl::finalize thread (lambda () (reap-dead-thread thread-sap)))
- thread))
-
-(defun destroy-thread (thread)
- "Deprecated. Soon to be removed or reimplemented using pthread_cancel."
- (terminate-thread thread))
-
-;;; 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.
-
-(define-condition interrupt-thread-error (error)
- ((thread :reader interrupt-thread-error-thread :initarg :thread)
- (errno :reader interrupt-thread-error-errno :initarg :errno))
- (: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))))))
-
-(defun interrupt-thread (thread function)
- "Interrupt THREAD and make it run FUNCTION."
- (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)))))
-
-(defun terminate-thread (thread)
- "Terminate the thread identified by THREAD, by causing it to run
-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
-;;; 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
-(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)))))
-
;;;; job control, independent listeners
(defstruct session
(interactive-threads nil)
(interactive-threads-queue (make-waitqueue)))
+(defvar *session* nil)
+
+;;; the debugger itself tries to acquire the session lock, don't let
+;;; funny situations (like getting a sigint while holding the session
+;;; lock) occur
+(defmacro with-session-lock ((session) &body body)
+ `(sb!sys:without-interrupts
+ (with-mutex ((session-lock ,session))
+ ,@body)))
+
(defun new-session ()
(make-session :threads (list *current-thread*)
:interactive-threads (list *current-thread*)))
(setf *session* (new-session)))
(defun %delete-thread-from-session (thread session)
- (with-mutex ((session-lock session))
+ (with-session-lock (session)
(setf (session-threads session)
(delete thread (session-threads session))
(session-interactive-threads session)
thread is not the foreground thread"
;; FIXME: threads created in other threads may escape termination
(let ((to-kill
- (with-mutex ((session-lock *session*))
+ (with-session-lock (*session*)
(and (eq *current-thread*
(car (session-interactive-threads *session*)))
(session-threads *session*)))))
interactive."
(declare (ignore stream))
(prog1
- (with-mutex ((session-lock *session*))
+ (with-session-lock (*session*)
(not (member *current-thread*
(session-interactive-threads *session*))))
(get-foreground)))
(defun get-foreground ()
(let ((was-foreground t))
(loop
- (with-mutex ((session-lock *session*))
+ (with-session-lock (*session*)
(let ((int-t (session-interactive-threads *session*)))
(when (eq (car int-t) *current-thread*)
(unless was-foreground
(defun release-foreground (&optional next)
"Background this thread. If NEXT is supplied, arrange for it to
have the foreground next"
- (with-mutex ((session-lock *session*))
+ (with-session-lock (*session*)
(setf (session-interactive-threads *session*)
(delete *current-thread* (session-interactive-threads *session*)))
(when next
(sb!impl::toplevel-repl nil)
(sb!int:flush-standard-output-streams))))))
(make-thread #'thread-repl))))
+
+;;;; the beef
+
+(defun make-thread (function &key name)
+ (let* ((thread (%make-thread :name name))
+ (setup-p nil)
+ (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))))))
+ (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))
+
+(defun destroy-thread (thread)
+ "Deprecated. Soon to be removed or reimplemented using pthread_cancel."
+ (terminate-thread thread))
+
+;;; 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.
+
+(define-condition interrupt-thread-error (error)
+ ((thread :reader interrupt-thread-error-thread :initarg :thread)
+ (errno :reader interrupt-thread-error-errno :initarg :errno))
+ (: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))))))
+
+(defun interrupt-thread (thread function)
+ "Interrupt THREAD and make it run FUNCTION."
+ (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)))))
+
+(defun terminate-thread (thread)
+ "Terminate the thread identified by THREAD, by causing it to run
+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
+;;; 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
+(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)))))
projects / sbcl.git / commitdiff