Add semaphores abstraction to bordeaux-threads

[bordeaux-threads.git] / src / default-implementations.lisp

;;;; -*- indent-tabs-mode: nil -*-

(in-package #:bordeaux-threads)

;;; Helper macros

(defmacro defdfun (name args doc &body body)
  `(eval-when (:compile-toplevel :load-toplevel :execute)
     (unless (fboundp ',name)
       (defun ,name ,args ,@body))
     (setf (documentation ',name 'function)
           (or (documentation ',name 'function) ,doc))))

(defmacro defdmacro (name args doc &body body)
  `(eval-when (:compile-toplevel :load-toplevel :execute)
     (unless (fboundp ',name)
       (defmacro ,name ,args ,@body))
     (setf (documentation ',name 'function)
           (or (documentation ',name 'function) ,doc))))

;;; Thread Creation

(defdfun start-multiprocessing ()
  "If the host implementation uses user-level threads, start the
scheduler and multiprocessing, otherwise do nothing.
It is safe to call repeatedly."
  nil)

(defdfun make-thread (function &key name
                      (initial-bindings *default-special-bindings*))
  "Creates and returns a thread named NAME, which will call the
  function FUNCTION with no arguments: when FUNCTION returns, the
  thread terminates. NAME defaults to \"Anonymous thread\" if unsupplied.

  On systems that do not support multi-threading, MAKE-THREAD will
  signal an error.

  The interaction between threads and dynamic variables is in some
  cases complex, and depends on whether the variable has only a global
  binding (as established by e.g. DEFVAR/DEFPARAMETER/top-level SETQ)
  or has been bound locally (e.g. with LET or LET*) in the calling
  thread.

  - Global bindings are shared between threads: the initial value of a
    global variable in the new thread will be the same as in the
    parent, and an assignment to such a variable in any thread will be
    visible to all threads in which the global binding is visible.

  - Local bindings, such as the ones introduced by INITIAL-BINDINGS,
    are local to the thread they are introduced in, except that

  - Local bindings in the the caller of MAKE-THREAD may or may not be
    shared with the new thread that it creates: this is
    implementation-defined. Portable code should not depend on
    particular behaviour in this case, nor should it assign to such
    variables without first rebinding them in the new thread."
  (%make-thread (binding-default-specials function initial-bindings)
                (or name "Anonymous thread")))

(defdfun %make-thread (function name)
  "The actual implementation-dependent function that creates threads."
  (declare (ignore function name))
  (error (make-threading-support-error)))

(defdfun current-thread ()
  "Returns the thread object for the calling
  thread. This is the same kind of object as would be returned by
  MAKE-THREAD."
  nil)

(defdfun threadp (object)
  "Returns true if object is a thread, otherwise NIL."
  (declare (ignore object))
  nil)

(defdfun thread-name (thread)
  "Returns the name of the thread, as supplied to MAKE-THREAD."
  (declare (ignore thread))
  "Main thread")

;;; Resource contention: locks and recursive locks

(defdfun lock-p (object)
  "Returns T if OBJECT is a lock; returns NIL otherwise."
  (declare (ignore object))
  nil)

(defdfun recursive-lock-p (object)
  "Returns T if OBJECT is a recursive lock; returns NIL otherwise."
  (declare (ignore object))
  nil)

(defdfun make-lock (&optional name)
  "Creates a lock (a mutex) whose name is NAME. If the system does not
  support multiple threads this will still return some object, but it
  may not be used for very much."
  ;; In CLIM-SYS this is a freshly consed list (NIL). I don't know if
  ;; there's some good reason it should be said structure or that it
  ;; be freshly consed - EQ comparison of locks?
  (declare (ignore name))
  (list nil))

(defdfun acquire-lock (lock &optional wait-p)
  "Acquire the lock LOCK for the calling thread.
  WAIT-P governs what happens if the lock is not available: if WAIT-P
  is true, the calling thread will wait until the lock is available
  and then acquire it; if WAIT-P is NIL, ACQUIRE-LOCK will return
  immediately. ACQUIRE-LOCK returns true if the lock was acquired and
  NIL otherwise.

  This specification does not define what happens if a thread
  attempts to acquire a lock that it already holds. For applications
  that require locks to be safe when acquired recursively, see instead
  MAKE-RECURSIVE-LOCK and friends."
  (declare (ignore lock wait-p))
  t)

(defdfun release-lock (lock)
  "Release LOCK. It is an error to call this unless
  the lock has previously been acquired (and not released) by the same
  thread. If other threads are waiting for the lock, the
  ACQUIRE-LOCK call in one of them will now be able to continue.

  This function has no interesting return value."
  (declare (ignore lock))
  (values))

(defdmacro with-lock-held ((place) &body body)
  "Evaluates BODY with the lock named by PLACE, the value of which
  is a lock created by MAKE-LOCK. Before the forms in BODY are
  evaluated, the lock is acquired as if by using ACQUIRE-LOCK. After the
  forms in BODY have been evaluated, or if a non-local control transfer
  is caused (e.g. by THROW or SIGNAL), the lock is released as if by
  RELEASE-LOCK.

  Note that if the debugger is entered, it is unspecified whether the
  lock is released at debugger entry or at debugger exit when execution
  is restarted."
  `(when (acquire-lock ,place t)
     (unwind-protect
          (locally ,@body)
       (release-lock ,place))))

(defdfun make-recursive-lock (&optional name)
  "Create and return a recursive lock whose name is NAME. A recursive
  lock differs from an ordinary lock in that a thread that already
  holds the recursive lock can acquire it again without blocking. The
  thread must then release the lock twice before it becomes available
  for another thread."
  (declare (ignore name))
  (list nil))

(defdfun acquire-recursive-lock (lock)
  "As for ACQUIRE-LOCK, but for recursive locks."
  (declare (ignore lock))
  t)

(defdfun release-recursive-lock (lock)
  "Release the recursive LOCK. The lock will only
  become free after as many Release operations as there have been
  Acquire operations. See RELEASE-LOCK for other information."
  (declare (ignore lock))
  (values))

(defdmacro with-recursive-lock-held ((place &key timeout) &body body)
  "Evaluates BODY with the recursive lock named by PLACE, which is a
reference to a recursive lock created by MAKE-RECURSIVE-LOCK. See
WITH-LOCK-HELD etc etc"
  (declare (ignore timeout))
  `(when (acquire-recursive-lock ,place)
     (unwind-protect
          (locally ,@body)
       (release-recursive-lock ,place))))

;;; Resource contention: condition variables

;;; A condition variable provides a mechanism for threads to put
;;; themselves to sleep while waiting for the state of something to
;;; change, then to be subsequently woken by another thread which has
;;; changed the state.
;;;
;;; A condition variable must be used in conjunction with a lock to
;;; protect access to the state of the object of interest. The
;;; procedure is as follows:
;;;
;;; Suppose two threads A and B, and some kind of notional event
;;; channel C. A is consuming events in C, and B is producing them.
;;; CV is a condition-variable
;;;
;;; 1) A acquires the lock that safeguards access to C
;;; 2) A threads and removes all events that are available in C
;;; 3) When C is empty, A calls CONDITION-WAIT, which atomically
;;;    releases the lock and puts A to sleep on CV
;;; 4) Wait to be notified; CONDITION-WAIT will acquire the lock again
;;;    before returning
;;; 5) Loop back to step 2, for as long as threading should continue
;;;
;;; When B generates an event E, it
;;; 1) acquires the lock guarding C
;;; 2) adds E to the channel
;;; 3) calls CONDITION-NOTIFY on CV to wake any sleeping thread
;;; 4) releases the lock
;;;
;;; To avoid the "lost wakeup" problem, the implementation must
;;; guarantee that CONDITION-WAIT in thread A atomically releases the
;;; lock and sleeps. If this is not guaranteed there is the
;;; possibility that thread B can add an event and call
;;; CONDITION-NOTIFY between the lock release and the sleep - in this
;;; case the notify call would not see A, which would be left sleeping
;;; despite there being an event available.

(defdfun thread-yield ()
  "Allows other threads to run. It may be necessary or desirable to
  call this periodically in some implementations; others may schedule
  threads automatically. On systems that do not support
  multi-threading, this does nothing."
  (values))

(defdfun make-condition-variable (&key name)
  "Returns a new condition-variable object for use
  with CONDITION-WAIT and CONDITION-NOTIFY."
  (declare (ignore name))
  nil)

(defdfun condition-wait (condition-variable lock &key timeout)
  "Atomically release LOCK and enqueue the calling
  thread waiting for CONDITION-VARIABLE. The thread will resume when
  another thread has notified it using CONDITION-NOTIFY; it may also
  resume if interrupted by some external event or in other
  implementation-dependent circumstances: the caller must always test
  on waking that there is threading to be done, instead of assuming
  that it can go ahead.

  It is an error to call function this unless from the thread that
  holds LOCK.

  If TIMEOUT is nil or not provided, the system always reacquires LOCK
  before returning to the caller. In this case T is returned.

  If TIMEOUT is non-nil, the call will return after at most TIMEOUT
  seconds (approximately), whether or not a notification has occurred.
  Either NIL or T will be returned. A return of NIL indicates that the
  lock is no longer held and that the timeout has expired. A return of
  T indicates that the lock is held, in which case the timeout may or
  may not have expired.

  **NOTE**: The behavior of CONDITION-WAIT with TIMEOUT diverges from
  the POSIX function pthread_cond_timedwait. The former may return
  without the lock being held while the latter always returns with the
  lock held.

  In an implementation that does not support multiple threads, this
  function signals an error."
  (declare (ignore condition-variable lock timeout))
  (error (make-threading-support-error)))

(defdfun condition-notify (condition-variable)
  "Notify at least one of the threads waiting for
  CONDITION-VARIABLE. It is implementation-dependent whether one or
  more than one (and possibly all) threads are woken, but if the
  implementation is capable of waking only a single thread (not all
  are) this is probably preferable for efficiency reasons. The order
  of wakeup is unspecified and does not necessarily relate to the
  order that the threads went to sleep in.

  CONDITION-NOTIFY has no useful return value. In an implementation
  that does not support multiple threads, it has no effect."
  (declare (ignore condition-variable))
  (values))

;;; Resource contention: semaphores

(defdfun make-semaphore (&key name (count 0))
    "Create a semaphore with the supplied NAME and initial counter value COUNT."
  (make-%semaphore :lock (make-lock name)
                   :condition-variable (make-condition-variable :name name)
                   :counter count))

(defdfun signal-semaphore (semaphore &key (count 1))
    "Increment SEMAPHORE by COUNT. If there are threads waiting on this
semaphore, then COUNT of them are woken up."
  (with-lock-held ((%semaphore-lock semaphore))
    (incf (%semaphore-counter semaphore) count)
    (dotimes (v count)
      (condition-notify (%semaphore-condition-variable semaphore))))
  (values))

(defdfun wait-on-semaphore (semaphore &key timeout)
  "Decrement the count of SEMAPHORE by 1 if the count would not be negative.

Else blocks until the semaphore can be decremented. Returns generalized boolean
T on success.

If TIMEOUT is given, it is the maximum number of seconds to wait. If the count
cannot be decremented in that time, returns NIL without decrementing the count."
  (with-lock-held ((%semaphore-lock semaphore))
    (if (>= (%semaphore-counter semaphore) 1)
        (decf (%semaphore-counter semaphore))
        (let ((deadline (when timeout
                          (+ (get-internal-real-time)
                             (* timeout internal-time-units-per-second)))))
          ;; we need this loop because of a spurious wakeup possibility
          (loop until (>= (%semaphore-counter semaphore) 1)
             do (cond
                  ((null (condition-wait (%semaphore-condition-variable semaphore)
                                         (%semaphore-lock semaphore)
                                         :timeout timeout))
                   (return-from wait-on-semaphore))
                  ;; unfortunately cv-wait may return T on timeout too
                  ((and deadline (>= (get-internal-real-time) deadline))
                   (return-from wait-on-semaphore))
                  (timeout
                   (setf timeout (/ (- deadline (get-internal-real-time))
                                    internal-time-units-per-second)))))
          (decf (%semaphore-counter semaphore))))))

;;; Timeouts

(defdmacro with-timeout ((timeout) &body body)
  "Execute `BODY' and signal a condition of type TIMEOUT if the execution of
BODY does not complete within `TIMEOUT' seconds. On implementations which do not
support WITH-TIMEOUT natively and don't support threads either it has no effect."
  (declare (ignorable timeout))
  #+thread-support
  (let ((ok-tag (gensym "OK"))
        (timeout-tag (gensym "TIMEOUT"))
        (caller (gensym "CALLER"))
        (sleeper (gensym "SLEEPER")))
    (once-only (timeout)
      `(let (,sleeper)
         (multiple-value-prog1
             (catch ',ok-tag
               (catch ',timeout-tag
                 (let ((,caller (current-thread)))
                   (setf ,sleeper
                         (make-thread #'(lambda ()
                                          (sleep ,timeout)
                                          (interrupt-thread ,caller
                                                            #'(lambda ()
                                                                (ignore-errors
                                                                  (throw ',timeout-tag nil)))))
                                      :name (format nil "WITH-TIMEOUT thread serving: ~S."
                                                    (thread-name ,caller))))
                   (throw ',ok-tag (progn ,@body))))
               (error 'timeout :length ,timeout))
           (when (thread-alive-p ,sleeper)
             (destroy-thread ,sleeper))))))
  #-thread-support
  `(progn
     ,@body))
(defdfun semaphore-p (object)
  "Returns T if OBJECT is a semaphore; returns NIL otherwise."
  (typep object 'semaphore))

;;; Introspection/debugging

;;; The following functions may be provided for debugging purposes,
;;; but are not advised to be called from normal user code.

(defdfun all-threads ()
  "Returns a sequence of all of the threads. This may not
  be freshly-allocated, so the caller should not modify it."
  (error (make-threading-support-error)))

(defdfun interrupt-thread (thread function)
  "Interrupt THREAD and cause it to evaluate FUNCTION
  before continuing with the interrupted path of execution. This may
  not be a good idea if THREAD is holding locks or doing anything
  important. On systems that do not support multiple threads, this
  function signals an error."
  (declare (ignore thread function))
  (error (make-threading-support-error)))

(defdfun destroy-thread (thread)
  "Terminates the thread THREAD, which is an object
  as returned by MAKE-THREAD. This should be used with caution: it is
  implementation-defined whether the thread runs cleanup forms or
  releases its locks first.

  Destroying the calling thread is an error."
  (declare (ignore thread))
  (error (make-threading-support-error)))

(defdfun thread-alive-p (thread)
  "Returns true if THREAD is alive, that is, if
  DESTROY-THREAD has not been called on it."
  (declare (ignore thread))
  (error (make-threading-support-error)))

(defdfun join-thread (thread)
  "Wait until THREAD terminates. If THREAD
  has already terminated, return immediately."
  (declare (ignore thread))
  (error (make-threading-support-error)))