Re: [Sbcl-devel] A first pass at a mailbox implementation for sbcl

[Matthew D S. <ak...@ch...>]

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.