git.pond.sub.org Git - eow/blob - locked-queue.lisp

   1 (in-package :locked-queue)
   2
   3 (declaim (optimize (space 0) (speed 0) (safety 3) (debug 3)))
   4
   5 (defclass locked-queue ()
   6   ((queue :initform nil)
   7    (mutex :initform (sb-thread:make-mutex :name "queue lock"))
   8    (waitq :initform (make-waitqueue))))
   9
  10 (defun create ()
  11   (make-instance 'locked-queue))
  12
  13 (defmethod dequeue ((q locked-queue))
  14   (with-slots (queue mutex waitq) q
  15     (with-mutex (mutex)
  16       (loop while (or (null queue)
  17                       (null (first queue)))
  18            do (condition-wait waitq mutex))
  19       (prog1 (first (car queue))
  20         (setf (car queue)
  21               (rest (car queue)))))))
  22
  23 (defmethod dequeue-all ((q locked-queue))
  24   (with-slots (queue mutex waitq) q
  25     (with-mutex (mutex)
  26       (if (or (null queue)
  27               (null (first queue)))
  28           (condition-wait waitq mutex))
  29       (loop
  30          until (null (car queue))
  31          collect (car (car queue))
  32          do (setf (car queue) (rest (car queue)))))))
  33
  34 (defmethod enqueue ((q locked-queue) value)
  35   (with-slots (queue mutex waitq) q
  36     (with-mutex (mutex)
  37       (let ((last (list value)))
  38         (if (null (first queue))
  39             (progn
  40               (setf queue (cons last last))
  41               (condition-notify waitq))
  42             (progn
  43               (setf (rest (cdr queue)) last
  44                     (cdr queue) last)
  45               (cons (car queue) last)))))))