1.0.23.21: Stack allocated conses for MIPS.
[sbcl.git] / 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 (with-test (:name mutex-owner)
24   ;; Make sure basics are sane on unithreaded ports as well
25   (let ((mutex (make-mutex)))
26     (get-mutex mutex)
27     (assert (eq *current-thread* (mutex-value mutex)))
28     (handler-bind ((warning #'error))
29       (release-mutex mutex))
30     (assert (not (mutex-value mutex)))))
31
32 (with-test (:name spinlock-owner)
33   ;; Make sure basics are sane on unithreaded ports as well
34   (let ((spinlock (sb-thread::make-spinlock)))
35     (sb-thread::get-spinlock spinlock)
36     (assert (eq *current-thread* (sb-thread::spinlock-value spinlock)))
37     (handler-bind ((warning #'error))
38       (sb-thread::release-spinlock spinlock))
39     (assert (not (sb-thread::spinlock-value spinlock)))))
40
41 ;;; Terminating a thread that's waiting for the terminal.
42
43 #+sb-thread
44 (let ((thread (make-thread (lambda ()
45                              (sb-thread::get-foreground)))))
46   (sleep 1)
47   (assert (thread-alive-p thread))
48   (terminate-thread thread)
49   (sleep 1)
50   (assert (not (thread-alive-p thread))))
51
52 ;;; Condition-wait should not be interruptible under WITHOUT-INTERRUPTS
53
54 #+sb-thread
55 (with-test (:name without-interrupts+condition-wait
56             :fails-on :sb-lutex)
57   (let* ((lock (make-mutex))
58          (queue (make-waitqueue))
59          (thread (make-thread (lambda ()
60                                 (sb-sys:without-interrupts
61                                   (with-mutex (lock)
62                                     (condition-wait queue lock)))))))
63     (sleep 1)
64     (assert (thread-alive-p thread))
65     (terminate-thread thread)
66     (sleep 1)
67     (assert (thread-alive-p thread))
68     (condition-notify queue)
69     (sleep 1)
70     (assert (not (thread-alive-p thread)))))
71
72 ;;; GET-MUTEX should not be interruptible under WITHOUT-INTERRUPTS
73
74 #+sb-thread
75 (with-test (:name without-interrupts+get-mutex)
76   (let* ((lock (make-mutex))
77          (bar (progn (get-mutex lock) nil))
78          (thread (make-thread (lambda ()
79                                 (sb-sys:without-interrupts
80                                     (with-mutex (lock)
81                                       (setf bar t)))))))
82     (sleep 1)
83     (assert (thread-alive-p thread))
84     (terminate-thread thread)
85     (sleep 1)
86     (assert (thread-alive-p thread))
87     (release-mutex lock)
88     (sleep 1)
89     (assert (not (thread-alive-p thread)))
90     (assert (eq :aborted (join-thread thread :default :aborted)))
91     (assert bar)))
92
93 #+sb-thread
94 (with-test (:name parallel-find-class)
95   (let* ((oops nil)
96          (threads (loop repeat 10
97                         collect (make-thread (lambda ()
98                                                (handler-case
99                                                    (loop repeat 10000
100                                                          do (find-class (gensym) nil))
101                                                  (serious-condition ()
102                                                    (setf oops t))))))))
103     (mapcar #'sb-thread:join-thread threads)
104     (assert (not oops))))
105
106 #+sb-thread
107 (with-test (:name :semaphore-multiple-waiters)
108   (let ((semaphore (make-semaphore :name "test sem")))
109     (labels ((make-readers (n i)
110                (values
111                 (loop for r from 0 below n
112                       collect
113                       (let ((r r))
114                         (sb-thread:make-thread (lambda ()
115                                                  (let ((sem semaphore))
116                                                    (dotimes (s i)
117                                                      (sb-thread:wait-on-semaphore sem))))
118                                                :name "reader")))
119                 (* n i)))
120              (make-writers (n readers i)
121                (let ((j (* readers i)))
122                  (multiple-value-bind (k rem) (truncate j n)
123                    (values
124                     (let ((writers
125                            (loop for w from 0 below n
126                                  collect
127                                  (let ((w w))
128                                    (sb-thread:make-thread (lambda ()
129                                                             (let ((sem semaphore))
130                                                               (dotimes (s k)
131                                                                 (sb-thread:signal-semaphore sem))))
132                                                           :name "writer")))))
133                       (assert (zerop rem))
134                       writers)
135                     (+ rem (* n k))))))
136              (test (r w n)
137                (multiple-value-bind (readers x) (make-readers r n)
138                  (assert (= (length readers) r))
139                  (multiple-value-bind (writers y) (make-writers w r n)
140                    (assert (= (length writers) w))
141                    (assert (= x y))
142                    (mapc #'sb-thread:join-thread writers)
143                    (mapc #'sb-thread:join-thread readers)
144                    (assert (zerop (sb-thread:semaphore-count semaphore)))
145                    (values)))))
146       (assert
147        (eq :ok
148            (handler-case
149                (sb-ext:with-timeout 10
150                  (test 1 1 100)
151                  (test 2 2 10000)
152                  (test 4 2 10000)
153                  (test 4 2 10000)
154                  (test 10 10 10000)
155                  (test 10 1 10000)
156                  :ok)
157              (sb-ext:timeout ()
158                :timeout)))))))
159