+;;;; the beef
+
+(defun make-thread (function &key name)
+ #!+sb-doc
+ "Create a new thread of NAME that runs FUNCTION. When the function
+returns the thread exits. The return values of FUNCTION are kept
+around and can be retrieved by JOIN-THREAD."
+ #!-sb-thread (declare (ignore function name))
+ #!-sb-thread (error "Not supported in unithread builds.")
+ #!+sb-thread
+ (let* ((thread (%make-thread :name name))
+ (setup-sem (make-semaphore :name "Thread setup semaphore"))
+ (real-function (coerce function 'function))
+ (initial-function
+ (lambda ()
+ ;; In time we'll move some of the binding presently done in C
+ ;; here too.
+ ;;
+ ;; KLUDGE: Here we have a magic list of variables that are
+ ;; not thread-safe for one reason or another. As people
+ ;; report problems with the thread safety of certain
+ ;; variables, (e.g. "*print-case* in multiple threads
+ ;; broken", sbcl-devel 2006-07-14), we add a few more
+ ;; bindings here. The Right Thing is probably some variant
+ ;; of Allegro's *cl-default-special-bindings*, as that is at
+ ;; least accessible to users to secure their own libraries.
+ ;; --njf, 2006-07-15
+ (let ((*current-thread* thread)
+ (*restart-clusters* nil)
+ (*handler-clusters* nil)
+ (*condition-restarts* nil)
+ (sb!impl::*deadline* nil)
+ (sb!impl::*step-out* nil)
+ ;; internal printer variables
+ (sb!impl::*previous-case* nil)
+ (sb!impl::*previous-readtable-case* nil)
+ (empty (vector))
+ (sb!impl::*merge-sort-temp-vector* empty)
+ (sb!impl::*zap-array-data-temp* empty)
+ (sb!impl::*internal-symbol-output-fun* nil)
+ (sb!impl::*descriptor-handlers* nil)) ; serve-event
+ (setf (thread-os-thread thread) (current-thread-sap-id))
+ (with-mutex ((thread-result-lock thread))
+ (with-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)
+ (setf (thread-result thread)
+ (cons t
+ (multiple-value-list
+ (funcall real-function)))))
+ (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
+ (get-lisp-obj-address initial-function))))
+ (when (zerop os-thread)
+ (error "Can't create a new thread"))
+ (wait-on-semaphore setup-sem)
+ thread))))
+
+(define-condition join-thread-error (error)
+ ((thread :reader join-thread-error-thread :initarg :thread))
+ #!+sb-doc
+ (:documentation "Joining thread failed.")
+ (:report (lambda (c s)
+ (format s "Joining thread failed: thread ~A ~
+ has not returned normally."
+ (join-thread-error-thread c)))))
+
+#!+sb-doc
+(setf (fdocumentation 'join-thread-error-thread 'function)
+ "The thread that we failed to join.")
+
+(defun join-thread (thread &key (default nil defaultp))
+ #!+sb-doc
+ "Suspend current thread until THREAD exits. Returns the result
+values of the thread function. If the thread does not exit normally,
+return DEFAULT if given or else signal JOIN-THREAD-ERROR."
+ (with-mutex ((thread-result-lock thread))
+ (cond ((car (thread-result thread))
+ (values-list (cdr (thread-result thread))))
+ (defaultp
+ default)
+ (t
+ (error 'join-thread-error :thread thread)))))
+
+(defun destroy-thread (thread)
+ #!+sb-doc
+ "Deprecated. Same as TERMINATE-THREAD."
+ (terminate-thread thread))
+
+(define-condition interrupt-thread-error (error)
+ ((thread :reader interrupt-thread-error-thread :initarg :thread))
+ #!+sb-doc
+ (:documentation "Interrupting thread failed.")
+ (:report (lambda (c s)
+ (format s "Interrupt thread failed: thread ~A has exited."
+ (interrupt-thread-error-thread c)))))
+
+#!+sb-doc
+(setf (fdocumentation 'interrupt-thread-error-thread 'function)
+ "The thread that was not interrupted.")
+
+(defmacro with-interruptions-lock ((thread) &body body)
+ `(call-with-system-mutex (lambda () ,@body) (thread-interruptions-lock ,thread)))
+
+;; Called from the signal handler in C.
+(defun run-interruption ()
+ (in-interruption ()
+ (loop
+ (let ((interruption (with-interruptions-lock (*current-thread*)
+ (pop (thread-interruptions *current-thread*)))))
+ (if interruption
+ (with-interrupts
+ (funcall interruption))
+ (return))))))
+
+;; 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
+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 (declare (ignore thread))
+ #!-sb-thread
+ (with-interrupt-bindings
+ (with-interrupts (funcall function)))
+ #!+sb-thread
+ (if (eq thread *current-thread*)
+ (with-interrupt-bindings
+ (with-interrupts (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
+ "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
+#!+sb-thread
+(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)))))))
+
+(define-alien-routine "thread_yield" int)
+
+#!+sb-doc
+(setf (fdocumentation 'thread-yield 'function)
+ "Yield the processor to other threads.")
+
+#!+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)
+ (make-lisp-obj tl-val))))
+
+(defun sb!vm::locked-symbol-global-value-add (symbol-name delta)
+ (sb!vm::locked-symbol-global-value-add symbol-name delta))
+
+;;; Stepping
+
+(defun thread-stepping ()
+ (make-lisp-obj
+ (sap-ref-word (current-thread-sap)
+ (* sb!vm::thread-stepping-slot sb!vm:n-word-bytes))))
+
+(defun (setf thread-stepping) (value)
+ (setf (sap-ref-word (current-thread-sap)
+ (* sb!vm::thread-stepping-slot sb!vm:n-word-bytes))
+ (get-lisp-obj-address value)))