thread-tests.el 10.7 KB
Newer Older
1 2
;;; threads.el --- tests for threads.

Paul Eggert's avatar
Paul Eggert committed
3
;; Copyright (C) 2012-2018 Free Software Foundation, Inc.
4 5 6 7 8 9 10 11 12 13 14 15 16 17

;; This file is part of GNU Emacs.

;; GNU Emacs is free software: you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.

;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; GNU General Public License for more details.

;; You should have received a copy of the GNU General Public License
18
;; along with GNU Emacs.  If not, see <https://www.gnu.org/licenses/>.
19 20 21

;;; Code:

Michael Albinus's avatar
Michael Albinus committed
22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41
;; Declare the functions in case Emacs has been configured --without-threads.
(declare-function all-threads "thread.c" ())
(declare-function condition-mutex "thread.c" (cond))
(declare-function condition-name "thread.c" (cond))
(declare-function condition-notify "thread.c" (cond &optional all))
(declare-function condition-wait "thread.c" (cond))
(declare-function current-thread "thread.c" ())
(declare-function make-condition-variable "thread.c" (mutex &optional name))
(declare-function make-mutex "thread.c" (&optional name))
(declare-function make-thread "thread.c" (function &optional name))
(declare-function mutex-lock "thread.c" (mutex))
(declare-function mutex-unlock "thread.c" (mutex))
(declare-function thread--blocker "thread.c" (thread))
(declare-function thread-alive-p "thread.c" (thread))
(declare-function thread-join "thread.c" (thread))
(declare-function thread-last-error "thread.c" ())
(declare-function thread-name "thread.c" (thread))
(declare-function thread-signal "thread.c" (thread error-symbol data))
(declare-function thread-yield "thread.c" ())

42
(ert-deftest threads-is-one ()
Glenn Morris's avatar
Glenn Morris committed
43
  "Test for existence of a thread."
Michael Albinus's avatar
Michael Albinus committed
44
  (skip-unless (featurep 'threads))
45 46 47
  (should (current-thread)))

(ert-deftest threads-threadp ()
Glenn Morris's avatar
Glenn Morris committed
48
  "Test of threadp."
Michael Albinus's avatar
Michael Albinus committed
49
  (skip-unless (featurep 'threads))
50 51 52
  (should (threadp (current-thread))))

(ert-deftest threads-type ()
Glenn Morris's avatar
Glenn Morris committed
53
  "Test of thread type."
Michael Albinus's avatar
Michael Albinus committed
54
  (skip-unless (featurep 'threads))
55 56 57
  (should (eq (type-of (current-thread)) 'thread)))

(ert-deftest threads-name ()
Glenn Morris's avatar
Glenn Morris committed
58
  "Test for name of a thread."
Michael Albinus's avatar
Michael Albinus committed
59
  (skip-unless (featurep 'threads))
60 61 62 63
  (should
   (string= "hi bob" (thread-name (make-thread #'ignore "hi bob")))))

(ert-deftest threads-alive ()
Glenn Morris's avatar
Glenn Morris committed
64
  "Test for thread liveness."
Michael Albinus's avatar
Michael Albinus committed
65
  (skip-unless (featurep 'threads))
66 67 68 69
  (should
   (thread-alive-p (make-thread #'ignore))))

(ert-deftest threads-all-threads ()
Glenn Morris's avatar
Glenn Morris committed
70
  "Simple test for all-threads."
Michael Albinus's avatar
Michael Albinus committed
71
  (skip-unless (featurep 'threads))
72 73 74 75 76 77 78 79
  (should (listp (all-threads))))

(defvar threads-test-global nil)

(defun threads-test-thread1 ()
  (setq threads-test-global 23))

(ert-deftest threads-basic ()
Glenn Morris's avatar
Glenn Morris committed
80
  "Basic thread test."
Michael Albinus's avatar
Michael Albinus committed
81
  (skip-unless (featurep 'threads))
82 83 84 85 86 87 88 89 90
  (should
   (progn
     (setq threads-test-global nil)
     (make-thread #'threads-test-thread1)
     (while (not threads-test-global)
       (thread-yield))
     threads-test-global)))

(ert-deftest threads-join ()
Glenn Morris's avatar
Glenn Morris committed
91
  "Test of `thread-join'."
Michael Albinus's avatar
Michael Albinus committed
92
  (skip-unless (featurep 'threads))
93 94 95 96 97 98 99 100
  (should
   (progn
     (setq threads-test-global nil)
     (let ((thread (make-thread #'threads-test-thread1)))
       (thread-join thread)
       (and threads-test-global
	    (not (thread-alive-p thread)))))))

101
(ert-deftest threads-join-self ()
Glenn Morris's avatar
Glenn Morris committed
102
  "Cannot `thread-join' the current thread."
Michael Albinus's avatar
Michael Albinus committed
103
  (skip-unless (featurep 'threads))
104 105
  (should-error (thread-join (current-thread))))

106 107 108 109 110 111 112 113
(defvar threads-test-binding nil)

(defun threads-test-thread2 ()
  (let ((threads-test-binding 23))
    (thread-yield))
  (setq threads-test-global 23))

(ert-deftest threads-let-binding ()
Glenn Morris's avatar
Glenn Morris committed
114
  "Simple test of threads and let bindings."
Michael Albinus's avatar
Michael Albinus committed
115
  (skip-unless (featurep 'threads))
116 117
  (should
   (progn
Tom Tromey's avatar
Tom Tromey committed
118
     (setq threads-test-global nil)
119 120 121 122 123 124 125
     (make-thread #'threads-test-thread2)
     (while (not threads-test-global)
       (thread-yield))
     (and (not threads-test-binding)
	  threads-test-global))))

(ert-deftest threads-mutexp ()
Glenn Morris's avatar
Glenn Morris committed
126
  "Simple test of `mutexp'."
Michael Albinus's avatar
Michael Albinus committed
127
  (skip-unless (featurep 'threads))
128 129 130
  (should-not (mutexp 'hi)))

(ert-deftest threads-mutexp-2 ()
Glenn Morris's avatar
Glenn Morris committed
131
  "Another simple test of `mutexp'."
Michael Albinus's avatar
Michael Albinus committed
132
  (skip-unless (featurep 'threads))
133 134 135
  (should (mutexp (make-mutex))))

(ert-deftest threads-mutex-type ()
Glenn Morris's avatar
Glenn Morris committed
136
  "type-of mutex."
Michael Albinus's avatar
Michael Albinus committed
137
  (skip-unless (featurep 'threads))
138 139 140
  (should (eq (type-of (make-mutex)) 'mutex)))

(ert-deftest threads-mutex-lock-unlock ()
Glenn Morris's avatar
Glenn Morris committed
141
  "Test mutex-lock and unlock."
Michael Albinus's avatar
Michael Albinus committed
142
  (skip-unless (featurep 'threads))
143 144 145 146 147 148 149
  (should
   (let ((mx (make-mutex)))
     (mutex-lock mx)
     (mutex-unlock mx)
     t)))

(ert-deftest threads-mutex-recursive ()
Glenn Morris's avatar
Glenn Morris committed
150
  "Test mutex recursion."
Michael Albinus's avatar
Michael Albinus committed
151
  (skip-unless (featurep 'threads))
152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170
  (should
   (let ((mx (make-mutex)))
     (mutex-lock mx)
     (mutex-lock mx)
     (mutex-unlock mx)
     (mutex-unlock mx)
     t)))

(defvar threads-mutex nil)
(defvar threads-mutex-key nil)

(defun threads-test-mlock ()
  (mutex-lock threads-mutex)
  (setq threads-mutex-key 23)
  (while threads-mutex-key
    (thread-yield))
  (mutex-unlock threads-mutex))

(ert-deftest threads-mutex-contention ()
Glenn Morris's avatar
Glenn Morris committed
171
  "Test of mutex contention."
Michael Albinus's avatar
Michael Albinus committed
172
  (skip-unless (featurep 'threads))
173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191
  (should
   (progn
     (setq threads-mutex (make-mutex))
     (setq threads-mutex-key nil)
     (make-thread #'threads-test-mlock)
     ;; Wait for other thread to get the lock.
     (while (not threads-mutex-key)
       (thread-yield))
     ;; Try now.
     (setq threads-mutex-key nil)
     (mutex-lock threads-mutex)
     (mutex-unlock threads-mutex)
     t)))

(defun threads-test-mlock2 ()
  (setq threads-mutex-key 23)
  (mutex-lock threads-mutex))

(ert-deftest threads-mutex-signal ()
Glenn Morris's avatar
Glenn Morris committed
192
  "Test signaling a blocked thread."
Michael Albinus's avatar
Michael Albinus committed
193
  (skip-unless (featurep 'threads))
194 195 196 197 198 199 200 201 202 203 204 205
  (should
   (progn
     (setq threads-mutex (make-mutex))
     (setq threads-mutex-key nil)
     (mutex-lock threads-mutex)
     (let ((thr (make-thread #'threads-test-mlock2)))
       (while (not threads-mutex-key)
	 (thread-yield))
       (thread-signal thr 'quit nil)
       (thread-join thr))
     t)))

Tom Tromey's avatar
Tom Tromey committed
206 207 208 209
(defun threads-test-io-switch ()
  (setq threads-test-global 23))

(ert-deftest threads-io-switch ()
Glenn Morris's avatar
Glenn Morris committed
210
  "Test that `accept-process-output' causes thread switch."
Michael Albinus's avatar
Michael Albinus committed
211
  (skip-unless (featurep 'threads))
Tom Tromey's avatar
Tom Tromey committed
212 213 214 215 216 217 218 219
  (should
   (progn
     (setq threads-test-global nil)
     (make-thread #'threads-test-io-switch)
     (while (not threads-test-global)
       (accept-process-output nil 1))
     threads-test-global)))

Tom Tromey's avatar
Tom Tromey committed
220
(ert-deftest threads-condvarp ()
Glenn Morris's avatar
Glenn Morris committed
221
  "Simple test of `condition-variable-p'."
Michael Albinus's avatar
Michael Albinus committed
222
  (skip-unless (featurep 'threads))
223
  (should-not (condition-variable-p 'hi)))
Tom Tromey's avatar
Tom Tromey committed
224 225

(ert-deftest threads-condvarp-2 ()
Glenn Morris's avatar
Glenn Morris committed
226
  "Another simple test of `condition-variable-p'."
Michael Albinus's avatar
Michael Albinus committed
227
  (skip-unless (featurep 'threads))
228
  (should (condition-variable-p (make-condition-variable (make-mutex)))))
Tom Tromey's avatar
Tom Tromey committed
229 230 231

(ert-deftest threads-condvar-type ()
  "type-of condvar"
Michael Albinus's avatar
Michael Albinus committed
232
  (skip-unless (featurep 'threads))
Tom Tromey's avatar
Tom Tromey committed
233 234 235
  (should (eq (type-of (make-condition-variable (make-mutex)))
	      'condition-variable)))

236
(ert-deftest threads-condvar-mutex ()
Glenn Morris's avatar
Glenn Morris committed
237
  "Simple test of `condition-mutex'."
Michael Albinus's avatar
Michael Albinus committed
238
  (skip-unless (featurep 'threads))
239 240 241 242 243
  (should
   (let ((m (make-mutex)))
     (eq m (condition-mutex (make-condition-variable m))))))

(ert-deftest threads-condvar-name ()
Glenn Morris's avatar
Glenn Morris committed
244
  "Simple test of `condition-name'."
Michael Albinus's avatar
Michael Albinus committed
245
  (skip-unless (featurep 'threads))
246 247 248 249
  (should
     (eq nil (condition-name (make-condition-variable (make-mutex))))))

(ert-deftest threads-condvar-name-2 ()
Glenn Morris's avatar
Glenn Morris committed
250
  "Another simple test of `condition-name'."
Michael Albinus's avatar
Michael Albinus committed
251
  (skip-unless (featurep 'threads))
252 253 254 255
  (should
     (string= "hi bob"
	      (condition-name (make-condition-variable (make-mutex)
						       "hi bob")))))
256 257 258 259 260 261 262 263 264 265 266 267
(defun call-error ()
  "Call `error'."
  (error "Error is called"))

;; This signals an error internally; the error should be caught.
(defun thread-custom ()
  (defcustom thread-custom-face 'highlight
    "Face used for thread customizations."
    :type 'face
    :group 'widget-faces))

(ert-deftest thread-errors ()
268
  "Test what happens when a thread signals an error."
Michael Albinus's avatar
Michael Albinus committed
269
  (skip-unless (featurep 'threads))
270 271 272 273 274 275 276 277 278
  (let (th1 th2)
    (setq th1 (make-thread #'call-error "call-error"))
    (should (threadp th1))
    (while (thread-alive-p th1)
      (thread-yield))
    (should (equal (thread-last-error)
                   '(error "Error is called")))
    (setq th2 (make-thread #'thread-custom "thread-custom"))
    (should (threadp th2))))
279

280 281
(ert-deftest thread-sticky-point ()
  "Test bug #25165 with point movement in cloned buffer."
Michael Albinus's avatar
Michael Albinus committed
282
  (skip-unless (featurep 'threads))
283 284 285 286 287 288 289 290
  (with-temp-buffer
    (insert "Lorem ipsum dolor sit amet, consectetur adipiscing elit.")
    (goto-char (point-min))
    (clone-indirect-buffer nil nil)
    (forward-char 20)
    (sit-for 1)
    (should (= (point) 21))))

291 292
(ert-deftest thread-signal-early ()
  "Test signaling a thread as soon as it is started by the OS."
Michael Albinus's avatar
Michael Albinus committed
293
  (skip-unless (featurep 'threads))
294 295 296 297 298
  (let ((thread
         (make-thread #'(lambda ()
                          (while t (thread-yield))))))
    (thread-signal thread 'error nil)
    (sit-for 1)
299 300
    (should-not (thread-alive-p thread))
    (should (equal (thread-last-error) '(error)))))
301

302
(defvar threads-condvar nil)
303

304
(defun threads-test-condvar-wait ()
305 306 307
  ;; Wait for condvar to be notified.
  (with-mutex (condition-mutex threads-condvar)
    (condition-wait threads-condvar))
308 309 310 311 312
  ;; Wait again, it will be signaled.
  (with-mutex (condition-mutex threads-condvar)
    (condition-wait threads-condvar)))

(ert-deftest threads-condvar-wait ()
Glenn Morris's avatar
Glenn Morris committed
313
  "Test waiting on conditional variable."
Michael Albinus's avatar
Michael Albinus committed
314
  (skip-unless (featurep 'threads))
315 316
  (let ((cv-mutex (make-mutex))
        new-thread)
Eli Zaretskii's avatar
Eli Zaretskii committed
317 318 319 320
    ;; We could have spurious threads from the previous tests still
    ;; running; wait for them to die.
    (while (> (length (all-threads)) 1)
      (thread-yield))
321 322
    (setq threads-condvar (make-condition-variable cv-mutex))
    (setq new-thread (make-thread #'threads-test-condvar-wait))
323 324

    ;; Make sure new-thread is alive.
325
    (should (thread-alive-p new-thread))
Eli Zaretskii's avatar
Eli Zaretskii committed
326
    (should (= (length (all-threads)) 2))
327 328 329 330
    ;; Wait for new-thread to become blocked on the condvar.
    (while (not (eq (thread--blocker new-thread) threads-condvar))
      (thread-yield))

331 332 333
    ;; Notify the waiting thread.
    (with-mutex cv-mutex
      (condition-notify threads-condvar t))
Eli Zaretskii's avatar
Eli Zaretskii committed
334 335
    ;; Allow new-thread to process the notification.
    (sleep-for 0.1)
336
    ;; Make sure the thread is still there.  This used to fail due to
337
    ;; a bug in thread.c:condition_wait_callback.
338
    (should (thread-alive-p new-thread))
Eli Zaretskii's avatar
Eli Zaretskii committed
339
    (should (= (length (all-threads)) 2))
340 341 342 343 344 345
    (should (eq (thread--blocker new-thread) threads-condvar))

    ;; Signal the thread.
    (thread-signal new-thread 'error '("Die, die, die!"))
    (sleep-for 0.1)
    ;; Make sure the thread died.
346 347
    (should (= (length (all-threads)) 1))
    (should (equal (thread-last-error) '(error "Die, die, die!")))))
348

349
;;; threads.el ends here