tests/threads.pure.lisp

   1 ;;;; miscellaneous tests of thread stuff
   2
   3 ;;;; This software is part of the SBCL system. See the README file for
   4 ;;;; more information.
   5 ;;;;
   6 ;;;; While most of SBCL is derived from the CMU CL system, the test
   7 ;;;; files (like this one) were written from scratch after the fork
   8 ;;;; from CMU CL.
   9 ;;;
  10 ;;;; This software is in the public domain and is provided with
  11 ;;;; absoluely no warranty. See the COPYING and CREDITS files for
  12 ;;;; more information.
  13
  14 (in-package :cl-user)
  15
  16 (defpackage :thread-test
  17   (:use :cl :sb-thread))
  18
  19 (in-package :thread-test)
  20
  21 (use-package :test-util)
  22
  23 ;;; Terminating a thread that's waiting for the terminal.
  24
  25 #+sb-thread
  26 (let ((thread (make-thread (lambda ()
  27                              (sb-thread::get-foreground)))))
  28   (sleep 1)
  29   (assert (thread-alive-p thread))
  30   (terminate-thread thread)
  31   (sleep 1)
  32   (assert (not (thread-alive-p thread))))
  33
  34 ;;; Condition-wait should not be interruptible under WITHOUT-INTERRUPTS
  35
  36 #+sb-thread
  37 (with-test (:name without-interrupts+condition-wait
  38             :fails-on :sb-lutex)
  39   (let* ((lock (make-mutex))
  40          (queue (make-waitqueue))
  41          (thread (make-thread (lambda ()
  42                                 (sb-sys:without-interrupts
  43                                   (with-mutex (lock)
  44                                     (condition-wait queue lock)))))))
  45     (sleep 1)
  46     (assert (thread-alive-p thread))
  47     (terminate-thread thread)
  48     (sleep 1)
  49     (assert (thread-alive-p thread))
  50     (condition-notify queue)
  51     (sleep 1)
  52     (assert (not (thread-alive-p thread)))))
  53
  54 ;;; GET-MUTEX should not be interruptible under WITHOUT-INTERRUPTS
  55
  56 #+sb-thread
  57 (with-test (:name without-interrupts+get-mutex)
  58   (let* ((lock (make-mutex))
  59          (bar (progn (get-mutex lock) nil))
  60          (thread (make-thread (lambda ()
  61                                 (sb-sys:without-interrupts
  62                                     (with-mutex (lock)
  63                                       (setf bar t)))))))
  64     (sleep 1)
  65     (assert (thread-alive-p thread))
  66     (terminate-thread thread)
  67     (sleep 1)
  68     (assert (thread-alive-p thread))
  69     (release-mutex lock)
  70     (sleep 1)
  71     (assert (not (thread-alive-p thread)))
  72     (assert (eq :aborted (join-thread thread :default :aborted)))
  73     (assert bar)))
  74
  75 #+sb-thread
  76 (with-test (:name parallel-find-class)
  77   (let* ((oops nil)
  78          (threads (loop repeat 10
  79                         collect (make-thread (lambda ()
  80                                                (handler-case
  81                                                    (loop repeat 10000
  82                                                          do (find-class (gensym) nil))
  83                                                  (serious-condition ()
  84                                                    (setf oops t))))))))
  85     (mapcar #'sb-thread:join-thread threads)
  86     (assert (not oops))))
  87
  88 #+sb-thread
  89 (with-test (:name :semaphore-multiple-waiters)
  90   (let ((semaphore (make-semaphore :name "test sem")))
  91     (labels ((make-readers (n i)
  92                (values
  93                 (loop for r from 0 below n
  94                       collect
  95                       (let ((r r))
  96                         (sb-thread:make-thread (lambda ()
  97                                                  (let ((sem semaphore))
  98                                                    (dotimes (s i)
  99                                                      (sb-thread:wait-on-semaphore sem))))
 100                                                :name "reader")))
 101                 (* n i)))
 102              (make-writers (n readers i)
 103                (let ((j (* readers i)))
 104                  (multiple-value-bind (k rem) (truncate j n)
 105                    (values
 106                     (let ((writers
 107                            (loop for w from 0 below n
 108                                  collect
 109                                  (let ((w w))
 110                                    (sb-thread:make-thread (lambda ()
 111                                                             (let ((sem semaphore))
 112                                                               (dotimes (s k)
 113                                                                 (sb-thread:signal-semaphore sem))))
 114                                                           :name "writer")))))
 115                       (assert (zerop rem))
 116                       writers)
 117                     (+ rem (* n k))))))
 118              (test (r w n)
 119                (multiple-value-bind (readers x) (make-readers r n)
 120                  (assert (= (length readers) r))
 121                  (multiple-value-bind (writers y) (make-writers w r n)
 122                    (assert (= (length writers) w))
 123                    (assert (= x y))
 124                    (mapc #'sb-thread:join-thread writers)
 125                    (mapc #'sb-thread:join-thread readers)
 126                    (assert (zerop (sb-thread:semaphore-count semaphore)))
 127                    (values)))))
 128       (assert
 129        (eq :ok
 130            (handler-case
 131                (sb-ext:with-timeout 10
 132                  (test 1 1 100)
 133                  (test 2 2 10000)
 134                  (test 4 2 10000)
 135                  (test 4 2 10000)
 136                  (test 10 10 10000)
 137                  (test 10 1 10000)
 138                  :ok)
 139              (sb-ext:timeout ()
 140                :timeout)))))))
 141