unsigned-long
(lisp-fun-address unsigned-long))
-(define-alien-routine "signal_thread_to_dequeue"
- unsigned-int
- (thread-id unsigned-long))
-
(define-alien-routine reap-dead-threads void)
(defvar *session* nil)
(defun get-spinlock (lock offset new-value)
(declare (optimize (speed 3) (safety 0)))
+ ;; %instance-set-conditional can test for 0 (which is a fixnum) and
+ ;; store any value
(loop until
- (eql (sb!vm::%instance-set-conditional lock offset 0 new-value) 0)))
+ (eql (sb!vm::%instance-set-conditional lock offset 0 new-value) 0)))
-;; this should do nothing if we didn't own the lock, so safe to use in
-;; unwind-protect cleanups when lock acquisition failed for some reason
-(defun release-spinlock (lock offset our-value)
+(defun release-spinlock (lock offset)
(declare (optimize (speed 3) (safety 0)))
- (sb!vm::%instance-set-conditional lock offset our-value 0))
+ ;; %instance-set-conditional cannot compare arbitrary objects
+ ;; meaningfully, so
+ ;; (sb!vm::%instance-set-conditional lock offset our-value 0)
+ ;; does not work for bignum thread ids.
+ (sb!vm::%instance-set lock offset 0))
(defmacro with-spinlock ((queue) &body body)
(with-unique-names (pid)
(progn
(get-spinlock ,queue 2 ,pid)
,@body)
- (release-spinlock ,queue 2 ,pid)))))
+ (release-spinlock ,queue 2)))))
;;;; the higher-level locking operations are based on waitqueues
(+ (sb!kernel:get-lisp-obj-address lock)
(- (* 5 sb!vm:n-word-bytes) sb!vm:instance-pointer-lowtag))))
-(sb!alien:define-alien-routine "block_sigcont" void)
-(sb!alien:define-alien-routine "unblock_sigcont_and_sleep" void)
-
(declaim (inline futex-wait futex-wake))
(sb!alien:define-alien-routine
"futex_wait" int (word unsigned-long) (old-value unsigned-long))
;; 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)
- (sb!sys:enable-interrupt sb!unix:sigint :ignore)
(catch 'sb!impl::%end-of-the-world
(with-simple-restart
- (destroy-thread
- (format nil "~~@<Destroy this thread (~A)~~@:>"
+ (terminate-thread
+ (format nil "~~@<Terminate this thread (~A)~~@:>"
(current-thread-id)))
+ ;; 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)
(funcall real-function))
0))
(values))))))
(pushnew tid (session-threads *session*)))
tid))
-;;; Really, you don't want to use these: they'll get into trouble with
-;;; garbage collection. Use a lock or a waitqueue instead
-(defun suspend-thread (thread-id)
- (sb!unix:unix-kill thread-id sb!unix:sigstop))
-(defun resume-thread (thread-id)
- (sb!unix:unix-kill thread-id sb!unix:sigcont))
-;;; Note warning about cleanup forms
(defun destroy-thread (thread-id)
- "Destroy the thread identified by THREAD-ID abruptly, without running cleanup forms"
- (sb!unix:unix-kill thread-id sb!unix:sigterm)
- ;; may have been stopped for some reason, so now wake it up to
- ;; deliver the TERM
- (sb!unix:unix-kill thread-id sb!unix:sigcont))
-
-
-
+ "Deprecated. Soon to be removed or reimplemented using pthread_cancel."
+ (terminate-thread thread-id))
;;; a moderate degree of care is expected for use of interrupt-thread,
;;; due to its nature: if you interrupt a thread that was holding
(defun interrupt-thread (thread function)
"Interrupt THREAD and make it run FUNCTION."
(let ((function (coerce function 'function)))
- (sb!sys:with-pinned-objects
- (function)
- (multiple-value-bind (res err)
- (sb!unix::syscall ("interrupt_thread"
- sb!alien:unsigned-long sb!alien:unsigned-long)
- thread
- thread
- (sb!kernel:get-lisp-obj-address function))
- (unless res
- (error 'interrupt-thread-error :thread thread :errno err))))))
+ (multiple-value-bind (res err)
+ (sb!unix::syscall ("interrupt_thread"
+ sb!alien:unsigned-long sb!alien:unsigned-long)
+ thread
+ thread
+ (sb!kernel:get-lisp-obj-address function))
+ (unless res
+ (error 'interrupt-thread-error :thread thread :errno err)))))
(defun terminate-thread (thread-id)
(declaim (inline current-thread-id))
(defun current-thread-id ()
- (logand
- (sb!sys:sap-int
- (sb!vm::current-thread-offset-sap sb!vm::thread-pid-slot))
- ;; KLUDGE pids are 16 bit really. Avoid boxing the return value
- (1- (ash 1 16))))
+ (sb!sys:sap-int
+ (sb!vm::current-thread-offset-sap sb!vm::thread-os-thread-slot)))
;;;; iterate over the in-memory threads
(let ((thread (alien-sap (extern-alien "all_threads" (* t)))))
(loop
(when (sb!sys:sap= thread (sb!sys:int-sap 0)) (return nil))
+ ;; FIXME: 32/64 bit
(let ((pid (sb!sys:sap-ref-32 thread (* sb!vm:n-word-bytes
- sb!vm::thread-pid-slot))))
+ sb!vm::thread-os-thread-slot))))
(when (= pid id) (return thread))
(setf thread (sb!sys:sap-ref-sap thread (* sb!vm:n-word-bytes
sb!vm::thread-next-slot)))))))
;;;; job control, independent listeners
(defstruct session
- (lock (make-mutex))
+ (lock (make-mutex :name "session lock"))
(threads nil)
(interactive-threads nil)
(interactive-threads-queue (make-waitqueue)))
(call-with-new-session (function ,fb-name)))))
;;; Remove thread id TID from its session, if it has one. This is
-;;; called from C reap_dead_threads() so is run in the context of
-;;; whichever thread called that (usually after a GC), which may not have
-;;; any meaningful parent/child/sibling relationship with the dead thread
+;;; called from C mark_thread_dead().
(defun handle-thread-exit (tid)
- (let ((session (symbol-value-in-thread '*session* tid)))
- (and session (%delete-thread-from-session tid session))))
-
+ (when *session*
+ (%delete-thread-from-session tid *session*)))
+
(defun terminate-session ()
"Kill all threads in session except for this one. Does nothing if current
thread is not the foreground thread"
(reap-dead-threads)
+ ;; FIXME: threads created in other threads may escape termination
(let* ((tid (current-thread-id))
(to-kill
(with-mutex ((session-lock *session*))
;; do the kill after dropping the mutex; unwind forms in dying
;; threads may want to do session things
(dolist (p to-kill)
- (unless (eql p tid) (terminate-thread p)))))
+ (unless (eql p tid)
+ ;; terminate the thread but don't be surprised if it has
+ ;; exited in the meantime
+ (handler-case (terminate-thread p)
+ (interrupt-thread-error ()))))))
;;; called from top of invoke-debugger
(defun debugger-wait-until-foreground-thread (stream)
(when (eql (car int-t) tid)
(unless was-foreground
(format *query-io* "Resuming thread ~A~%" tid))
- (sb!sys:enable-interrupt sb!unix:sigint #'sb!unix::sigint-handler)
(return-from get-foreground t))
(setf was-foreground nil)
(unless (member tid int-t)
(let ((tid (current-thread-id)))
(setf (session-interactive-threads *session*)
(delete tid (session-interactive-threads *session*)))
- (sb!sys:enable-interrupt sb!unix:sigint :ignore)
(when next
(setf (session-interactive-threads *session*)
(list* next
(delete next (session-interactive-threads *session*)))))
(condition-broadcast (session-interactive-threads-queue *session*)))))
+(defun foreground-thread ()
+ (car (session-interactive-threads *session*)))
+
(defun make-listener-thread (tty-name)
(assert (probe-file tty-name))
(let* ((in (sb!unix:unix-open (namestring tty-name) sb!unix:o_rdwr #o666))
(sb!sys:make-fd-stream err :input t :output t :buffering :line :dual-channel-p t))
(sb!impl::*descriptor-handlers* nil))
(with-new-session ()
- (sb!sys:enable-interrupt sb!unix:sigint #'sb!unix::sigint-handler)
(unwind-protect
(sb!impl::toplevel-repl nil)
(sb!int:flush-standard-output-streams))))))
projects / sbcl.git / blobdiff