impl-lispworks-condition-variables.lisp - clic - Clic is an command line intera… | |
git clone git://bitreich.org/clic/ git://enlrupgkhuxnvlhsf6lc3fziv5h2hhfrinws65… | |
Log | |
Files | |
Refs | |
Tags | |
README | |
LICENSE | |
--- | |
impl-lispworks-condition-variables.lisp (7140B) | |
--- | |
1 ;;;; -*- indent-tabs-mode: nil -*- | |
2 | |
3 (in-package #:bordeaux-threads) | |
4 | |
5 ;; Lispworks condition support is simulated, albeit via a lightweight wr… | |
6 ;; its own polling-based wait primitive. Waiters register with the cond… | |
7 ;; and use MP:process-wait which queries for permission to proceed at it… | |
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 no… | |
10 ;; on every poll (or have to serialize on the condition variable) and a … | |
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 b… | |
13 ;; case). Much of the complexity present is to support single notificat… | |
14 ;; the spec); but a distinct condition-notify-all is provided for refere… | |
15 ;; Single-notification follows a first-in first-out ordering | |
16 ;; | |
17 ;; Performance: With 1000 threads waiting on one condition-variable, th… | |
18 ;; as tested on a 3GHz Win32 box) is noise - hovering at 0% on Task mana… | |
19 ;; While not true zero like a true native solution, the use of the Lispw… | |
20 ;; fast enough to be an equivalent substitute (thread count will cause i… | |
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 :rea… | |
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… | |
29 ;; to someone else, and offender is removed from hash and list | |
30 (unconsumed-notifications (make-hash-table :test 'eq) :type hash-table… | |
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 … | |
43 ,@body))))) | |
44 | |
45 (defmacro defcvfun (function-name (condition-variable &rest args) &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… | |
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 (funcal… | |
67 (clrhash wait-hash) | |
68 (clrhash unconsumed-notifications) ; don't care as everyone just got … | |
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 … | |
108 (let ((wakeup-allowed-to-proceed nil) | |
109 (wakeup-lock (mp:make-lock :name "wakeup lock for condition-… | |
110 ;; wakeup-allowed-to-proceed is an optimisation to avoid having … | |
111 ;; search the hashtable. That it is locked is for safety/comple… | |
112 ;; as wakeup-allowed-to-proceed only transitions nil -> t, and t… | |
113 ;; moot in this situation, it would be redundant even if ever a … | |
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… | |
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-p… | |
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 proce… | |
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 b… | |
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… | |
138 (when (gethash id unconsumed-notifications) ; Must have e… | |
139 (remhash id unconsumed-notifications) ; Have to pass on… | |
140 (do-notify-single condition-variable))))))) | |
141 (mp:process-lock lock-)) | |
142 t) | |
143 | |
144 (define-condition-wait-compiler-macro) |