[Openmcl-devel] Semaphore troubles

[James M. Lawrence]

Is there anything incorrect about the code below? The function `test'
eventually fails at the first assertion, with `result' being `later'
rather than `sooner'. On my system (Linux Core-i7) the failure occurs
within 100 iterations.

The condition-wait function, which has been lifted directly from
bordeaux-threads, looks suspicious. What if ccl:signal-semaphore is
called during the time interval between the calls to ccl:release-lock
and ccl:wait-on-semaphore?

I don't see any CCL functions which take a semaphore and a lock. I
suppose I don't understand the CCL thread model? What is the proper
way to construct a blocking queue? Thanks in advance.

(I wrote a smaller test case without the queue, but I couldn't
reproduce the problem with it.)

ccl-1.8/lx86cl, md5 040409ba578edfa8b3dd62b009d57929

(defun condition-wait (cvar lock)
  (unwind-protect
       (progn
         (ccl:release-lock lock)
         (ccl:wait-on-semaphore cvar))
    (ccl:grab-lock lock)))

;;; raw-queue

(defun make-raw-queue ()
  (cons nil nil))

(defun push-raw-queue (value q)
  (let ((new (cons value nil)))
    (if (car q)
        (setf (cddr q) new)
        (setf (car  q) new))
    (setf (cdr q) new)))

(defun pop-raw-queue (q)
  (if (car q)
      (multiple-value-prog1 (values (caar q) t)
        (unless (setf (car q) (cdar q))
          ;; clear lingering ref
          (setf (cdr q) nil)))
      (values nil nil)))

;;; queue

(defstruct queue
  (impl (make-raw-queue))
  (lock (ccl:make-lock))
  (cvar (ccl:make-semaphore)))

(defun push-queue (object queue)
  (ccl:with-lock-grabbed ((queue-lock queue))
    (push-raw-queue object (queue-impl queue))
    (ccl:signal-semaphore (queue-cvar queue))))

(defun pop-queue (queue)
  (ccl:with-lock-grabbed ((queue-lock queue))
    (loop (multiple-value-bind (value presentp)
              (pop-raw-queue (queue-impl queue))
            (if presentp
                (return value)
                (condition-wait (queue-cvar queue)
                                (queue-lock queue)))))))

;;; run

(defun test ()
  (let ((tasks (make-queue)))
    (loop
       :repeat 2
       :do (ccl:process-run-function
            "test"
            (lambda ()
              (loop (funcall (or (pop-queue tasks)
                                 (return)))))))
    (let ((receiver (make-queue)))
      (push-queue (lambda ()
                    (push-queue (progn (sleep 0.2) 'later)
                                receiver))
                  tasks)
      (push-queue (lambda ()
                    (push-queue 'sooner receiver))
                  tasks)
      (let ((result (pop-queue receiver)))
        (assert (eq 'sooner result)))
      (let ((result (pop-queue receiver)))
        (assert (eq 'later result))))
    (push-queue nil tasks)
    (push-queue nil tasks))
  (format t "."))

(defun run ()
  (loop (test)))