New diffs - I added "name" to make-condition-variable to match the spec. (defun make-condition-variable (&key name) . . . .)
Matt Lamari wrote:
We had a conversation on this a while back.
Same code (as we discussed), diffed against the latest.
The unit-test still passes.
ASD file has to be modded to remove a clash with the default condition-var struct
Attached are the diff files - I hope they are in the right form. I'd like to get this code out there - please let me know if any changes are required.
--- ..\bordeaux-threads_new\bordeaux-threads.asd 2009-12-24 19:35:44.000000000 -0600 +++ bordeaux-threads.asd 2009-12-29 23:21:40.637166200 -0600 @@ -53,7 +53,8 @@ #-thread-support "unsupported") (:file "default-implementations") #+(and thread-support - (or armedbear digitool ecl lispworks)) + (or armedbear digitool ecl) + (not lispworks)) (:file "condition-variables")))) :in-order-to ((test-op (load-op bordeaux-threads-test))) :perform (test-op :after (op c)
--- ..\bordeaux-threads_new\src\impl-lispworks.lisp 2009-12-24 19:35:44.000000000 -0600 +++ src\impl-lispworks.lisp 2009-12-30 10:04:34.464140700 -0600 @@ -68,4 +68,194 @@ (mp:process-wait (format nil "Waiting for thread ~A to complete" thread) (complement #'mp:process-alive-p) thread))
+ + + + +; Lispworks condition support is simulated, albeit via a lightweight wrapper over +; its own polling-based wait primitive. Waiters register with the condition variable, +; and use MP:process-wait which queries for permission to proceed at its own (usspecified) interval. +; http://www.lispworks.com/documentation/lw51/LWRM/html/lwref-445.htm +; A wakeup callback (on notify) is provided to lighten this query to not have to do a hash lookup +; on every poll (or have to serialize on the condition variable) and a mechanism is put +; in place to unregister any waiter that exits wait for other reasons, +; and to resend any (single) notification that may have been consumed before this (corner +; case). Much of the complexity present is to support single notification (as recommended in +; the spec); but a distinct condition-notify-all is provided for reference. +; Single-notification follows a first-in first-out ordering +; +; Performance: With 1000 threads waiting on one condition-variable, the steady-state hit (at least +; as tested on a 3GHz Win32 box) is noise - hovering at 0% on Task manager. +; While not true zero like a true native solution, the use of the Lispworks native checks appear +; fast enough to be an equivalent substitute (thread count will cause issue before the +; waiting overhead becomes significant) +(defstruct (condition-variable (:constructor make-lw-condition (name))) + name + (lock (mp:make-lock :name "For condition-variable") :type mp:lock :read-only t) + (wait-tlist (cons nil nil) :type cons :read-only t) + (wait-hash (make-hash-table :test 'eq) :type hash-table :read-only t) + ; unconsumed-notifications is to track :remove-from-consideration + ; for entries that may have exited prematurely - notification is sent through + ; to someone else, and offender is removed from hash and list + (unconsumed-notifications (make-hash-table :test 'eq) :type hash-table :read-only t)) + +(defun make-condition-variable (&key name) + (make-lw-condition name)) + +(defmacro with-cv-access (condition-variable &body body) + (let ((cv-sym (gensym)) + (slots '(lock wait-tlist wait-hash unconsumed-notifications))) + `(let ((,cv-sym ,condition-variable)) + (with-slots ,slots + ,cv-sym + (macrolet ((locked (&body body) `(mp:with-lock (lock) ,@body))) + (labels ((,(gensym) () ,@slots))) ; Trigger expansion of the symbol-macrolets to ignore + ,@body))))) + +(defmacro defcvfun (function-name (condition-variable &rest args) &body body) + `(defun ,function-name (,condition-variable ,@args) + (with-cv-access ,condition-variable + ,@body))) +#+lispworks (editor:setup-indent "defcvfun" 2 2 7) ; indent defcvfun + +; utility function thath assumes process is locked on condition-variable's lock. +(defcvfun do-notify-single (condition-variable) ; assumes already locked + (let ((id (caar wait-tlist))) + (when id + (pop (car wait-tlist)) + (unless (car wait-tlist) ; check for empty + (setf (cdr wait-tlist) nil)) + (funcall (gethash id wait-hash)) ; call waiter-wakeup + (remhash id wait-hash) ; absence of entry = permission to proceed + (setf (gethash id unconsumed-notifications) t)))) + +; Added for completeness/to show how it's done in this paradigm; but +; The symbol for this call is not exposed in the api +(defcvfun condition-notify-all (condition-variable) + (locked + (loop for waiter-wakeup being the hash-values in wait-hash do (funcall waiter-wakeup)) + (clrhash wait-hash) + (clrhash unconsumed-notifications) ; don't care as everyone just got notified + (setf (car wait-tlist) nil) + (setf (cdr wait-tlist) nil))) + +; Currently implemented so as to notify only one waiting thread +(defcvfun condition-notify (condition-variable) + (locked (do-notify-single condition-variable))) + + + +(defun delete-from-tlist (tlist element) + (let ((deleter + (lambda () + (setf (car tlist) (cdar tlist)) + (unless (car tlist) + (setf (cdr tlist) nil))))) + (loop for cons in (car tlist) do + (if (eq element (car cons)) + (progn + (funcall deleter) + (return nil)) + (let ((cons cons)) + (setq deleter + (lambda () + (setf (cdr cons) (cddr cons)) + (unless (cdr cons) + (setf (cdr tlist) cons))))))))) + +(defun add-to-tlist-tail (tlist element) + (let ((new-link (cons element nil))) + (cond + ((car tlist) + (setf (cddr tlist) new-link) + (setf (cdr tlist) new-link)) + (t + (setf (car tlist) new-link) + (setf (cdr tlist) new-link))))) + +(defcvfun condition-wait (condition-variable lock-) + (mp:process-unlock lock-) + (unwind-protect ; for the re-taking of the lock. Guarding all of the code + (let ((wakeup-allowed-to-proceed nil) + (wakeup-lock (mp:make-lock :name "wakeup lock for condition-wait"))) + ; wakeup-allowed-to-proceed is an optimisation to avoid having to serialize all waiters and + ; search the hashtable. That it is locked is for safety/completeness, although + ; as wakeup-allowed-to-proceed only transitions nil -> t, and that missing it once or twice is + ; moot in this situation, it would be redundant even if ever a Lispworks implementation ever became + ; non-atomic in its assigments + (let ((id (cons nil nil)) + (clean-exit nil)) + (locked + (add-to-tlist-tail wait-tlist id) + (setf (gethash id wait-hash) (lambda () (mp:with-lock (wakeup-lock) (setq wakeup-allowed-to-proceed t))))) + (unwind-protect + (progn + (mp:process-wait + "Waiting for notification" + (lambda () + (when (mp:with-lock (wakeup-lock) wakeup-allowed-to-proceed) + (locked (not (gethash id wait-hash)))))) + (locked (remhash id unconsumed-notifications)) + (setq clean-exit t)) ; Notification was consumed + ; Have to call remove-from-consideration just in case process was interrupted + ; rather than having condition met + (unless clean-exit ; clean-exit is just an optimization + (locked + (when (gethash id wait-hash) ; not notified - must have been interrupted + ; Have to unsubscribe + (remhash id wait-hash) + (delete-from-tlist wait-tlist id)) + ; note - it's possible to be removed from wait-hash/wait-tlist (in notify-single); but still have an unconsumed notification! + (when (gethash id unconsumed-notifications) ; Must have exited for reasons unrelated to notification + (remhash id unconsumed-notifications) ; Have to pass on the notification to an eligible waiter + (do-notify-single condition-variable))))))) + (mp:process-lock lock-))) + + +; Generally safe sanity check for the locks and single-notify +(defun unit-test-lw-conditions () + (let ((condition-variable (make-condition-variable :name "Test")) + (test-lock (make-lock)) + (completed nil)) + (loop for id from 0 to 5 do + (let ((id id)) + (make-thread (lambda () (with-lock-held (test-lock) (condition-wait condition-variable test-lock) (push id completed) (condition-notify condition-variable)))))) + (sleep 2) + (if completed + (print "Failed: Premature passage through condition-wait") + (print "Successfully waited on condition")) + (condition-notify condition-variable) + (sleep 2) + (if (and completed (eql (length completed) 6) (equal (sort completed #'<) (loop for id from 0 to 5 collect id))) + (print "Success: All elements notified") + (print (format nil "Failed: Of 6 expected elements, only ~A proceeded" completed))) + (with-cv-access condition-variable + (if (and + (not (or (car wait-tlist) (cdr wait-tlist))) + (zerop (hash-table-count wait-hash)) + (zerop (hash-table-count unconsumed-notifications))) + (print "Success: condition variable restored to initial state") + (print "Error: condition variable retains residue from completed waiters"))) + + (setq completed nil) + (loop for id from 0 to 5 do + (let ((id id)) + (make-thread (lambda () (with-lock-held (test-lock) (condition-wait condition-variable test-lock) (push id completed)))))) + (sleep 2) + (condition-notify condition-variable) + (sleep 2) + (if (= (length completed) 1) + (print "Success: Notify-single only notified a single waiter to restart") + (print (format nil "Failure: Notify-single restarted ~A items" (length completed)))) + (condition-notify condition-variable) + (sleep 2) + (if (= (length completed) 2) + (print "Success: second Notify-single only notified a single waiter to restart") + (print (format nil "Failure: Two Notify-singles restarted ~A items" (length completed)))) + (loop for i from 0 to 5 do (condition-notify condition-variable)) + (print "Note: In the case of any failures, assume there are outstanding waiting threads") + (values))) + + + (mark-supported)