From: Matthew D S. <ak...@ch...> - 2005-12-20 07:14:44
|
Far=E9 wrote: >>19/12/05, pv...@pv... <pv...@pv...> wrote: >>As suggested by Xof on #lisp, you probably want to use a (singly) linke= d >>list with a pointer to the tail to implement your queue (since it gives= an >>efficient TCONC). >=20 > I have such an implementation of fifo queues in fare-utils. All you > need to do to make it thread-safe is wrap every function that access > it in a lock-grabbing form. >=20 Below is a second try with Fare's library code. >=20 >>I don't know if/how SBCL exposes compare-and-swap and other primitives, >>but there are relatively simple lock-free or wait-free algorithms for >>queues.=20 Looks interesting, but I currently don't know enough about lock-free=20 algorithms to confidently use it as an implementation technique. Waiting (and perhaps locking), however, seems to be a fundamental=20 characteristic of mailbox style communication; synchronization happens=20 when attempting to read from an empty mailbox. If a thread goes into a=20 wait state on a read, it needs to be rescheduled when a message is=20 available. Waitqueues (which I currently use to implement this=20 behavior) require a lock. I chose to keep the concurrency issues separate from the fifo=20 implementation. Anyway here it is: (in-package :sb-thread) ;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;fifo by Fare Rideau. (defstruct fifo (head nil) (tail nil)) (defun fifo-empty-p (fifo) (declare (type fifo fifo)) (null (fifo-head fifo))) (defun fifo-peek (fifo) (declare (type fifo fifo)) "Return the head of the queue without dequeuing it." (when (fifo-head fifo) (car (fifo-head fifo)))) (defun fifo-enqueue (obj fifo) (declare (type fifo fifo)) "Enqueue an object in a fifo. Return the fifo." (let ((last (cons obj nil))) (if (null (fifo-head fifo)) (setf (fifo-head fifo) last) (setf (cdr (fifo-tail fifo)) last)) (setf (fifo-tail fifo) last)) fifo) (defun fifo-dequeue (fifo) (declare (type fifo fifo)) "Dequeue an object. Return the object dequeued." (when (fifo-head fifo) (prog1 (pop (fifo-head fifo)) (when (null (fifo-head fifo)) (setf (fifo-tail fifo) nil))))) (defun fifo-nconc2 (fifo1 fifo2) (declare (type fifo fifo1 fifo2)) "move objects from fifo1 to head of fifo2" (psetf (fifo-head fifo1) nil (fifo-tail fifo1) nil (fifo-head fifo2) (nconc (fifo-head fifo1) (fifo-head fifo2)) (fifo-tail fifo2) (or (fifo-tail fifo2) (fifo-tail fifo1))) fifo2) (defun fifo-dequeue-object (obj fifo) (declare (type fifo fifo)) (loop with buffer =3D (make-fifo) with top =3D nil until (fifo-empty-p fifo) do (setf top (fifo-dequeue fifo)) until (eql obj top) do (fifo-enqueue top buffer) finally (return (fifo-nconc2 buffer fifo)))) (defstruct mailbox (fifo (make-fifo) :type fifo) (waitqueue (make-waitqueue) :type waitqueue) (lock (make-mutex) :type mutex)) (defun mailbox-empty-p (mailbox) (declare (type mailbox mailbox)) (let ((lock (mailbox-lock mailbox))) (with-mutex (lock) (fifo-empty-p (mailbox-fifo mailbox))))) (defun mailbox-send (mailbox object) (declare (type mailbox mailbox)) (let ((lock (mailbox-lock mailbox)) (waitqueue (mailbox-waitqueue mailbox))) (with-mutex (lock) (fifo-enqueue object (mailbox-fifo mailbox)) (condition-broadcast waitqueue)))) (defun mailbox-peek (mailbox) (declare (type mailbox mailbox)) (let ((lock (mailbox-lock mailbox)) (waitqueue (mailbox-waitqueue mailbox))) (with-mutex (lock) (loop (if (fifo-empty-p (mailbox-fifo mailbox)) (condition-wait waitqueue lock) (return))) (fifo-peek (mailbox-fifo mailbox))))) (defun mailbox-read (mailbox) (declare (type mailbox mailbox)) (let ((lock (mailbox-lock mailbox)) (waitqueue (mailbox-waitqueue mailbox))) (with-mutex (lock) (loop (if (fifo-empty-p (mailbox-fifo mailbox)) (condition-wait waitqueue lock) (return))) (fifo-dequeue (mailbox-fifo mailbox))))) Matt --=20 "You do not really understand something unless you can explain it to=20 your grandmother." =97 Albert Einstein. |