Ticket #1058 (closed defect: fixed)
Stress test failure with conditional-store
|Reported by:||jlawrence||Owned by:||gb|
|Component:||Runtime (threads, GC)||Version:||trunk|
(This assumes ccl::conditional-store should work even though it's not officially supported.)
The RUN function below eventually hangs on Linux and Darwin. On 32-bit it generally hangs sooner. The time until hanging decreases as the thread count increases. The number of threads reported by ccl:all-processes is relatively constant, and hanging still occurs with a 2-second sleep added to the loop.
Unfortunately I could not reproduce with a CAS-based stack, and CAS spin locks have been fixed (#1030), which leaves us with the more complex CAS queue. I hope the implementation below is straightforward enough. I'm confident that it is correct, so please double-check before blaming the queue. I've included SBCL support for reference (it runs on SBCL without a problem).
#+ccl (defmacro conditional-store (&rest args) `(ccl::conditional-store ,@args)) #+sbcl (eval-when (:compile-toplevel :load-toplevel :execute) (import '(sb-thread:make-semaphore sb-thread:signal-semaphore sb-thread:wait-on-semaphore)) (defmacro conditional-store (place old new) (check-type old symbol) `(eq ,old (sb-ext:compare-and-swap ,place ,old ,new))) (defun process-run-function (name function) (sb-thread:make-thread function :name name))) ;;;; queue ;;; The following invariants hold except during lag across threads: ;;; ;;; (node-cdr (queue-tail queue)) == nil ;;; ;;; If the queue is empty, (queue-head queue) == (queue-tail queue). ;;; ;;; If the queue is non-empty, (node-car (node-cdr (queue-head queue))) ;;; is the next value to be dequeued and (node-car (queue-tail queue)) ;;; is the most recently enqueued value. (defstruct (node (:constructor make-node (car cdr))) (car (error "no car")) (cdr (error "no cdr"))) (defstruct (queue (:constructor %make-queue (head tail))) (head (error "no head")) (tail (error "no tail"))) (defconstant +dummy+ 'dummy) (defun make-queue () (let ((dummy (make-node +dummy+ nil))) (%make-queue dummy dummy))) (defun enqueue (value queue) (let ((new (make-node value nil))) (loop (when (conditional-store (node-cdr (queue-tail queue)) nil new) (setf (queue-tail queue) new) (return value))))) (defun dequeue (queue) (loop (let* ((head (queue-head queue)) (next (node-cdr head))) (cond ((null next) (return (values nil nil))) ((eq next +dummy+)) ; try again ((conditional-store (queue-head queue) head next) (let ((result (node-car next))) (setf (node-cdr head) +dummy+ (node-car head) +dummy+) (return (values result t)))))))) ;;;; test (defun test (message-count thread-count) (let ((queue (make-queue))) (loop repeat thread-count do (process-run-function "test" (lambda () (loop repeat message-count do (enqueue :hello queue)) (enqueue :done queue)))) (loop with done-count = 0 until (and (eq :done (dequeue queue)) (= (incf done-count) thread-count))))) (defun run () (loop (test 10000 64) (format t ".") (finish-output)))