test/tests-v1.lisp

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