bordeaux-threads-test.lisp - clic - Clic is an command line interactive client for gopher written in Common LISP
(HTM) git clone git://bitreich.org/clic/ git://enlrupgkhuxnvlhsf6lc3fziv5h2hhfrinws65d7roiv6bfj7d652fid.onion/clic/
(DIR) Log
(DIR) Files
(DIR) Refs
(DIR) Tags
(DIR) README
(DIR) 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 implementations that
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" i))))))
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 proceeded" completed)))
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 completed waiters")))
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-lock)
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 restart")
196 (format t "Failure: Notify-single restarted ~A items" (length completed)))
197 (condition-notify condition-variable)
198 (sleep 2)
199 (if (= (length completed) 2)
200 (print "Success: second Notify-single only notified a single waiter to restart")
201 (format t "Failure: Two Notify-singles restarted ~A items" (length completed)))
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 outstanding waiting threads")
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)))))