src/impl-lispworks-condition-variables.lisp

   1 ;;;; -*- indent-tabs-mode: nil -*-
   2
   3 (in-package #:bordeaux-threads)
   4
   5 ;; Lispworks condition support is simulated, albeit via a lightweight wrapper over
   6 ;; its own polling-based wait primitive.  Waiters register with the condition variable,
   7 ;; and use MP:process-wait which queries for permission to proceed at its own (usspecified) interval.
   8 ;; http://www.lispworks.com/documentation/lw51/LWRM/html/lwref-445.htm
   9 ;; A wakeup callback (on notify) is provided to lighten this query to not have to do a hash lookup
  10 ;; on every poll (or have to serialize on the condition variable) and a mechanism is put
  11 ;; in place to unregister any waiter that exits wait for other reasons,
  12 ;; and to resend any (single) notification that may have been consumed before this (corner
  13 ;; case).  Much of the complexity present is to support single notification (as recommended in
  14 ;; the spec); but a distinct condition-notify-all is provided for reference.
  15 ;; Single-notification follows a first-in first-out ordering
  16 ;;
  17 ;; Performance:  With 1000 threads waiting on one condition-variable, the steady-state hit (at least
  18 ;; as tested on a 3GHz Win32 box) is noise - hovering at 0% on Task manager.
  19 ;; While not true zero like a true native solution, the use of the Lispworks native checks appear
  20 ;; fast enough to be an equivalent substitute (thread count will cause issue before the
  21 ;; waiting overhead becomes significant)
  22 (defstruct (condition-variable (:constructor make-lw-condition (name)))
  23   name
  24   (lock (mp:make-lock :name "For condition-variable") :type mp:lock :read-only t)
  25   (wait-tlist (cons nil nil) :type cons :read-only t)
  26   (wait-hash (make-hash-table :test 'eq) :type hash-table :read-only t)
  27   ;; unconsumed-notifications is to track :remove-from-consideration
  28   ;; for entries that may have exited prematurely - notification is sent through
  29   ;; to someone else, and offender is removed from hash and list
  30   (unconsumed-notifications (make-hash-table :test 'eq) :type hash-table :read-only t))
  31
  32 (defun make-condition-variable (&key name)
  33   (make-lw-condition name))
  34
  35 (defmacro with-cv-access (condition-variable &body body)
  36   (let ((cv-sym (gensym))
  37         (slots '(lock wait-tlist wait-hash unconsumed-notifications)))
  38     `(let ((,cv-sym ,condition-variable))
  39        (with-slots ,slots
  40            ,cv-sym
  41          (macrolet ((locked (&body body) `(mp:with-lock (lock) ,@body)))
  42            (labels ((,(gensym) () ,@slots))) ; Trigger expansion of the symbol-macrolets to ignore
  43            ,@body)))))
  44
  45 (defmacro defcvfun (function-name (condition-variable &rest args) &body body)
  46   `(defun ,function-name (,condition-variable ,@args)
  47      (with-cv-access ,condition-variable
  48        ,@body)))
  49 #+lispworks (editor:setup-indent "defcvfun" 2 2 7) ; indent defcvfun
  50
  51 ; utility function thath assumes process is locked on condition-variable's lock.
  52 (defcvfun do-notify-single (condition-variable) ; assumes already locked
  53   (let ((id (caar wait-tlist)))
  54     (when id
  55       (pop (car wait-tlist))
  56       (unless (car wait-tlist) ; check for empty
  57         (setf (cdr wait-tlist) nil))
  58       (funcall (gethash id wait-hash)) ; call waiter-wakeup
  59       (remhash id wait-hash) ; absence of entry = permission to proceed
  60       (setf (gethash id unconsumed-notifications) t))))
  61
  62 ;; Added for completeness/to show how it's done in this paradigm; but
  63 ;; The symbol for this call is not exposed in the api
  64 (defcvfun condition-notify-all (condition-variable)
  65   (locked
  66    (loop for waiter-wakeup being the hash-values in wait-hash do (funcall waiter-wakeup))
  67    (clrhash wait-hash)
  68    (clrhash unconsumed-notifications) ; don't care as everyone just got notified
  69    (setf (car wait-tlist) nil)
  70    (setf (cdr wait-tlist) nil)))
  71
  72 ;; Currently implemented so as to notify only one waiting thread
  73 (defcvfun condition-notify (condition-variable)
  74   (locked (do-notify-single condition-variable)))
  75
  76 (defun delete-from-tlist (tlist element)
  77   (let ((deleter
  78          (lambda ()
  79            (setf (car tlist) (cdar tlist))
  80            (unless (car tlist)
  81              (setf (cdr tlist) nil)))))
  82     (loop for cons in (car tlist) do
  83           (if (eq element (car cons))
  84               (progn
  85                 (funcall deleter)
  86                 (return nil))
  87             (let ((cons cons))
  88               (setq deleter
  89                     (lambda ()
  90                       (setf (cdr cons) (cddr cons))
  91                       (unless (cdr cons)
  92                         (setf (cdr tlist) cons)))))))))
  93
  94 (defun add-to-tlist-tail (tlist element)
  95   (let ((new-link (cons element nil)))
  96     (cond
  97      ((car tlist)
  98       (setf (cddr tlist) new-link)
  99       (setf (cdr tlist) new-link))
 100      (t
 101       (setf (car tlist) new-link)
 102       (setf (cdr tlist) new-link)))))
 103
 104 (defcvfun condition-wait (condition-variable lock- &key timeout)
 105   (signal-error-if-condition-wait-timeout timeout)
 106   (mp:process-unlock lock-)
 107   (unwind-protect ; for the re-taking of the lock.  Guarding all of the code
 108       (let ((wakeup-allowed-to-proceed nil)
 109             (wakeup-lock (mp:make-lock :name "wakeup lock for condition-wait")))
 110         ;; wakeup-allowed-to-proceed is an optimisation to avoid having to serialize all waiters and
 111         ;; search the hashtable.  That it is locked is for safety/completeness, although
 112         ;; as wakeup-allowed-to-proceed only transitions nil -> t, and that missing it once or twice is
 113         ;; moot in this situation, it would be redundant even if ever a Lispworks implementation ever became
 114         ;; non-atomic in its assigments
 115         (let ((id (cons nil nil))
 116               (clean-exit nil))
 117           (locked
 118            (add-to-tlist-tail wait-tlist id)
 119            (setf (gethash id wait-hash) (lambda () (mp:with-lock (wakeup-lock) (setq wakeup-allowed-to-proceed t)))))
 120           (unwind-protect
 121               (progn
 122                 (mp:process-wait
 123                  "Waiting for notification"
 124                  (lambda ()
 125                    (when (mp:with-lock (wakeup-lock) wakeup-allowed-to-proceed)
 126                      (locked (not (gethash id wait-hash))))))
 127                 (locked (remhash id unconsumed-notifications))
 128                 (setq clean-exit t)) ; Notification was consumed
 129             ;; Have to call remove-from-consideration just in case process was interrupted
 130             ;; rather than having condition met
 131             (unless clean-exit ; clean-exit is just an optimization
 132               (locked
 133                (when (gethash id wait-hash) ; not notified - must have been interrupted
 134                  ;; Have to unsubscribe
 135                  (remhash id wait-hash)
 136                  (delete-from-tlist wait-tlist id))
 137                ;; note - it's possible to be removed from wait-hash/wait-tlist (in notify-single); but still have an unconsumed notification!
 138                (when (gethash id unconsumed-notifications) ; Must have exited for reasons unrelated to notification
 139                  (remhash id unconsumed-notifications) ; Have to pass on the notification to an eligible waiter
 140                  (do-notify-single condition-variable)))))))
 141     (mp:process-lock lock-))
 142   t)
 143
 144 (define-condition-wait-compiler-macro)