From a64ef42cfb06bf300f20165fa4b0df505b24a52b Mon Sep 17 00:00:00 2001
From: "Tobias C. Rittweiler" <trittweiler@users.sourceforge.net>
Date: Tue, 30 Mar 2010 10:48:08 +0000
Subject: [PATCH] still 1.0.38.18; forgot to delete old sb-queue files.

---
 contrib/sb-queue/queue.lisp      |  162 -----------------------
 contrib/sb-queue/test-queue.lisp |  266 --------------------------------------
 2 files changed, 428 deletions(-)
 delete mode 100644 contrib/sb-queue/queue.lisp
 delete mode 100644 contrib/sb-queue/test-queue.lisp

diff --git a/contrib/sb-queue/queue.lisp b/contrib/sb-queue/queue.lisp
deleted file mode 100644
index dfe96b3..0000000
--- a/contrib/sb-queue/queue.lisp
+++ /dev/null
@@ -1,162 +0,0 @@
-;;;; Lock-free FIFO queues, from "An Optimistic Approach to Lock-Free FIFO
-;;;; Queues" by Edya Ladan-Mozes and Nir Shavit.
-;;;;
-;;;; Written by Nikodemus Siivola for SBCL.
-;;;;
-;;;; This software is part of the SBCL system. See the README file for
-;;;; more information.
-;;;;
-;;;; This software is derived from the CMU CL system, which was written at
-;;;; Carnegie Mellon University and released into the public domain. The
-;;;; software is in the public domain and is provided with absolutely no
-;;;; warranty. See the COPYING and CREDITS files for more information.
-
-(defpackage :sb-queue
-  (:use :cl :sb-thread :sb-sys :sb-ext)
-  (:export
-   "DEQUEUE"
-   "ENQUEUE"
-   "LIST-QUEUE-CONTENTS"
-   "MAKE-QUEUE"
-   "QUEUE"
-   "QUEUE-COUNT"
-   "QUEUE-EMPTY-P"
-   "QUEUE-NAME"
-   "QUEUEP"))
-
-(in-package :sb-queue)
-
-(defconstant +dummy+ '.dummy.)
-
-(declaim (inline make-node))
-(defstruct node
-  value
-  (prev nil :type (or null node))
-  (next nil :type (or null node)))
-
-(declaim (inline %make-queue))
-(defstruct (queue (:constructor %make-queue (head tail name))
-                  (:copier nil)
-                  (:predicate queuep))
-  "Lock-free thread safe queue. ENQUEUE can be used to add objects to the queue,
-and DEQUEUE retrieves items from the queue in FIFO order."
-  (head (error "No HEAD.") :type node)
-  (tail (error "No TAIL.") :type node)
-  (name nil))
-
-(setf (documentation 'queuep 'function)
-      "Returns true if argument is a QUEUE, NIL otherwise."
-      (documentation 'queue-name 'function)
-      "Name of a QUEUE. Can be assingned to using SETF. Queue names
-can be arbitrary printable objects, and need not be unique.")
-
-(defun make-queue (&key name initial-contents)
-  "Returns a new QUEUE with NAME and contents of the INITIAL-CONTENTS
-sequence enqueued."
-  (let* ((dummy (make-node :value +dummy+))
-         (queue (%make-queue dummy dummy name)))
-    (flet ((enc-1 (x)
-             (enqueue x queue)))
-      (declare (dynamic-extent #'enc-1))
-      (map nil #'enc-1 initial-contents))
-    queue))
-
-(defun enqueue (value queue)
-  "Adds VALUE to the end of QUEUE. Returns VALUE."
-  (let ((node (make-node :value value)))
-    (loop for tail = (queue-tail queue)
-          do (setf (node-next node) tail)
-             (when (eq tail (sb-ext:compare-and-swap (queue-tail queue) tail node))
-               (setf (node-prev tail) node)
-               (return value)))))
-
-(defun dequeue (queue)
-  "Retrieves the oldest value in QUEUE and returns it as the primary value,
-and T as secondary value. If the queue is empty, returns NIL as both primary
-and secondary value."
-  (tagbody
-   :continue
-     (let* ((head (queue-head queue))
-            (tail (queue-tail queue))
-            (first-node-prev (node-prev head))
-            (val (node-value head)))
-       (when (eq head (queue-head queue))
-         (cond ((not (eq val +dummy+))
-                (if (eq tail head)
-                    (let ((dummy (make-node :value +dummy+ :next tail)))
-                      (when (eq tail (sb-ext:compare-and-swap (queue-tail queue)
-                                                              tail dummy))
-                        (setf (node-prev head) dummy))
-                      (go :continue))
-                    (when (null first-node-prev)
-                      (fixList queue tail head)
-                      (go :continue)))
-                (when (eq head (sb-ext:compare-and-swap (queue-head queue)
-                                                        head first-node-prev))
-                  ;; This assignment is not present in the paper, but is
-                  ;; equivalent to the free(head.ptr) call there: it unlinks
-                  ;; the HEAD from the queue -- the code in the paper leaves
-                  ;; the dangling pointer in place.
-                  (setf (node-next first-node-prev) nil)
-                  (return-from dequeue (values val t))))
-               ((eq tail head)
-                (return-from dequeue (values nil nil)))
-               ((null first-node-prev)
-                (fixList queue tail head)
-                (go :continue))
-               (t
-                (sb-ext:compare-and-swap (queue-head queue)
-                                         head first-node-prev)))))
-     (go :continue)))
-
-(defun fixlist (queue tail head)
-  (let ((current tail))
-    (loop while (and (eq head (queue-head queue)) (not (eq current head)))
-          do (let ((next (node-next current)))
-               (when (not next)
-                 (return-from fixlist nil))
-               (let ((nextNodePrev (node-prev next)))
-                 (when (not (eq nextNodePrev current))
-                   (setf (node-prev next) current))
-                 (setf current next))))))
-
-(defun list-queue-contents (queue)
-  "Returns the contents of QUEUE as a list without removing them from the
-QUEUE. Mainly useful for manual examination of queue state."
-  (let (all)
-    (labels ((walk (node)
-               ;; Since NEXT pointers are always right, traversing from tail
-               ;; to head is safe.
-               (let ((value (node-value node))
-                     (next (node-next node)))
-                 (unless (eq +dummy+ value)
-                   (push value all))
-                 (when next
-                   (walk next)))))
-      (walk (queue-tail queue)))
-    all))
-
-(defun queue-count (queue)
-  "Returns the number of objects in QUEUE. Mainly useful for manual
-examination of queue state, and in PRINT-OBJECT methods: inefficient as it
-walks the entire queue."
-  (let ((n 0))
-    (declare (unsigned-byte n))
-    (labels ((walk (node)
-               (let ((value (node-value node))
-                     (next (node-next node)))
-                 (unless (eq +dummy+ value)
-                   (incf n))
-                 (when next
-                   (walk next)))))
-      (walk (queue-tail queue))
-      n)))
-
-(defun queue-empty-p (queue)
-  "Returns T if QUEUE is empty, NIL otherwise."
-  (let* ((head (queue-head queue))
-         (tail (queue-tail queue))
-         (val (node-value head)))
-    (and (eq head tail) (eq val +dummy+))))
-
-(provide :sb-queue)
diff --git a/contrib/sb-queue/test-queue.lisp b/contrib/sb-queue/test-queue.lisp
deleted file mode 100644
index 48b7b62..0000000
--- a/contrib/sb-queue/test-queue.lisp
+++ /dev/null
@@ -1,266 +0,0 @@
-;;;; This software is part of the SBCL system. See the README file for
-;;;; more information.
-;;;;
-;;;; This software is derived from the CMU CL system, which was written at
-;;;; Carnegie Mellon University and released into the public domain. The
-;;;; software is in the public domain and is provided with absolutely no
-;;;; warranty. See the COPYING and CREDITS files for more information.
-
-(defpackage :sb-queue-test
-  (:use :cl :sb-thread :sb-queue :sb-rt)
-  (:export))
-
-(in-package :sb-queue-test)
-
-(deftest queue.1
-    (let ((q (make-queue :name 'test-q :initial-contents '(1 2 3))))
-      (enqueue 4 q)
-      (values (queue-name q)
-              (multiple-value-list (dequeue q))
-              (list-queue-contents q)))
-  test-q
-  (1 t)
-  (2 3 4))
-
-(deftest queue.2
-    (dequeue (make-queue))
-  nil
-  nil)
-
-(deftest queue.3
-    (dequeue (make-queue :initial-contents '(nil)))
-  nil
-  t)
-
-(deftest queue.4
-    (let ((x (make-instance 'structure-object))
-          (y (make-queue)))
-      ;; I wonder why I thought this needs testing?
-      (values (typep x 'queue)
-              (queuep x)
-              (typep y 'queue)
-              (queuep y)))
-  nil nil t t)
-
-(deftest queue.5
-    (let ((q (make-queue :initial-contents (vector 1 2 3 4 5))))
-      (values (= 5 (queue-count q))
-              (enqueue 'foo q)
-              (= 6 (queue-count q))
-              (dequeue q)
-              (= 5 (queue-count q))
-              (dequeue q)
-              (= 4 (queue-count q))
-              (dequeue q)
-              (= 3 (queue-count q))
-              (dequeue q)
-              (= 2 (queue-count q))
-              (dequeue q)
-              (= 1 (queue-count q))
-              (not (queue-empty-p q))
-              (dequeue q)
-              (= 0 (queue-count q))
-              (queue-empty-p q)
-              (dequeue q)
-              (= 0 (queue-count q))
-              (queue-empty-p q)))
-  t
-  foo
-  t
-  1
-  t
-  2
-  t
-  3
-  t
-  4
-  t
-  5
-  t
-  t
-  foo
-  t
-  t
-  nil
-  t
-  t)
-
-#+sb-thread
-(deftest queue.t.1
-    (let* ((q (make-queue))
-           (w (make-semaphore))
-           (r (make-semaphore))
-           (n 100000)
-           (schedulers (list
-                        (make-thread (lambda ()
-                                       (signal-semaphore r)
-                                       (wait-on-semaphore w)
-                                       (dotimes (i n)
-                                         (enqueue (cons :a i) q))))
-                        (make-thread (lambda ()
-                                       (signal-semaphore r)
-                                       (wait-on-semaphore w)
-                                       (dotimes (i n)
-                                         (enqueue (cons :b i) q))))
-                        (make-thread (lambda ()
-                                       (signal-semaphore r)
-                                       (wait-on-semaphore w)
-                                       (dotimes (i n)
-                                         (enqueue (cons :c i) q))))
-                        (make-thread (lambda ()
-                                       (signal-semaphore r)
-                                       (wait-on-semaphore w)
-                                       (dotimes (i n)
-                                         (enqueue (cons :d i) q)))))))
-      (loop repeat 4 do (wait-on-semaphore r))
-      (signal-semaphore w 4)
-      (mapc #'join-thread schedulers)
-      (let (a b c d)
-        (loop
-          (multiple-value-bind (item ok) (dequeue q)
-            (cond (item
-                   (assert ok)
-                   (case (car item)
-                     (:a (push (cdr item) a))
-                     (:b (push (cdr item) b))
-                     (:c (push (cdr item) c))
-                     (:d (push (cdr item) d))))
-                  (t
-                   (assert (not ok))
-                   (return)))))
-        (labels ((check-list (list)
-                   (when list
-                     (if (cdr list)
-                         (when (= (first list) (1- (second list)))
-                           (check-list (cdr list)))
-                         (= (first list) (1- n))))))
-          (values (check-list (nreverse a))
-                  (check-list (nreverse b))
-                  (check-list (nreverse c))
-                  (check-list (nreverse d))))))
-  t
-  t
-  t
-  t)
-
-#+sb-thread
-(deftest queue.t.2
-    (let ((q (make-queue))
-          (w (make-semaphore))
-          (r (make-semaphore)))
-      (dotimes (i 1000000)
-        (enqueue i q))
-      (flet ((dq ()
-               (signal-semaphore r)
-               (wait-on-semaphore w)
-               (let ((last -1))
-                 (loop
-                   (multiple-value-bind (x ok) (dequeue q)
-                     (cond (x
-                            (if (and (> x last) ok)
-                                (setf last x)
-                                (return (list last x ok))))
-                           (t
-                            (if (not ok)
-                                (return t)
-                                (return (list last x ok))))))))))
-        (let ((deschedulers
-               (list (make-thread #'dq)
-                     (make-thread #'dq)
-                     (make-thread #'dq)
-                     (make-thread #'dq))))
-          (loop repeat 4 do (wait-on-semaphore r))
-          (signal-semaphore w 4)
-          (mapcar #'join-thread deschedulers))))
-  (t t t t))
-
-#+sb-thread
-(deftest queue.t.3
-    (let* ((q (make-queue))
-           (w (make-semaphore))
-           (r (make-semaphore))
-           (n 100000)
-           (schedulers (list
-                        (make-thread (lambda ()
-                                       (signal-semaphore r)
-                                       (wait-on-semaphore w)
-                                       (dotimes (i n)
-                                         (enqueue (cons :a i) q))))
-                        (make-thread (lambda ()
-                                       (signal-semaphore r)
-                                       (wait-on-semaphore w)
-                                       (dotimes (i n)
-                                         (enqueue (cons :b i) q))))
-                        (make-thread (lambda ()
-                                       (signal-semaphore r)
-                                       (wait-on-semaphore w)
-                                       (dotimes (i n)
-                                         (enqueue (cons :c i) q))))
-                        (make-thread (lambda ()
-                                       (signal-semaphore r)
-                                       (wait-on-semaphore w)
-                                       (dotimes (i n)
-                                         (enqueue (cons :d i) q)))))))
-      (flet ((dq ()
-               (let ((a -1)
-                     (ac 0)
-                     (b -1)
-                     (bc 0)
-                     (c -1)
-                     (cc 0)
-                     (d -1)
-                     (dc 0))
-                 (signal-semaphore r)
-                 (wait-on-semaphore w)
-                 (loop (multiple-value-bind (item ok) (dequeue q)
-                         (cond (item
-                                (let ((n (cdr item)))
-                                  (macrolet ((test (name c)
-                                               `(if (< ,name n)
-                                                    (progn
-                                                      (setf ,name n)
-                                                      (incf ,c))
-                                                    (return nil))))
-                                    (ecase (car item)
-                                      (:a (test a ac))
-                                      (:b (test b bc))
-                                      (:c (test c cc))
-                                      (:d (test d dc))))))
-                               (t
-                                (assert (not ok))
-                                (unless (or (some #'thread-alive-p schedulers)
-                                            (not (queue-empty-p q)))
-                                  (return (list a ac b bc c cc d dc))))))))))
-        (let ((deschedulers (list
-                             (make-thread #'dq)
-                             (make-thread #'dq)
-                             (make-thread #'dq)
-                             (make-thread #'dq))))
-          (loop repeat 8 do (wait-on-semaphore r))
-          (signal-semaphore w 8)
-          (let ((a -1)
-                (ac 0)
-                (b -1)
-                (bc 0)
-                (c -1)
-                (cc 0)
-                (d -1)
-                (dc 0))
-            (mapc (lambda (th)
-                    (let ((results (join-thread th)))
-                      (when results
-                        (destructuring-bind (ta tac tb tbc tc tcc td tdc) results
-                          (setf a (max ta a)
-                                b (max tb b)
-                                c (max tc c)
-                                d (max td d))
-                          (incf ac tac)
-                          (incf bc tbc)
-                          (incf cc tcc)
-                          (incf dc tdc)))))
-                  deschedulers)
-            (and (= n ac (1+ a))
-                 (= n bc (1+ b))
-                 (= n cc (1+ c))
-                 (= n dc (1+ d)))))))
-  t)
-- 
1.7.10.4