apiv2/impl-condition-variables-semaphores.lisp

   1 ;;;; -*- indent-tabs-mode: nil -*-
   2
   3 (in-package :bordeaux-threads-2)
   4
   5 ;;;
   6 ;;; Portable condition variables using semaphores.
   7 ;;;
   8 ;;; The implementation is meant to be correct and readable,
   9 ;;; without trying too hard to be very fast.
  10 ;;;
  11
  12 (defstruct queue
  13   (vector (make-array 7 :adjustable t :fill-pointer 0) :type vector)
  14   (lock (%make-lock nil) :type native-lock))
  15
  16 (defun queue-drain (queue)
  17   (%with-lock ((queue-lock queue) nil)
  18     (shiftf (queue-vector queue)
  19             (make-array 7 :adjustable t :fill-pointer 0))))
  20
  21 (defun queue-dequeue (queue)
  22   (%with-lock ((queue-lock queue) nil)
  23     (let ((vector (queue-vector queue)))
  24       (if (zerop (length vector))
  25           nil
  26           (vector-pop vector)))))
  27
  28 (defun queue-enqueue (queue value)
  29   (%with-lock ((queue-lock queue) nil)
  30     (vector-push-extend value (queue-vector queue))))
  31
  32 (defstruct (condition-variable
  33             (:constructor %make-condition-variable (name))
  34             ;; CONDITION-VARIABLE-P is defined in API-CONDITION-VARIABLES.LISP
  35             (:predicate nil))
  36   name
  37   (queue (make-queue)))
  38
  39 (defmethod print-object ((cv condition-variable) stream)
  40   (print-unreadable-object (cv stream :type t :identity t)
  41     (format stream "~S" (condition-variable-name cv))))
  42
  43 (defun %condition-wait (cv lock timeout)
  44   (with-slots (queue) cv
  45     (let* ((thread (current-thread))
  46            (semaphore (%thread-semaphore thread)))
  47       (queue-enqueue queue thread)
  48       (%release-lock lock)
  49       (unwind-protect
  50            (%wait-on-semaphore semaphore timeout)
  51         (%acquire-lock lock t nil)))))
  52
  53 (defun %condition-notify (cv)
  54   (with-slots (queue) cv
  55     (when-let ((next-thread (queue-dequeue queue)))
  56       (%signal-semaphore (%thread-semaphore next-thread) 1))))
  57
  58 (defun %condition-broadcast (cv)
  59   (with-slots (queue) cv
  60     (let ((queued-threads (queue-drain queue)))
  61       (map nil (lambda (thr)
  62                  (%signal-semaphore (%thread-semaphore thr) 1))
  63            queued-threads))))