1 ;;;; -*- indent-tabs-mode: nil -*-
3 (in-package #:bordeaux-threads
)
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
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)))
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
))
32 (defun make-condition-variable (&key name
)
33 (make-lw-condition name
))
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
))
41 (macrolet ((locked (&body body
) `(mp:with-lock
(lock) ,@body
)))
42 (labels ((,(gensym) () ,@slots
))) ; Trigger expansion of the symbol-macrolets to ignore
45 (defmacro defcvfun
(function-name (condition-variable &rest args
) &body body
)
46 `(defun ,function-name
(,condition-variable
,@args
)
47 (with-cv-access ,condition-variable
49 #+lispworks
(editor:setup-indent
"defcvfun" 2 2 7) ; indent defcvfun
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
)))
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
))))
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)
66 (loop for waiter-wakeup being the hash-values in wait-hash do
(funcall waiter-wakeup
))
68 (clrhash unconsumed-notifications
) ; don't care as everyone just got notified
69 (setf (car wait-tlist
) nil
)
70 (setf (cdr wait-tlist
) nil
)))
72 ;; Currently implemented so as to notify only one waiting thread
73 (defcvfun condition-notify
(condition-variable)
74 (locked (do-notify-single condition-variable
)))
76 (defun delete-from-tlist (tlist element
)
79 (setf (car tlist
) (cdar tlist
))
81 (setf (cdr tlist
) nil
)))))
82 (loop for cons in
(car tlist
) do
83 (if (eq element
(car cons
))
90 (setf (cdr cons
) (cddr cons
))
92 (setf (cdr tlist
) cons
)))))))))
94 (defun add-to-tlist-tail (tlist element
)
95 (let ((new-link (cons element nil
)))
98 (setf (cddr tlist
) new-link
)
99 (setf (cdr tlist
) new-link
))
101 (setf (car tlist
) new-link
)
102 (setf (cdr tlist
) new-link
)))))
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
))
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
)))))
123 "Waiting for notification"
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
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-
))
144 (define-condition-wait-compiler-macro)