PageRenderTime 72ms CodeModel.GetById 22ms app.highlight 45ms RepoModel.GetById 2ms app.codeStats 0ms

/tests/channels.lisp

http://github.com/sykopomp/chanl
Lisp | 227 lines | 194 code | 19 blank | 14 comment | 0 complexity | 400bf0f2fa3dd3f9954fc79bfaa75b47 MD5 | raw file
  1;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10; indent-tabs-mode: nil -*-
  2;;;;
  3;;;; Copyright © 2009 Kat Marchan, Adlai Chandrasekhar
  4;;;;
  5;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  6(in-package :chanl)
  7
  8(def-suite channels :in chanl)
  9(def-suite construction :in channels)
 10(in-suite construction)
 11
 12(test make-unbuffered
 13  (let ((chan (make-instance 'channel)))
 14    (is (channelp chan))
 15    (is (not (channel-buffered-p chan)))
 16    (is (= 0 (channel-readers chan)))
 17    (is (= 0 (channel-writers chan)))
 18    (is (eq *secret-unbound-value* (channel-value chan)))
 19    (is (send-blocks-p chan))
 20    (is (recv-blocks-p chan))
 21    ;; We don't really have predicates for these, but if they exist, we assume
 22    ;; they're what they're suposed to be.
 23    (is (channel-lock chan))
 24    (is (channel-send-ok chan))
 25    (is (channel-recv-ok chan))))
 26
 27#+ (or sbcl (and ccl (or x86 x86_64)))
 28(test make-cas
 29  (let ((chan (make-instance 'cas-channel)))
 30    (is (channelp chan))
 31    (is (not (channel-buffered-p chan)))
 32    (is (= 0 (channel-readers chan)))
 33    (is (= 0 (channel-writers chan)))
 34    (is (eq *secret-unbound-value* (channel-value chan)))
 35    (is (send-blocks-p chan))
 36    (is (recv-blocks-p chan))))
 37
 38(test make-stack
 39  (let ((chan (make-instance 'stack-channel)))
 40    (is (channelp chan))
 41    (is (channel-buffered-p chan))
 42    (is (null (channel-value chan)))
 43    (is (= 0 (channel-readers chan)))
 44    (is (= 0 (channel-writers chan)))
 45    (is (not (send-blocks-p chan)))
 46    (is (recv-blocks-p chan))
 47    ;; We don't really have predicates for these, but if they exist, we assume
 48    ;; they're what they're suposed to be.
 49    (is (channel-lock chan))
 50    (is (channel-send-ok chan))
 51    (is (channel-recv-ok chan))))
 52
 53(test make-bounded
 54  (let ((chan (make-instance 'bounded-channel :size 10)))
 55    (is (channelp chan))
 56    (is (channel-buffered-p chan))
 57    (is (queuep (channel-value chan)))
 58    (is (= 10 (queue-length (channel-value chan))))
 59    (is (= 0 (channel-readers chan)))
 60    (is (= 0 (channel-writers chan)))
 61    (is (not (send-blocks-p chan)))
 62    (is (recv-blocks-p chan))
 63    ;; We don't really have predicates for these, but if they exist, we assume
 64    ;; they're what they're suposed to be.
 65    (is (channel-lock chan))
 66    (is (channel-send-ok chan))
 67    (is (channel-recv-ok chan))))
 68
 69(test make-unbounded
 70  (let ((chan (make-instance 'unbounded-channel)))
 71    (is (channelp chan))
 72    (is (channel-buffered-p chan))
 73    (is (equal '(()) (channel-value chan)))
 74    (is (= 0 (channel-readers chan)))
 75    (is (= 0 (channel-writers chan)))
 76    (is (not (send-blocks-p chan)))
 77    (is (recv-blocks-p chan))
 78    ;; We don't really have predicates for these, but if they exist, we assume
 79    ;; they're what they're suposed to be.
 80    (is (channel-lock chan))
 81    (is (channel-send-ok chan))
 82    (is (channel-recv-ok chan))))
 83
 84(test make-invalid
 85  (signals error (make-instance 'buffered-channel :size nil))
 86  (signals error (make-instance 'buffered-channel :size -1)))
 87
 88(def-suite messaging :in channels)
 89(def-suite sending :in messaging)
 90(in-suite sending)
 91
 92(test send-unbuffered
 93  (let ((channel (make-instance 'channel)))
 94    (is (null (send channel 'test :blockp nil)))
 95    (pexec () (recv channel))
 96    (is (eq channel (send channel 'test)))
 97    (pexec () (recv channel))
 98    (is (eq channel (send channel 'test)))
 99    (pexec () (recv channel))
100    (sleep 0.5) ;hax to let the thread start working
101    (is (eq channel (send channel 'test :blockp nil)))))
102
103#+sbcl                                  ; FIXME! livelock on ccl
104(test send-cas
105  (let ((channel (make-instance 'cas-channel)))
106    (is (null (send channel 'test :blockp nil)))
107    (pexec () (recv channel))
108    (is (eq channel (send channel 'test)))
109    (pexec () (recv channel))
110    (is (eq channel (send channel 'test)))
111    (pexec () (recv channel))
112    (sleep 0.5)                         ; hax, wait for read-state
113    (is (eq channel (send channel 'test :blockp nil)))))
114
115(test send-buffered
116  (let ((channel (make-instance 'bounded-channel :size 1)))
117    (is (eq channel (send channel 'test :blockp nil)))
118    (recv channel)
119    (is (eq channel (send channel 'test)))
120    (is (null (send channel 'test :blockp nil)))
121    (pexec () (recv channel))
122    (is (eq channel (send channel 'test)))))
123
124(test send-sequence
125  (let ((channels (loop repeat 3 collect (make-instance 'channel))))
126    (is (null (send channels 'test :blockp nil)))
127    (pexec () (recv (elt channels 1)))
128    (is (eq (elt channels 1) (send channels 'test)))))
129
130(def-suite receiving :in messaging)
131(in-suite receiving)
132
133(test recv-unbuffered
134  (let ((channel (make-instance 'channel)))
135    (is (null (nth-value 1 (recv channel :blockp nil))))
136    (is (null (values (recv channel :blockp nil))))
137    (pexec () (send channel 'test))
138    (multiple-value-bind (value rec-chan)
139        (recv channel)
140      (is (eq channel rec-chan))
141      (is (eq 'test value)))
142    ;; repeat it just to make sure it doesn't fuck up the second time around
143    (pexec () (send channel 'test))
144    (multiple-value-bind (value rec-chan)
145        (recv channel)
146      (is (eq channel rec-chan))
147      (is (eq 'test value)))
148    (pexec () (send channel 'test))
149    (sleep 0.5)
150    (is (eq 'test (recv channel :blockp nil)))))
151
152(test recv-buffered
153  (let ((channel (make-instance 'bounded-channel :size 1)))
154    (is (null (recv channel :blockp nil)))
155    (is (null (nth-value 1 (recv channel :blockp nil))))
156    (send channel 'test)
157    (multiple-value-bind (value rec-chan)
158        (recv channel)
159      (is (eq channel rec-chan))
160      (is (eq 'test value)))
161    (is (null (recv channel :blockp nil)))
162    (is (null (nth-value 1 (recv channel :blockp nil))))
163    (pexec () (send channel 'test))
164    (is (eq 'test (recv channel)))))
165
166(test recv-sequence
167  (let ((channels (loop repeat 3 collect (make-instance 'channel))))
168    (is (null (recv channels :blockp nil)))
169    (is (null (nth-value 1 (recv channels :blockp nil))))
170    (pexec () (send (elt channels 1) 'test))
171    (multiple-value-bind (value rec-chan)
172        (recv channels)
173      (is (eq 'test value))
174      (is (eq (elt channels 1) rec-chan)))))
175
176(def-suite racing :in channels)
177(in-suite racing)
178
179(defun setup-race (thread-count class &rest channel-args)
180  (let ((lock (bt:make-lock "bt:semaphore")) (nrx 0) (ntx 0) start
181        (channel (apply #'make-instance class channel-args)))
182    (macrolet ((with-counter ((place) &body body)
183                 `(unwind-protect
184                       (progn (bt:with-lock-held (lock) (incf ,place)) ,@body)
185                    (bt:with-lock-held (lock) (decf ,place))))
186               (await (place) `(loop :until (= ,place thread-count))))
187      (flet ((recver () (with-counter (nrx) (recv channel)))
188             (sender (x)
189               (lambda ()
190                 (with-counter (ntx)
191                   (loop :until start :do (bt:thread-yield))
192                   (send channel x))))
193             (strcat (&rest things) (format () "~{~A~}" things)))
194        (let ((threads (loop :for n :below thread-count
195                          :collect (bt:make-thread #'recver :name (strcat "r" n))
196                          :collect (bt:make-thread (sender n) :name (strcat "s" n)))))
197          (await nrx) (await ntx) (setf start t)
198          (values threads channel))))))
199
200(test racing
201  (macrolet ((test-case (class count kind)
202               `(multiple-value-bind (threads channel) (setup-race ,count ',class)
203                  (let* ((pass nil)
204                         (verifier (pexec ()
205                                     (mapc #'bt:join-thread threads)
206                                     (setf pass t))))
207                    (sleep 5) (is (eq pass t)
208                                  (concatenate
209                                   'string ,(format () "count=~D, ~A" count kind)
210                                   (with-output-to-string (*standard-output*)
211                                     (format t "~%~%Contested Channel:~%")
212                                     (describe channel)
213                                     (format t "~%~%Competing Threads:~%")
214                                     (mapc 'describe
215                                           (remove () threads
216                                                   :key #'bt:thread-alive-p)))))
217                    (unless pass
218                      (mapc #'bt:destroy-thread
219                            (remove () threads
220                                    :key #'bt:thread-alive-p))
221                      (kill (task-thread verifier)))))))
222    (test-case channel 3 "unbuffered")
223    (test-case channel 6 "unbuffered")
224    (test-case channel 10 "unbuffered")
225    (test-case unbounded-channel 3 "unbounded")
226    (test-case unbounded-channel 6 "unbounded")
227    (test-case unbounded-channel 10 "unbounded")))