+#!+sb-futex
+(defun condition-notify/futex (queue)
+ "Notify one of the processes waiting on QUEUE."
+ (let ((me (current-thread-id)))
+ ;; no problem if >1 thread notifies during the comment in
+ ;; condition-wait: as long as the value in queue-data isn't the
+ ;; waiting thread's id, it matters not what it is
+ ;; 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)))
+
+#!+sb-futex
+(defun condition-broadcast/futex (queue)
+ (let ((me (current-thread-id)))
+ (setf (waitqueue-data queue) me)
+ (futex-wake (waitqueue-data-address queue) (ash 1 30))))
+
+(defun condition-broadcast (queue)
+ "Notify all of the processes waiting on QUEUE."
+ (with-spinlock (queue)
+ (map nil #'signal-thread-to-dequeue (waitqueue-data queue))))
+
+;;; Futexes may be available at compile time but not runtime, so we
+;;; default to not using them unless os_init says they're available
+(defun maybe-install-futex-functions ()
+ #!+sb-futex
+ (unless (zerop (extern-alien "linux_supports_futex" int))
+ (setf (fdefinition 'get-mutex) #'get-mutex/futex
+ (fdefinition 'release-mutex) #'release-mutex/futex
+ (fdefinition 'condition-wait) #'condition-wait/futex
+ (fdefinition 'condition-broadcast) #'condition-broadcast/futex
+ (fdefinition 'condition-notify) #'condition-notify/futex)
+ t))
+
+(defun make-thread (function)
+ (let* ((real-function (coerce function 'function))
+ (tid
+ (%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 ((sb!kernel::*restart-clusters* 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)
+ (sb!sys:enable-interrupt sb!unix:sigint :ignore)
+ (sb!unix:unix-exit
+ (catch 'sb!impl::%end-of-the-world
+ (with-simple-restart
+ (destroy-thread
+ (format nil "~~@<Destroy this thread (~A)~~@:>"
+ (current-thread-id)))
+ (funcall real-function))
+ 0))))))))
+ (with-mutex ((session-lock *session*))
+ (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))
+
+
+
+
+;;; 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. Used with thought
+;;; though, it's a good deal gentler than the last-resort functions above
+
+(defun interrupt-thread (thread function)
+ "Interrupt THREAD and make it run FUNCTION. "
+ (sb!unix::syscall* ("interrupt_thread"
+ sb!alien:unsigned-long sb!alien:unsigned-long)
+ thread
+ thread (sb!kernel:get-lisp-obj-address
+ (coerce function 'function))))
+(defun terminate-thread (thread-id)
+ "Terminate the thread identified by THREAD-ID, by causing it to run
+SB-EXT:QUIT - the usual cleanup forms will be evaluated"
+ (interrupt-thread thread-id 'sb!ext:quit))
+
+(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))))
+
+;;;; iterate over the in-memory threads
+
+(defun mapcar-threads (function)
+ "Call FUNCTION once for each known thread, giving it the thread structure as argument"
+ (let ((function (coerce function 'function)))
+ (loop for thread = (alien-sap (extern-alien "all_threads" (* t)))
+ then (sb!sys:sap-ref-sap thread (* 4 sb!vm::thread-next-slot))
+ until (sb!sys:sap= thread (sb!sys:int-sap 0))
+ collect (funcall function thread))))
+
+;;;; job control, independent listeners
+
+(defstruct session
+ (lock (make-mutex))
+ (threads nil)
+ (interactive-threads nil)
+ (interactive-threads-queue (make-waitqueue)))
+
+(defun new-session ()
+ (let ((tid (current-thread-id)))
+ (make-session :threads (list tid)
+ :interactive-threads (list tid))))
+
+(defun init-job-control ()
+ (setf *session* (new-session)))
+
+(defun %delete-thread-from-session (tid)
+ (with-mutex ((session-lock *session*))
+ (setf (session-threads *session*)
+ (delete tid (session-threads *session*))
+ (session-interactive-threads *session*)
+ (delete tid (session-interactive-threads *session*)))))
+
+(defun call-with-new-session (fn)
+ (%delete-thread-from-session (current-thread-id))
+ (let ((*session* (new-session))) (funcall fn)))
+
+(defmacro with-new-session (args &body forms)
+ (declare (ignore args)) ;for extensibility
+ (sb!int:with-unique-names (fb-name)
+ `(labels ((,fb-name () ,@forms))
+ (call-with-new-session (function ,fb-name)))))
+
+;;; this is called from a C signal handler: some signals may be masked
+(defun handle-thread-exit (tid)
+ "Remove thread id TID from the session, if it's there"
+ (%delete-thread-from-session tid))
+
+(defun terminate-session ()
+ "Kill all threads in session exept for this one. Does nothing if current
+thread is not the foreground thread"
+ (let* ((tid (current-thread-id))
+ (to-kill
+ (with-mutex ((session-lock *session*))
+ (and (eql tid (car (session-interactive-threads *session*)))
+ (session-threads *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)))))
+
+;;; called from top of invoke-debugger
+(defun debugger-wait-until-foreground-thread (stream)
+ "Returns T if thread had been running in background, NIL if it was
+interactive."
+ (prog1
+ (with-mutex ((session-lock *session*))
+ (not (member (current-thread-id)
+ (session-interactive-threads *session*))))
+ (get-foreground)))