apiv2/api-semaphores.lisp

   1 ;;;; -*- Mode: LISP; Syntax: ANSI-Common-lisp; Base: 10; Package: BORDEAUX-THREADS-2 -*-
   2 ;;;; The above modeline is required for Genera. Do not change.
   3
   4 (in-package :bordeaux-threads-2)
   5
   6 #-(or abcl allegro ccl ecl lispworks mezzano sbcl)
   7 (defstruct (%semaphore
   8             (:constructor %make-semaphore (name counter)))
   9   name counter
  10   (lock               (make-lock))
  11   (condition-variable (%make-condition-variable nil)))
  12
  13 #-(or abcl allegro ccl ecl lispworks mezzano sbcl)
  14 (deftype semaphore () '%semaphore)
  15
  16 (defun make-semaphore (&key name (count 0))
  17   "Create a semaphore with the supplied NAME and initial counter value COUNT."
  18   (check-type name (or null string))
  19   (%make-semaphore name count))
  20
  21 #-(or abcl allegro ccl ecl lispworks mezzano sbcl)
  22 (defun %signal-semaphore (semaphore count)
  23   (with-lock-held ((%semaphore-lock semaphore))
  24     (incf (%semaphore-counter semaphore) count)
  25     (dotimes (v count)
  26       (%condition-notify (%semaphore-condition-variable semaphore)))))
  27
  28 (defun signal-semaphore (semaphore &key (count 1))
  29   "Increment SEMAPHORE by COUNT. If there are threads waiting on this
  30 semaphore, then COUNT of them are woken up."
  31   (%signal-semaphore semaphore count)
  32   t)
  33
  34 #-(or abcl allegro ccl ecl lispworks mezzano sbcl)
  35 (defun %wait-on-semaphore (semaphore timeout)
  36   (with-lock-held ((%semaphore-lock semaphore))
  37     (if (plusp (%semaphore-counter semaphore))
  38         (decf (%semaphore-counter semaphore))
  39         (let ((deadline (when timeout
  40                           (+ (get-internal-real-time)
  41                              (* timeout internal-time-units-per-second)))))
  42           ;; we need this loop because of a spurious wakeup possibility
  43           (loop until (plusp (%semaphore-counter semaphore))
  44                 do (cond
  45                      ((null (%condition-wait
  46                              (%semaphore-condition-variable semaphore)
  47                              (lock-native-lock (%semaphore-lock semaphore))
  48                              timeout))
  49                       (return-from %wait-on-semaphore))
  50                      ;; unfortunately cv-wait may return T on timeout too
  51                      ((and deadline (>= (get-internal-real-time) deadline))
  52                       (return-from %wait-on-semaphore))
  53                      (timeout
  54                       (setf timeout (/ (- deadline (get-internal-real-time))
  55                                        internal-time-units-per-second)))))
  56           (decf (%semaphore-counter semaphore))))
  57     ;; Semaphore acquired.
  58     t))
  59
  60 (defun wait-on-semaphore (semaphore &key timeout)
  61   "Decrement the count of SEMAPHORE by 1 if the count is larger than zero.
  62
  63 If count is zero, blocks until the semaphore can be decremented.
  64 Returns generalized boolean T on success.
  65
  66 If TIMEOUT is given, it is the maximum number of seconds to wait. If the count
  67 cannot be decremented in that time, returns NIL without decrementing the count."
  68   (%wait-on-semaphore semaphore timeout))
  69
  70 (defun semaphorep (object)
  71   "Returns T if OBJECT is a semaphore, otherwise NIL."
  72   (typep object 'semaphore))