Introduction
Introduction Statistics Contact Development Disclaimer Help
tbordeaux-threads-test.lisp - clic - Clic is an command line interactive client…
git clone git://bitreich.org/clic/ git://hg6vgqziawt5s4dj.onion/clic/
Log
Files
Refs
Tags
LICENSE
---
tbordeaux-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)))))
You are viewing proxied material from bitreich.org. The copyright of proxied material belongs to its original authors. Any comments or complaints in relation to proxied material should be directed to the original authors of the content concerned. Please see the disclaimer for more details.