Custom Query (1030 matches)

(defun test (thread-count)
  (let ((threads (loop repeat thread-count
                       collect (ccl:process-run-function
                                "test" (lambda ())))))
    ;;(sleep 0.01)
    (mapc #'ccl:process-kill threads)))

(defun run ()
  (loop
     (assert (find "Initial" (ccl:all-processes)
                   :key #'ccl:process-name
                   :test #'string=))
     (test 10)
     (format t ".")))

The assertion fails within 100 iterations on dx86cl64, dx86cl, and lx86cl. With the SLEEP call I did not see a failure for 20k iterations.

(defun run-server (host port out)
  (with-open-stream (server (ccl:make-socket :connect :passive
                                             :local-host host
                                             :local-port port
                                             :reuse-address t))
    (with-open-stream (stream (ccl:accept-connection server))
      (format out "~s~%" (read stream))
      (print :pong stream)
      (finish-output stream))))

(defun make-socket/retry (host port tries)
  (loop (handler-case (return (ccl:make-socket :remote-host host
                                               :remote-port port))
          (ccl:socket-creation-error (err)
            (unless (plusp (decf tries)) (error err))
            (format t "retry~%")
            (sleep 0.1)))))

(defun test (host port)
  (ccl:process-run-function "server" #'run-server
                            host port *standard-output*)
  ;(sleep 0.001)
  (with-open-stream (stream (make-socket/retry host port 5))
    (print :ping stream)
    (finish-output stream)
    (format t "~s~%" (read stream))))

(defun run ()
  (loop for port from 10000 to 20000 do (test "localhost" port)))

Failure happens within three iterations on my machine.

retry
:PING
:PONG
retry
> Error: on #<CCL::LISTENER-SOCKET #x1866FB36> : 
>        Bad file descriptor (error #9) during accept
> While executing: SOCKET-ERROR, in process server(3).

or

retry
:PING
:PONG
retry
> Error: Bad file descriptor (error #9) during socket creation operation in bind
> While executing: SOCKET-ERROR, in process server(3).

or

retry
:PING
:PONG
retry
:PING
:PONG
retry
> Error: Bad file descriptor (error #9) during socket creation operation in listen
> While executing: SOCKET-ERROR, in process server(4).

Adding the SLEEP call after PROCESS-RUN-FUNCTION prevents all errors.

Tested on 1.9-dev-r15576M-trunk (LinuxX8632). Failure on Darwin has happened but is very rare; I've only seen it twice.

I can work around this issue by handling/retrying, however CCL is the only implementation which requires this special attention.

(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)))