3rdparties/software/bordeaux-threads-v0.8.7/test/bordeaux-threads-test.lisp (9117 bytes)
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)))))