wait-for-objects.lisp

;;;; WAIT-FOR-OBJECTS. Wait for events on multiple objects.

(defun wait-for-objects (&rest objects)
  "Wait for any object in OBJECTS to be ready.
Returns a list of objects that are ready.
If no objects are supplied, then W-F-O will wait forever."
  ...)

(defun wait-for-objects-with-timeout (timeout &rest objects)
  "As with WAIT-FOR-OBJECTS, but with a timeout.
If TIMEOUT is NIL then this is equivalent to WAIT-FOR-OBJECTS.
Otherwise it is as if a timer object with the given TIMEOUT was included with OBJECTS.
Returns NIL if the timeout expires.
Returns the number of seconds remaining as a secondary value if TIMEOUT is non-NIL."
  (cond ((null timeout)
         ;; No timeout.
         (values (apply #'wait-for-objects objects)
                 nil))
        ((not (plusp timeout))
         ;; Special case, zero or negative timeout - just poll the events.
         (values (loop
                    for object in objects
                    when (event-wait (get-object-event object) nil)
                    collect object)
                 0))
        (t
         ;; Arbitrary timeout.
         (let ((timer (make-timer)))
           (timer-arm timeout timer)
           (values (remove timer (apply #'wait-for-objects (list* timer objects)))
                   (timer-remaining timer))))))

(defgeneric get-object-event (object)
  (:documentation "Convert OBJECT into an EVENT object."))

;;;; Event. The basic building block used by WAIT-FOR-OBJECTS.
;;;;
;;;; This can be used directly (as by the epoch indicators) or
;;;; wrapped by higher-level structures (like timers, semaphores, etc).
;;;; GET-OBJECT-EVENT is used by W-F-O to convert high-level objects
;;;; to their appropriate event objects.

(defstruct event ...)

(defmethod get-object-event ((object event))
  object)

;;; Public API:

(defun make-event (&key name state)
  "Create a new event with the specified initial state."
  ...)

(defun event-state (event)
  "Return the current state of EVENT."
  ...)

(defun (setf event-state) (state event)
  "Set the state of EVENT.
STATE may be any object and will be treated as a generalized boolean by EVENT-WAIT and WAIT-FOR-OBJECTS."
  ...)

(defun event-wait (event &key (wait-p t))
  "Wait until EVENT's state is not NIL.
Returns EVENT's state, or NIL if WAIT-P is false and the state is NIL."
  ...)

;;;; Epoch indicators.
;;;;
;;;; These functions return events that are set when the given epoch ends.

(defun boot-epoch ()
  "Return an epoch event for the current boot.
This event is set after a snapshot is taken *and* the machine is rebooted."
  ...)

(defun gc-epoch ()
  "Return an epoch event for the current GC epoch.
This event is set when the GC runs and objects may have been moved."
  ...)

;;;; Timers.
;;;;
;;;; Absolute and relative.
;;;; These are based on elapsed system run time, not wall-clock time so
;;;; are unaffected by snapshot-inflicted time travel or other real time changes.

(defstruct timer ...)

(defmethod get-object-event ((object timer))
  ...)

;;; Public API:

(defun make-timer (&key name)
  "Create a new disarmed timer.
It must be armed with TIMER-ARM or TIMER-ARM-ABSOLUTE before use."
  ...)

(defun timer-arm (seconds timer)
  "Configure TIMER to go off in approximately SECONDS seconds from now.
SECONDS must be a REAL.
This is a convienence function wrapping TIMER-ARM-ABSOLUTE."
  (timer-arm-absolute (+ (get-internal-run-time)
                         (truncate (* seconds internal-time-units-per-second)))
                      timer))

(defun timer-arm-absolute (internal-run-time timer)
  "Configure TIMER to go off at INTERNAL-RUN-TIME.
This is an absolute time specified in integer internal time units.
The current internal run time can be fetched with GET-INTERNAL-RUN-TIME."
  ...)

(defun timer-disarm (timer)
  "Reset TIMER back to its creation state.
Returns the number of seconds remaining if was armed or NIL if it was disarmed."
  ...)

(defun timer-remaining (timer)
  "Returns the number of seconds remaining if TIMER is armed or NIL if it is disarmed."
  (let ((deadline (timer-deadline timer)))
    (when deadline
      (/ (min 0 (- deadline (get-internal-run-time)))
         internal-time-units-per-second))))

(defun timer-deadline (timer)
  "Returns TIMER's internal run time deadline if is armed or NIL if it is disarmed."
  ...)

(defun timer-wait (timer &key (wait-p t))
  "Wait until TIMER has fired.
If TIMER has been disarmed or not yet armed, then an error will be signalled.
Returns true if the timer has fired, false if it hasn't and WAIT-P is false."
  ...)

;;;; Semaphore.

(defclass semaphore ()
  ((%not-zero-event :initarg :not-zero-event :reader semaphore-not-zero-event)
   (%lock :initarg :lock :reader semaphore-lock)
   (%value :initarg :value :accessor %semaphore-value)))

(defmethod print-object ((object semaphore) stream)
  (print-unreadable-object (object stream :type t :identity t)
    (format stream "~S" (semaphore-name object))))

(defmethod get-object-event ((object semaphore))
  (semaphore-not-zero-event semaphore))

;;; Public API:

(defun make-semaphore (&key name (initial-value 0))
  (check-type initial-value (integer 0))
  (make-instance 'semaphore
                 :not-zero-event (make-event :name name
                                             :initial-state (not (zerop initial-value)))
                 :lock (make-mutex "Internal semaphore lock")
                 :value initial-value))

(defun semaphore-up (semaphore)
  "Increment SEMAPHORE."
  (with-mutex ((semaphore-lock semaphore))
    (incf (%semaphore-value semaphore))
    (event-set t (semaphore-not-zero-event semaphore)))
  (values))

(defun semaphore-down (semaphore &key (wait-p t))
  "Decrement SEMAPHORE.
If SEMAPHORE's current value is 0, then this will block if WAIT-P is true
until SEMAPHORE is incremented.
Returns true if SEMAPHORE was decremented, false if WAIT-P is false and the semapore's value is 0."
  (loop
     (with-mutex ((semaphore-lock semaphore))
       (when (not (zerop (%semaphore-value semaphore)))
         (decf (%semaphore-value semaphore))
         (when (zerop (%semaphore-value semaphore))
           (event-set nil (semaphore-not-zero-event semaphore)))
         (return t)))
     (when (not wait-p)
       (return nil))
     (event-wait (semaphore-not-zero-event semaphore))))

(defun semaphore-value (semaphore)
  "Return SEMAPHORE's current value."
  (%semaphore-value semaphore))

(defun semaphore-name (semaphore)
  (event-name (semaphore-not-zero-event semaphore)))

;;;; Mailbox. A buffered communication channel.
;;;;
;;;; There are separate send and receive endpoint objects
;;;; so that WAIT-FOR-OBJECT can know which event is being
;;;; waited for (non-empty vs non-full).

(defclass mailbox ()
  ((%name)
   (%capacity)
   (%not-full-event)
   (%not-empty-event)
   ...
))

(defclass mailbox-endpoint ()
  ((%mailbox :initarg :mailbox :reader mailbox-endpoint-mailbox)))
(defclass mailbox-sender (mailbox-endpoint))
(defclass mailbox-receiver (mailbox-endpoint))

(defmethod initialize-instance :after ((instance mailbox))
  ;; Mailbox is initially empty.
  (setf (slot-value instance '%not-full-event) (make-event :name `(mailbox-not-full-event ,mailbox)
                                                           :initial-state t)
        (slot-value instance '%not-empty-event) (make-event :name `(mailbox-not-empty-event ,mailbox)
                                                            :initial-state nil)))

(defmethod get-object-event ((object mailbox-sender))
  ;; Mailbox is ready for sending as long as it isn't full.
  (slot-value (mailbox-endpoint-mailbox object) '%not-full-event))

(defmethod get-object-event ((object mailbox-receiver))
  ;; Mailbox is ready for receiving as long as it isn't empty
  (slot-value (mailbox-endpoint-mailbox object) '%not-empty-event))

;;; Public API:

(defun make-mailbox (&key name capacity)
  "Create a new mailbox.
CAPACITY can be NIL to indicate that there should be no limit on the number of buffered items
or a positive integer to restrict the buffer to that many items.
Returns two values representing the send & receive sides of the mailbox.
Items are sent and received in FIFO order."
  (check-type capacity (or null (integer 1)))
  (let ((mailbox (make-instance 'mailbox
                                :name name
                                :capacity capacity)))
    (values (make-instance 'mailbox-sender :mailbox mailbox)
            (make-instance 'mailbox-receiver :mailbox mailbox))))

(defun mailbox-send (value sender &key (wait-p t))
  "Push a value into the mailbox.
If the mailbox is at capacity, this will block if WAIT-P is true."
  ...)

(defun mailbox-receive (receiver &key (wait-p t))
  "Pop a value from the mailbox.
If the mailbox is empty, this will block if WAIT-P is true."
  ...)

(defun mailbox-peek (receiver &key (wait-p t))
  "Peek at the next pending message in the mailbox, if any.
Like MAILBOX-RECEIVE, but leaves the message in the mailbox."
  ...)

(defun mailbox-empty-p (mailbox-endpoint)
  "Returns true if there are no messages waiting."
  (zerop (mailbox-n-pending mailbox-endpoint)))

(defun mailbox-n-pending (mailbox-endpoint)
  "Returns the number of waiting messages."
  ...)

(defun mailbox-equal (mailbox-endpoint-a mailbox-endpoint-b)
  "Returns true if both endpoints refer to the same mailbox."
  (eql (mailbox-endpoint-mailbox mailbox-endpoint-a)
       (mailbox-endpoint-mailbox mailbox-endpoint-b)))

(defun mailbox-name (mailbox-endpoint)
  "Returns the name argument passed to MAKE-MAILBOX."
  ...)

(defun mailbox-capacity (mailbox-endpoint)
  "Returns the capacity argument passed to MAKE-MAILBOX."
  ...)