+;;; Of the WITH-PINNED-OBJECTS in this file, not every single one is
+;;; necessary because threads are only supported with the conservative
+;;; gencgc and numbers on the stack (returned by GET-LISP-OBJ-ADDRESS)
+;;; are treated as references.
+
+;;; set the doc here because in early-thread FDOCUMENTATION is not
+;;; available, yet
+#!+sb-doc
+(setf (fdocumentation '*current-thread* 'variable)
+ "Bound in each thread to the thread itself.")
+
+(defstruct (thread (:constructor %make-thread))
+ #!+sb-doc
+ "Thread type. Do not rely on threads being structs as it may change
+in future versions."
+ name
+ %alive-p
+ os-thread
+ interruptions
+ (interruptions-lock (make-mutex :name "thread interruptions lock"))
+ result
+ (result-lock (make-mutex :name "thread result lock")))
+
+#!+sb-doc
+(setf (fdocumentation 'thread-name 'function)
+ "The name of the thread. Setfable.")
+
+(def!method print-object ((thread thread) stream)
+ (if (thread-name thread)
+ (print-unreadable-object (thread stream :type t :identity t)
+ (prin1 (thread-name thread) stream))
+ (print-unreadable-object (thread stream :type t :identity t)
+ ;; body is empty => there is only one space between type and
+ ;; identity
+ ))
+ thread)
+
+(defun thread-alive-p (thread)
+ #!+sb-doc
+ "Check if THREAD is running."
+ (thread-%alive-p thread))
+
+;; A thread is eligible for gc iff it has finished and there are no
+;; more references to it. This list is supposed to keep a reference to
+;; all running threads.
+(defvar *all-threads* ())
+(defvar *all-threads-lock* (make-mutex :name "all threads lock"))
+
+(defmacro with-all-threads-lock (&body body)
+ `(call-with-system-mutex (lambda () ,@body) *all-threads-lock*))
+
+(defun list-all-threads ()
+ #!+sb-doc
+ "Return a list of the live threads."
+ (with-all-threads-lock
+ (copy-list *all-threads*)))
+
+(declaim (inline current-thread-sap))
+(defun current-thread-sap ()
+ (sb!vm::current-thread-offset-sap sb!vm::thread-this-slot))
+
+(declaim (inline current-thread-sap-id))
+(defun current-thread-sap-id ()
+ (sap-int
+ (sb!vm::current-thread-offset-sap sb!vm::thread-os-thread-slot)))
+
+(defun init-initial-thread ()
+ (/show0 "Entering INIT-INITIAL-THREAD")
+ (let ((initial-thread (%make-thread :name "initial thread"
+ :%alive-p t
+ :os-thread (current-thread-sap-id))))
+ (setq *current-thread* initial-thread)
+ ;; Either *all-threads* is empty or it contains exactly one thread
+ ;; in case we are in reinit since saving core with multiple
+ ;; threads doesn't work.
+ (setq *all-threads* (list initial-thread))))
+
+;;;;
+
+#!+sb-thread
+(progn
+ ;; FIXME it would be good to define what a thread id is or isn't
+ ;; (our current assumption is that it's a fixnum). It so happens
+ ;; that on Linux it's a pid, but it might not be on posix thread
+ ;; implementations.
+ (define-alien-routine ("create_thread" %create-thread)
+ unsigned-long (lisp-fun-address unsigned-long))
+
+ (define-alien-routine "signal_interrupt_thread"
+ integer (os-thread unsigned-long))
+
+ (define-alien-routine "block_deferrable_signals"
+ void)
+
+ #!+sb-lutex
+ (progn
+ (declaim (inline %lutex-init %lutex-wait %lutex-wake
+ %lutex-lock %lutex-unlock))
+
+ (define-alien-routine ("lutex_init" %lutex-init)
+ int (lutex unsigned-long))
+
+ (define-alien-routine ("lutex_wait" %lutex-wait)
+ int (queue-lutex unsigned-long) (mutex-lutex unsigned-long))
+
+ (define-alien-routine ("lutex_wake" %lutex-wake)
+ int (lutex unsigned-long) (n int))
+
+ (define-alien-routine ("lutex_lock" %lutex-lock)
+ int (lutex unsigned-long))
+
+ (define-alien-routine ("lutex_trylock" %lutex-trylock)
+ int (lutex unsigned-long))
+
+ (define-alien-routine ("lutex_unlock" %lutex-unlock)
+ int (lutex unsigned-long))
+
+ (define-alien-routine ("lutex_destroy" %lutex-destroy)
+ int (lutex unsigned-long))
+
+ ;; FIXME: Defining a whole bunch of alien-type machinery just for
+ ;; passing primitive lutex objects directly to foreign functions
+ ;; doesn't seem like fun right now. So instead we just manually
+ ;; pin the lutex, get its address, and let the callee untag it.
+ (defmacro with-lutex-address ((name lutex) &body body)
+ `(let ((,name ,lutex))
+ (with-pinned-objects (,name)
+ (let ((,name (get-lisp-obj-address ,name)))
+ ,@body))))
+
+ (defun make-lutex ()
+ (/show0 "Entering MAKE-LUTEX")
+ ;; Suppress GC until the lutex has been properly registered with
+ ;; the GC.
+ (without-gcing
+ (let ((lutex (sb!vm::%make-lutex)))
+ (/show0 "LUTEX=..")
+ (/hexstr lutex)
+ (with-lutex-address (lutex lutex)
+ (%lutex-init lutex))
+ lutex))))
+
+ #!-sb-lutex
+ (progn
+ (declaim (inline futex-wait %futex-wait futex-wake))
+
+ (define-alien-routine ("futex_wait" %futex-wait)
+ int (word unsigned-long) (old-value unsigned-long)
+ (to-sec long) (to-usec unsigned-long))
+
+ (defun futex-wait (word old to-sec to-usec)
+ (with-interrupts
+ (%futex-wait word old to-sec to-usec)))
+
+ (define-alien-routine "futex_wake"
+ int (word unsigned-long) (n unsigned-long))))
+
+;;; used by debug-int.lisp to access interrupt contexts
+#!-(or sb-fluid sb-thread) (declaim (inline sb!vm::current-thread-offset-sap))
+#!-sb-thread
+(defun sb!vm::current-thread-offset-sap (n)
+ (declare (type (unsigned-byte 27) n))
+ (sap-ref-sap (alien-sap (extern-alien "all_threads" (* t)))
+ (* n sb!vm:n-word-bytes)))
+
+#!+sb-thread
+(defun sb!vm::current-thread-offset-sap (n)
+ (declare (type (unsigned-byte 27) n))
+ (sb!vm::current-thread-offset-sap n))
+
+(declaim (inline get-spinlock release-spinlock))
+
+;; Should always be called with interrupts disabled.
+(defun get-spinlock (spinlock)
+ (declare (optimize (speed 3) (safety 0)))
+ (let* ((new *current-thread*)
+ (old (sb!ext:compare-and-swap (spinlock-value spinlock) nil new)))
+ (when old
+ (when (eq old new)
+ (error "Recursive lock attempt on ~S." spinlock))
+ #!+sb-thread
+ (flet ((cas ()
+ (unless (sb!ext:compare-and-swap (spinlock-value spinlock) nil new)
+ (return-from get-spinlock t))))
+ (if (and (not *interrupts-enabled*) *allow-with-interrupts*)
+ ;; If interrupts are enabled, but we are allowed to enabled them,
+ ;; check for pending interrupts every once in a while.
+ (loop
+ (loop repeat 128 do (cas)) ; 128 is arbitrary here
+ (sb!unix::%check-interrupts))
+ (loop (cas)))))
+ t))
+
+(defun release-spinlock (spinlock)
+ (declare (optimize (speed 3) (safety 0)))
+ (setf (spinlock-value spinlock) nil)
+ nil)
+
+;;;; mutexes
+
+#!+sb-doc
+(setf (fdocumentation 'make-mutex 'function)
+ "Create a mutex."
+ (fdocumentation 'mutex-name 'function)
+ "The name of the mutex. Setfable.")
+
+#!+(and sb-thread (not sb-lutex))
+(progn
+ (define-structure-slot-addressor mutex-state-address
+ :structure mutex
+ :slot state)
+ ;; Important: current code assumes these are fixnums or other
+ ;; lisp objects that don't need pinning.
+ (defconstant +lock-free+ 0)
+ (defconstant +lock-taken+ 1)
+ (defconstant +lock-contested+ 2))
+
+(defun get-mutex (mutex &optional (new-owner *current-thread*) (waitp t))
+ #!+sb-doc
+ "Acquire MUTEX for NEW-OWNER, which must be a thread or NIL. If
+NEW-OWNER is NIL, it defaults to the current thread. If WAITP is
+non-NIL and the mutex is in use, sleep until it is available.
+
+Note: using GET-MUTEX to assign a MUTEX to another thread then the
+current one is not recommended, and liable to be deprecated.
+
+GET-MUTEX is not interrupt safe. The correct way to call it is:
+
+ (WITHOUT-INTERRUPTS
+ ...
+ (ALLOW-WITH-INTERRUPTS (GET-MUTEX ...))
+ ...)
+
+WITHOUT-INTERRUPTS is necessary to avoid an interrupt unwinding the
+call while the mutex is in an inconsistent state while
+ALLOW-WITH-INTERRUPTS allows the call to be interrupted from sleep.
+
+It is recommended that you use WITH-MUTEX instead of calling GET-MUTEX
+directly."
+ (declare (type mutex mutex) (optimize (speed 3))
+ #!-sb-thread (ignore waitp))
+ (unless new-owner
+ (setq new-owner *current-thread*))
+ (when (eql new-owner (mutex-%owner mutex))
+ (error "Recursive lock attempt ~S." mutex))
+ #!+sb-thread
+ (progn
+ ;; FIXME: Lutexes do not currently support deadlines, as at least
+ ;; on Darwin pthread_foo_timedbar functions are not supported:
+ ;; this means that we probably need to use the Carbon multiprocessing
+ ;; functions on Darwin.
+ ;;
+ ;; FIXME: This is definitely not interrupt safe: what happens if
+ ;; we get hit (1) during the lutex calls (ok, they may be safe,
+ ;; but has that been checked?) (2) after the lutex call, but
+ ;; before setting the mutex owner.
+ #!+sb-lutex
+ (when (zerop (with-lutex-address (lutex (mutex-lutex mutex))
+ (if waitp
+ (with-interrupts (%lutex-lock lutex))
+ (%lutex-trylock lutex))))
+ (setf (mutex-%owner mutex) new-owner)
+ t)
+ #!-sb-lutex
+ (let ((old (sb!ext:compare-and-swap (mutex-state mutex)
+ +lock-free+
+ +lock-taken+)))
+ (unless (or (eql +lock-free+ old) (not waitp))
+ (tagbody
+ :retry
+ (when (or (eql +lock-contested+ old)
+ (not (eql +lock-free+
+ (sb!ext:compare-and-swap (mutex-state mutex)
+ +lock-taken+
+ +lock-contested+))))
+ ;; Wait on the contested lock.
+ (multiple-value-bind (to-sec to-usec) (decode-timeout nil)
+ (when (= 1 (with-pinned-objects (mutex)
+ (futex-wait (mutex-state-address mutex)
+ (get-lisp-obj-address +lock-contested+)
+ (or to-sec -1)
+ (or to-usec 0))))
+ (signal-deadline))))
+ (setf old (sb!ext:compare-and-swap (mutex-state mutex)
+ +lock-free+
+ +lock-contested+))
+ ;; Did we get it?
+ (unless (eql +lock-free+ old)
+ (go :retry))))
+ (cond ((eql +lock-free+ old)
+ (let ((prev (sb!ext:compare-and-swap (mutex-%owner mutex)
+ nil new-owner)))
+ (when prev
+ (bug "Old owner in free mutex: ~S" prev))
+ t))
+ (waitp
+ (bug "Failed to acquire lock with WAITP."))))))
+
+(defun release-mutex (mutex)
+ #!+sb-doc
+ "Release MUTEX by setting it to NIL. Wake up threads waiting for
+this mutex.
+
+RELEASE-MUTEX is not interrupt safe: interrupts should be disabled
+around calls to it.
+
+Signals a WARNING is current thread is not the current owner of the
+mutex."
+ (declare (type mutex mutex))
+ ;; Order matters: set owner to NIL before releasing state.
+ (let* ((self *current-thread*)
+ (old-owner (sb!ext:compare-and-swap (mutex-%owner mutex) self nil)))
+ (unless (eql self old-owner)
+ (warn "Releasing ~S, owned by another thread: ~S" mutex old-owner)
+ (setf (mutex-%owner mutex) nil)))
+ #!+sb-thread
+ (progn
+ #!+sb-lutex
+ (with-lutex-address (lutex (mutex-lutex mutex))
+ (%lutex-unlock lutex))
+ #!-sb-lutex
+ (let ((old (sb!ext:compare-and-swap (mutex-state mutex)
+ +lock-taken+ +lock-free+)))
+ (when (eql old +lock-contested+)
+ (sb!ext:compare-and-swap (mutex-state mutex)
+ +lock-contested+ +lock-free+)
+ (with-pinned-objects (mutex)
+ (futex-wake (mutex-state-address mutex) 1))))
+ nil))
+
+;;;; waitqueues/condition variables
+
+(defstruct (waitqueue (:constructor %make-waitqueue))
+ #!+sb-doc
+ "Waitqueue type."
+ (name nil :type (or null simple-string))
+ #!+(and sb-lutex sb-thread)
+ (lutex (make-lutex))
+ #!-sb-lutex
+ (data nil))