contrib/sb-queue/test-queue.lisp

   1 ;;;; This software is part of the SBCL system. See the README file for
   2 ;;;; more information.
   3 ;;;;
   4 ;;;; This software is derived from the CMU CL system, which was written at
   5 ;;;; Carnegie Mellon University and released into the public domain. The
   6 ;;;; software is in the public domain and is provided with absolutely no
   7 ;;;; warranty. See the COPYING and CREDITS files for more information.
   8
   9 (defpackage :sb-queue-test
  10   (:use :cl :sb-thread :sb-queue :sb-rt)
  11   (:export))
  12
  13 (in-package :sb-queue-test)
  14
  15 (deftest queue.1
  16     (let ((q (make-queue :name 'test-q :initial-contents '(1 2 3))))
  17       (enqueue 4 q)
  18       (values (queue-name q)
  19               (multiple-value-list (dequeue q))
  20               (list-queue-contents q)))
  21   test-q
  22   (1 t)
  23   (2 3 4))
  24
  25 (deftest queue.2
  26     (dequeue (make-queue))
  27   nil
  28   nil)
  29
  30 (deftest queue.3
  31     (dequeue (make-queue :initial-contents '(nil)))
  32   nil
  33   t)
  34
  35 (deftest queue.4
  36     (let ((x (make-instance 'structure-object))
  37           (y (make-queue)))
  38       ;; I wonder why I thought this needs testing?
  39       (values (typep x 'queue)
  40               (queuep x)
  41               (typep y 'queue)
  42               (queuep y)))
  43   nil nil t t)
  44
  45 (deftest queue.5
  46     (let ((q (make-queue :initial-contents (vector 1 2 3 4 5))))
  47       (values (= 5 (queue-count q))
  48               (enqueue 'foo q)
  49               (= 6 (queue-count q))
  50               (dequeue q)
  51               (= 5 (queue-count q))
  52               (dequeue q)
  53               (= 4 (queue-count q))
  54               (dequeue q)
  55               (= 3 (queue-count q))
  56               (dequeue q)
  57               (= 2 (queue-count q))
  58               (dequeue q)
  59               (= 1 (queue-count q))
  60               (not (queue-empty-p q))
  61               (dequeue q)
  62               (= 0 (queue-count q))
  63               (queue-empty-p q)
  64               (dequeue q)
  65               (= 0 (queue-count q))
  66               (queue-empty-p q)))
  67   t
  68   foo
  69   t
  70   1
  71   t
  72   2
  73   t
  74   3
  75   t
  76   4
  77   t
  78   5
  79   t
  80   t
  81   foo
  82   t
  83   t
  84   nil
  85   t
  86   t)
  87
  88 #+sb-thread
  89 (deftest queue.t.1
  90     (let* ((q (make-queue))
  91            (w (make-semaphore))
  92            (r (make-semaphore))
  93            (n 100000)
  94            (schedulers (list
  95                         (make-thread (lambda ()
  96                                        (signal-semaphore r)
  97                                        (wait-on-semaphore w)
  98                                        (dotimes (i n)
  99                                          (enqueue (cons :a i) q))))
 100                         (make-thread (lambda ()
 101                                        (signal-semaphore r)
 102                                        (wait-on-semaphore w)
 103                                        (dotimes (i n)
 104                                          (enqueue (cons :b i) q))))
 105                         (make-thread (lambda ()
 106                                        (signal-semaphore r)
 107                                        (wait-on-semaphore w)
 108                                        (dotimes (i n)
 109                                          (enqueue (cons :c i) q))))
 110                         (make-thread (lambda ()
 111                                        (signal-semaphore r)
 112                                        (wait-on-semaphore w)
 113                                        (dotimes (i n)
 114                                          (enqueue (cons :d i) q)))))))
 115       (loop repeat 4 do (wait-on-semaphore r))
 116       (signal-semaphore w 4)
 117       (mapc #'join-thread schedulers)
 118       (let (a b c d)
 119         (loop
 120           (multiple-value-bind (item ok) (dequeue q)
 121             (cond (item
 122                    (assert ok)
 123                    (case (car item)
 124                      (:a (push (cdr item) a))
 125                      (:b (push (cdr item) b))
 126                      (:c (push (cdr item) c))
 127                      (:d (push (cdr item) d))))
 128                   (t
 129                    (assert (not ok))
 130                    (return)))))
 131         (labels ((check-list (list)
 132                    (when list
 133                      (if (cdr list)
 134                          (when (= (first list) (1- (second list)))
 135                            (check-list (cdr list)))
 136                          (= (first list) (1- n))))))
 137           (values (check-list (nreverse a))
 138                   (check-list (nreverse b))
 139                   (check-list (nreverse c))
 140                   (check-list (nreverse d))))))
 141   t
 142   t
 143   t
 144   t)
 145
 146 #+sb-thread
 147 (deftest queue.t.2
 148     (let ((q (make-queue))
 149           (w (make-semaphore))
 150           (r (make-semaphore)))
 151       (dotimes (i 1000000)
 152         (enqueue i q))
 153       (flet ((dq ()
 154                (signal-semaphore r)
 155                (wait-on-semaphore w)
 156                (let ((last -1))
 157                  (loop
 158                    (multiple-value-bind (x ok) (dequeue q)
 159                      (cond (x
 160                             (if (and (> x last) ok)
 161                                 (setf last x)
 162                                 (return (list last x ok))))
 163                            (t
 164                             (if (not ok)
 165                                 (return t)
 166                                 (return (list last x ok))))))))))
 167         (let ((deschedulers
 168                (list (make-thread #'dq)
 169                      (make-thread #'dq)
 170                      (make-thread #'dq)
 171                      (make-thread #'dq))))
 172           (loop repeat 4 do (wait-on-semaphore r))
 173           (signal-semaphore w 4)
 174           (mapcar #'join-thread deschedulers))))
 175   (t t t t))
 176
 177 #+sb-thread
 178 (deftest queue.t.3
 179     (let* ((q (make-queue))
 180            (w (make-semaphore))
 181            (r (make-semaphore))
 182            (n 100000)
 183            (schedulers (list
 184                         (make-thread (lambda ()
 185                                        (signal-semaphore r)
 186                                        (wait-on-semaphore w)
 187                                        (dotimes (i n)
 188                                          (enqueue (cons :a i) q))))
 189                         (make-thread (lambda ()
 190                                        (signal-semaphore r)
 191                                        (wait-on-semaphore w)
 192                                        (dotimes (i n)
 193                                          (enqueue (cons :b i) q))))
 194                         (make-thread (lambda ()
 195                                        (signal-semaphore r)
 196                                        (wait-on-semaphore w)
 197                                        (dotimes (i n)
 198                                          (enqueue (cons :c i) q))))
 199                         (make-thread (lambda ()
 200                                        (signal-semaphore r)
 201                                        (wait-on-semaphore w)
 202                                        (dotimes (i n)
 203                                          (enqueue (cons :d i) q)))))))
 204       (flet ((dq ()
 205                (let ((a -1)
 206                      (ac 0)
 207                      (b -1)
 208                      (bc 0)
 209                      (c -1)
 210                      (cc 0)
 211                      (d -1)
 212                      (dc 0))
 213                  (signal-semaphore r)
 214                  (wait-on-semaphore w)
 215                  (loop (multiple-value-bind (item ok) (dequeue q)
 216                          (cond (item
 217                                 (let ((n (cdr item)))
 218                                   (macrolet ((test (name c)
 219                                                `(if (< ,name n)
 220                                                     (progn
 221                                                       (setf ,name n)
 222                                                       (incf ,c))
 223                                                     (return nil))))
 224                                     (ecase (car item)
 225                                       (:a (test a ac))
 226                                       (:b (test b bc))
 227                                       (:c (test c cc))
 228                                       (:d (test d dc))))))
 229                                (t
 230                                 (assert (not ok))
 231                                 (unless (or (some #'thread-alive-p schedulers)
 232                                             (not (queue-empty-p q)))
 233                                   (return (list a ac b bc c cc d dc))))))))))
 234         (let ((deschedulers (list
 235                              (make-thread #'dq)
 236                              (make-thread #'dq)
 237                              (make-thread #'dq)
 238                              (make-thread #'dq))))
 239           (loop repeat 8 do (wait-on-semaphore r))
 240           (signal-semaphore w 8)
 241           (let ((a -1)
 242                 (ac 0)
 243                 (b -1)
 244                 (bc 0)
 245                 (c -1)
 246                 (cc 0)
 247                 (d -1)
 248                 (dc 0))
 249             (mapc (lambda (th)
 250                     (let ((results (join-thread th)))
 251                       (when results
 252                         (destructuring-bind (ta tac tb tbc tc tcc td tdc) results
 253                           (setf a (max ta a)
 254                                 b (max tb b)
 255                                 c (max tc c)
 256                                 d (max td d))
 257                           (incf ac tac)
 258                           (incf bc tbc)
 259                           (incf cc tcc)
 260                           (incf dc tdc)))))
 261                   deschedulers)
 262             (and (= n ac (1+ a))
 263                  (= n bc (1+ b))
 264                  (= n cc (1+ c))
 265                  (= n dc (1+ d)))))))
 266   t)