bordeaux-threads-test.lisp - clic - Clic is an command line interactive client … | |
git clone git://bitreich.org/clic/ git://enlrupgkhuxnvlhsf6lc3fziv5h2hhfrinws65… | |
Log | |
Files | |
Refs | |
Tags | |
README | |
LICENSE | |
--- | |
bordeaux-threads-test.lisp (9117B) | |
--- | |
1 #| | |
2 Copyright 2006,2007 Greg Pfeil | |
3 | |
4 Distributed under the MIT license (see LICENSE file) | |
5 |# | |
6 | |
7 (defpackage bordeaux-threads/test | |
8 (:use #:cl #:bordeaux-threads #:fiveam) | |
9 (:shadow #:with-timeout)) | |
10 | |
11 (in-package #:bordeaux-threads/test) | |
12 | |
13 (def-suite :bordeaux-threads) | |
14 (def-fixture using-lock () | |
15 (let ((lock (make-lock))) | |
16 (&body))) | |
17 (in-suite :bordeaux-threads) | |
18 | |
19 (test should-have-current-thread | |
20 (is (current-thread))) | |
21 | |
22 (test current-thread-identity | |
23 (let* ((box (list nil)) | |
24 (thread (make-thread (lambda () | |
25 (setf (car box) (current-thread)))))) | |
26 (join-thread thread) | |
27 (is (eql (car box) thread)))) | |
28 | |
29 (test join-thread-return-value | |
30 (is (eql 0 (join-thread (make-thread (lambda () 0)))))) | |
31 | |
32 (test should-identify-threads-correctly | |
33 (is (threadp (current-thread))) | |
34 (is (threadp (make-thread (lambda () t) :name "foo"))) | |
35 (is (not (threadp (make-lock))))) | |
36 | |
37 (test should-retrieve-thread-name | |
38 (is (equal "foo" (thread-name (make-thread (lambda () t) :name "foo"))… | |
39 | |
40 (test interrupt-thread | |
41 (let* ((box (list nil)) | |
42 (thread (make-thread (lambda () | |
43 (setf (car box) | |
44 (catch 'new-thread | |
45 (sleep 60) | |
46 'not-interrupted)))))) | |
47 (sleep 1) | |
48 (interrupt-thread thread (lambda () | |
49 (throw 'new-thread 'interrupted))) | |
50 (join-thread thread) | |
51 (is (eql 'interrupted (car box))))) | |
52 | |
53 (test should-lock-without-contention | |
54 (with-fixture using-lock () | |
55 (is (acquire-lock lock t)) | |
56 (release-lock lock) | |
57 (is (acquire-lock lock nil)) | |
58 (release-lock lock))) | |
59 | |
60 (defun set-equal (set-a set-b) | |
61 (and (null (set-difference set-a set-b)) | |
62 (null (set-difference set-b set-a)))) | |
63 | |
64 (test default-special-bindings | |
65 (locally (declare (special *a* *c*)) | |
66 (let* ((the-as 50) (the-bs 150) (*b* 42) | |
67 some-a some-b some-other-a some-other-b | |
68 (*default-special-bindings* | |
69 `((*a* . (funcall ,(lambda () (incf the-as)))) | |
70 (*b* . (funcall ,(lambda () (incf the-bs)))) | |
71 ,@*default-special-bindings*)) | |
72 (threads (list (make-thread | |
73 (lambda () | |
74 (setf some-a *a* some-b *b*))) | |
75 (make-thread | |
76 (lambda () | |
77 (setf some-other-a *a* | |
78 some-other-b *b*)))))) | |
79 (declare (special *b*)) | |
80 (thread-yield) | |
81 (is (not (boundp '*a*))) | |
82 (loop while (some #'thread-alive-p threads) | |
83 do (thread-yield)) | |
84 (is (set-equal (list some-a some-other-a) '(51 52))) | |
85 (is (set-equal (list some-b some-other-b) '(151 152))) | |
86 (is (not (boundp '*a*)))))) | |
87 | |
88 | |
89 (defparameter *shared* 0) | |
90 (defparameter *lock* (make-lock)) | |
91 | |
92 (test should-have-thread-interaction | |
93 ;; this simple test generates N process. Each process grabs and | |
94 ;; releases the lock until SHARED has some value, it then | |
95 ;; increments SHARED. the outer code first sets shared 1 which | |
96 ;; gets the thing running and then waits for SHARED to reach some | |
97 ;; value. this should, i think, stress test locks. | |
98 (setf *shared* 0) | |
99 (flet ((worker (i) | |
100 (loop | |
101 do (with-lock-held (*lock*) | |
102 (when (= i *shared*) | |
103 (incf *shared*) | |
104 (return))) | |
105 (thread-yield) | |
106 (sleep 0.001)))) | |
107 (let* ((procs (loop | |
108 for i from 1 upto 2 | |
109 ;; create a new binding to protect against implement… | |
110 ;; mutate instead of binding the loop variable | |
111 collect (let ((i i)) | |
112 (make-thread (lambda () | |
113 (funcall #'worker i)) | |
114 :name (format nil "Proc #~D" … | |
115 (with-lock-held (*lock*) | |
116 (incf *shared*)) | |
117 (block test | |
118 (loop | |
119 until (with-lock-held (*lock*) | |
120 (= (1+ (length procs)) *shared*)) | |
121 do (with-lock-held (*lock*) | |
122 (is (>= (1+ (length procs)) *shared*))) | |
123 (thread-yield) | |
124 (sleep 0.001)))))) | |
125 | |
126 | |
127 (defparameter *condition-variable* (make-condition-variable)) | |
128 | |
129 (test condition-variable | |
130 (setf *shared* 0) | |
131 (flet ((worker (i) | |
132 (with-lock-held (*lock*) | |
133 (loop | |
134 until (= i *shared*) | |
135 do (condition-wait *condition-variable* *lock*)) | |
136 (incf *shared*)) | |
137 (condition-notify *condition-variable*))) | |
138 (let ((num-procs 100)) | |
139 (dotimes (i num-procs) | |
140 ;; create a new binding to protect against implementations that | |
141 ;; mutate instead of binding the loop variable | |
142 (let ((i i)) | |
143 (make-thread (lambda () | |
144 (funcall #'worker i)) | |
145 :name (format nil "Proc #~D" i)))) | |
146 (with-lock-held (*lock*) | |
147 (loop | |
148 until (= num-procs *shared*) | |
149 do (condition-wait *condition-variable* *lock*))) | |
150 (is (equal num-procs *shared*))))) | |
151 | |
152 ;; Generally safe sanity check for the locks and single-notify | |
153 #+(and lispworks (not lispworks6)) | |
154 (test condition-variable-lw | |
155 (let ((condition-variable (make-condition-variable :name "Test")) | |
156 (test-lock (make-lock)) | |
157 (completed nil)) | |
158 (dotimes (id 6) | |
159 (let ((id id)) | |
160 (make-thread (lambda () | |
161 (with-lock-held (test-lock) | |
162 (condition-wait condition-variable test-lock) | |
163 (push id completed) | |
164 (condition-notify condition-variable)))))) | |
165 (sleep 2) | |
166 (if completed | |
167 (print "Failed: Premature passage through condition-wait") | |
168 (print "Successfully waited on condition")) | |
169 (condition-notify condition-variable) | |
170 (sleep 2) | |
171 (if (and completed | |
172 (eql (length completed) 6) | |
173 (equal (sort completed #'<) | |
174 (loop for id from 0 to 5 collect id))) | |
175 (print "Success: All elements notified") | |
176 (print (format nil "Failed: Of 6 expected elements, only ~A proc… | |
177 (bt::with-cv-access condition-variable | |
178 (if (and | |
179 (not (or (car wait-tlist) (cdr wait-tlist))) | |
180 (zerop (hash-table-count wait-hash)) | |
181 (zerop (hash-table-count unconsumed-notifications))) | |
182 (print "Success: condition variable restored to initial state") | |
183 (print "Error: condition variable retains residue from complet… | |
184 (setq completed nil) | |
185 (dotimes (id 6) | |
186 (let ((id id)) | |
187 (make-thread (lambda () | |
188 (with-lock-held (test-lock) | |
189 (condition-wait condition-variable test-loc… | |
190 (push id completed)))))) | |
191 (sleep 2) | |
192 (condition-notify condition-variable) | |
193 (sleep 2) | |
194 (if (= (length completed) 1) | |
195 (print "Success: Notify-single only notified a single waiter to … | |
196 (format t "Failure: Notify-single restarted ~A items" (length co… | |
197 (condition-notify condition-variable) | |
198 (sleep 2) | |
199 (if (= (length completed) 2) | |
200 (print "Success: second Notify-single only notified a single wai… | |
201 (format t "Failure: Two Notify-singles restarted ~A items" (leng… | |
202 (loop for i from 0 to 5 do (condition-notify condition-variable)) | |
203 (print "Note: In the case of any failures, assume there are outstan… | |
204 (values))) | |
205 | |
206 #+(or abcl allegro clisp clozure ecl lispworks6 sbcl scl) | |
207 (test condition-wait-timeout | |
208 (let ((lock (make-lock)) | |
209 (cvar (make-condition-variable)) | |
210 (flag nil)) | |
211 (make-thread (lambda () (sleep 0.4) (setf flag t))) | |
212 (with-lock-held (lock) | |
213 (condition-wait cvar lock :timeout 0.2) | |
214 (is (null flag)) | |
215 (sleep 0.4) | |
216 (is (eq t flag))))) | |
217 | |
218 (test semaphore-signal | |
219 (let ((sem (make-semaphore))) | |
220 (make-thread (lambda () (sleep 0.4) (signal-semaphore sem))) | |
221 (is (not (null (wait-on-semaphore sem)))))) | |
222 | |
223 (test semaphore-signal-n-of-m | |
224 (let* ((sem (make-semaphore :count 1)) | |
225 (lock (make-lock)) | |
226 (count 0) | |
227 (waiter (lambda () | |
228 (wait-on-semaphore sem) | |
229 (with-lock-held (lock) (incf count))))) | |
230 (make-thread (lambda () (sleep 0.2) (signal-semaphore sem :count 3))) | |
231 (dotimes (v 5) (make-thread waiter)) | |
232 (sleep 0.3) | |
233 (is (= count 4)) | |
234 ;; release other waiters | |
235 (signal-semaphore sem :count 10) | |
236 (sleep 0.1) | |
237 (is (= count 5)))) | |
238 | |
239 (test semaphore-wait-timeout | |
240 (let ((sem (make-semaphore)) | |
241 (flag nil)) | |
242 (make-thread (lambda () (sleep 0.4) (setf flag t))) | |
243 (is (null (wait-on-semaphore sem :timeout 0.2))) | |
244 (is (null flag)) | |
245 (sleep 0.4) | |
246 (is (eq t flag)))) | |
247 | |
248 (test semaphore-typed | |
249 (is (typep (bt:make-semaphore) 'bt:semaphore)) | |
250 (is (bt:semaphore-p (bt:make-semaphore))) | |
251 (is (null (bt:semaphore-p (bt:make-lock))))) |