test/src/thread-tests.el

   1 ;;; threads.el --- tests for threads.
   2
   3 ;; Copyright (C) 2012-2018 Free Software Foundation, Inc.
   4
   5 ;; This file is part of GNU Emacs.
   6
   7 ;; GNU Emacs is free software: you can redistribute it and/or modify
   8 ;; it under the terms of the GNU General Public License as published by
   9 ;; the Free Software Foundation, either version 3 of the License, or
  10 ;; (at your option) any later version.
  11
  12 ;; GNU Emacs is distributed in the hope that it will be useful,
  13 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  14 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  15 ;; GNU General Public License for more details.
  16
  17 ;; 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 ;;; Code:
  21
  22 (ert-deftest threads-is-one ()
  23   "Test for existence of a thread."
  24   (skip-unless (fboundp 'make-thread))
  25   (should (current-thread)))
  26
  27 (ert-deftest threads-threadp ()
  28   "Test of threadp."
  29   (skip-unless (fboundp 'make-thread))
  30   (should (threadp (current-thread))))
  31
  32 (ert-deftest threads-type ()
  33   "Test of thread type."
  34   (skip-unless (fboundp 'make-thread))
  35   (should (eq (type-of (current-thread)) 'thread)))
  36
  37 (ert-deftest threads-name ()
  38   "Test for name of a thread."
  39   (skip-unless (fboundp 'make-thread))
  40   (should
  41    (string= "hi bob" (thread-name (make-thread #'ignore "hi bob")))))
  42
  43 (ert-deftest threads-alive ()
  44   "Test for thread liveness."
  45   (skip-unless (fboundp 'make-thread))
  46   (should
  47    (thread-alive-p (make-thread #'ignore))))
  48
  49 (ert-deftest threads-all-threads ()
  50   "Simple test for all-threads."
  51   (skip-unless (fboundp 'make-thread))
  52   (should (listp (all-threads))))
  53
  54 (defvar threads-test-global nil)
  55
  56 (defun threads-test-thread1 ()
  57   (setq threads-test-global 23))
  58
  59 (ert-deftest threads-basic ()
  60   "Basic thread test."
  61   (skip-unless (fboundp 'make-thread))
  62   (should
  63    (progn
  64      (setq threads-test-global nil)
  65      (make-thread #'threads-test-thread1)
  66      (while (not threads-test-global)
  67        (thread-yield))
  68      threads-test-global)))
  69
  70 (ert-deftest threads-join ()
  71   "Test of `thread-join'."
  72   (skip-unless (fboundp 'make-thread))
  73   (should
  74    (progn
  75      (setq threads-test-global nil)
  76      (let ((thread (make-thread #'threads-test-thread1)))
  77        (thread-join thread)
  78        (and threads-test-global
  79             (not (thread-alive-p thread)))))))
  80
  81 (ert-deftest threads-join-self ()
  82   "Cannot `thread-join' the current thread."
  83   (skip-unless (fboundp 'make-thread))
  84   (should-error (thread-join (current-thread))))
  85
  86 (defvar threads-test-binding nil)
  87
  88 (defun threads-test-thread2 ()
  89   (let ((threads-test-binding 23))
  90     (thread-yield))
  91   (setq threads-test-global 23))
  92
  93 (ert-deftest threads-let-binding ()
  94   "Simple test of threads and let bindings."
  95   (skip-unless (fboundp 'make-thread))
  96   (should
  97    (progn
  98      (setq threads-test-global nil)
  99      (make-thread #'threads-test-thread2)
 100      (while (not threads-test-global)
 101        (thread-yield))
 102      (and (not threads-test-binding)
 103           threads-test-global))))
 104
 105 (ert-deftest threads-mutexp ()
 106   "Simple test of `mutexp'."
 107   (skip-unless (fboundp 'make-thread))
 108   (should-not (mutexp 'hi)))
 109
 110 (ert-deftest threads-mutexp-2 ()
 111   "Another simple test of `mutexp'."
 112   (skip-unless (fboundp 'make-thread))
 113   (should (mutexp (make-mutex))))
 114
 115 (ert-deftest threads-mutex-type ()
 116   "type-of mutex."
 117   (skip-unless (fboundp 'make-thread))
 118   (should (eq (type-of (make-mutex)) 'mutex)))
 119
 120 (ert-deftest threads-mutex-lock-unlock ()
 121   "Test mutex-lock and unlock."
 122   (skip-unless (fboundp 'make-thread))
 123   (should
 124    (let ((mx (make-mutex)))
 125      (mutex-lock mx)
 126      (mutex-unlock mx)
 127      t)))
 128
 129 (ert-deftest threads-mutex-recursive ()
 130   "Test mutex recursion."
 131   (skip-unless (fboundp 'make-thread))
 132   (should
 133    (let ((mx (make-mutex)))
 134      (mutex-lock mx)
 135      (mutex-lock mx)
 136      (mutex-unlock mx)
 137      (mutex-unlock mx)
 138      t)))
 139
 140 (defvar threads-mutex nil)
 141 (defvar threads-mutex-key nil)
 142
 143 (defun threads-test-mlock ()
 144   (mutex-lock threads-mutex)
 145   (setq threads-mutex-key 23)
 146   (while threads-mutex-key
 147     (thread-yield))
 148   (mutex-unlock threads-mutex))
 149
 150 (ert-deftest threads-mutex-contention ()
 151   "Test of mutex contention."
 152   (skip-unless (fboundp 'make-thread))
 153   (should
 154    (progn
 155      (setq threads-mutex (make-mutex))
 156      (setq threads-mutex-key nil)
 157      (make-thread #'threads-test-mlock)
 158      ;; Wait for other thread to get the lock.
 159      (while (not threads-mutex-key)
 160        (thread-yield))
 161      ;; Try now.
 162      (setq threads-mutex-key nil)
 163      (mutex-lock threads-mutex)
 164      (mutex-unlock threads-mutex)
 165      t)))
 166
 167 (defun threads-test-mlock2 ()
 168   (setq threads-mutex-key 23)
 169   (mutex-lock threads-mutex))
 170
 171 (ert-deftest threads-mutex-signal ()
 172   "Test signaling a blocked thread."
 173   (skip-unless (fboundp 'make-thread))
 174   (should
 175    (progn
 176      (setq threads-mutex (make-mutex))
 177      (setq threads-mutex-key nil)
 178      (mutex-lock threads-mutex)
 179      (let ((thr (make-thread #'threads-test-mlock2)))
 180        (while (not threads-mutex-key)
 181          (thread-yield))
 182        (thread-signal thr 'quit nil)
 183        (thread-join thr))
 184      t)))
 185
 186 (defun threads-test-io-switch ()
 187   (setq threads-test-global 23))
 188
 189 (ert-deftest threads-io-switch ()
 190   "Test that `accept-process-output' causes thread switch."
 191   (skip-unless (fboundp 'make-thread))
 192   (should
 193    (progn
 194      (setq threads-test-global nil)
 195      (make-thread #'threads-test-io-switch)
 196      (while (not threads-test-global)
 197        (accept-process-output nil 1))
 198      threads-test-global)))
 199
 200 (ert-deftest threads-condvarp ()
 201   "Simple test of `condition-variable-p'."
 202   (skip-unless (fboundp 'make-thread))
 203   (should-not (condition-variable-p 'hi)))
 204
 205 (ert-deftest threads-condvarp-2 ()
 206   "Another simple test of `condition-variable-p'."
 207   (skip-unless (fboundp 'make-thread))
 208   (should (condition-variable-p (make-condition-variable (make-mutex)))))
 209
 210 (ert-deftest threads-condvar-type ()
 211   "type-of condvar"
 212   (skip-unless (fboundp 'make-thread))
 213   (should (eq (type-of (make-condition-variable (make-mutex)))
 214               'condition-variable)))
 215
 216 (ert-deftest threads-condvar-mutex ()
 217   "Simple test of `condition-mutex'."
 218   (skip-unless (fboundp 'make-thread))
 219   (should
 220    (let ((m (make-mutex)))
 221      (eq m (condition-mutex (make-condition-variable m))))))
 222
 223 (ert-deftest threads-condvar-name ()
 224   "Simple test of `condition-name'."
 225   (skip-unless (fboundp 'make-thread))
 226   (should
 227      (eq nil (condition-name (make-condition-variable (make-mutex))))))
 228
 229 (ert-deftest threads-condvar-name-2 ()
 230   "Another simple test of `condition-name'."
 231   (skip-unless (fboundp 'make-thread))
 232   (should
 233      (string= "hi bob"
 234               (condition-name (make-condition-variable (make-mutex)
 235                                                        "hi bob")))))
 236 (defun call-error ()
 237   "Call `error'."
 238   (error "Error is called"))
 239
 240 ;; This signals an error internally; the error should be caught.
 241 (defun thread-custom ()
 242   (defcustom thread-custom-face 'highlight
 243     "Face used for thread customizations."
 244     :type 'face
 245     :group 'widget-faces))
 246
 247 (ert-deftest thread-errors ()
 248   "Test what happens when a thread signals an error."
 249   (skip-unless (fboundp 'make-thread))
 250   (let (th1 th2)
 251     (setq th1 (make-thread #'call-error "call-error"))
 252     (should (threadp th1))
 253     (while (thread-alive-p th1)
 254       (thread-yield))
 255     (should (equal (thread-last-error)
 256                    '(error "Error is called")))
 257     (setq th2 (make-thread #'thread-custom "thread-custom"))
 258     (should (threadp th2))))
 259
 260 (ert-deftest thread-sticky-point ()
 261   "Test bug #25165 with point movement in cloned buffer."
 262   (skip-unless (fboundp 'make-thread))
 263   (with-temp-buffer
 264     (insert "Lorem ipsum dolor sit amet, consectetur adipiscing elit.")
 265     (goto-char (point-min))
 266     (clone-indirect-buffer nil nil)
 267     (forward-char 20)
 268     (sit-for 1)
 269     (should (= (point) 21))))
 270
 271 (ert-deftest thread-signal-early ()
 272   "Test signaling a thread as soon as it is started by the OS."
 273   (skip-unless (fboundp 'make-thread))
 274   (let ((thread
 275          (make-thread #'(lambda ()
 276                           (while t (thread-yield))))))
 277     (thread-signal thread 'error nil)
 278     (sit-for 1)
 279     (should-not (thread-alive-p thread))
 280     (should (equal (thread-last-error) '(error)))))
 281
 282 (defvar threads-condvar nil)
 283
 284 (defun threads-test-condvar-wait ()
 285   ;; Wait for condvar to be notified.
 286   (with-mutex (condition-mutex threads-condvar)
 287     (condition-wait threads-condvar))
 288   ;; Wait again, it will be signaled.
 289   (with-mutex (condition-mutex threads-condvar)
 290     (condition-wait threads-condvar)))
 291
 292 (ert-deftest threads-condvar-wait ()
 293   "Test waiting on conditional variable."
 294   (skip-unless (fboundp 'make-thread))
 295   (let ((cv-mutex (make-mutex))
 296         new-thread)
 297     ;; We could have spurious threads from the previous tests still
 298     ;; running; wait for them to die.
 299     (while (> (length (all-threads)) 1)
 300       (thread-yield))
 301     (setq threads-condvar (make-condition-variable cv-mutex))
 302     (setq new-thread (make-thread #'threads-test-condvar-wait))
 303
 304     ;; Make sure new-thread is alive.
 305     (should (thread-alive-p new-thread))
 306     (should (= (length (all-threads)) 2))
 307     ;; Wait for new-thread to become blocked on the condvar.
 308     (while (not (eq (thread--blocker new-thread) threads-condvar))
 309       (thread-yield))
 310
 311     ;; Notify the waiting thread.
 312     (with-mutex cv-mutex
 313       (condition-notify threads-condvar t))
 314     ;; Allow new-thread to process the notification.
 315     (sleep-for 0.1)
 316     ;; Make sure the thread is still there.  This used to fail due to
 317     ;; a bug in thread.c:condition_wait_callback.
 318     (should (thread-alive-p new-thread))
 319     (should (= (length (all-threads)) 2))
 320     (should (eq (thread--blocker new-thread) threads-condvar))
 321
 322     ;; Signal the thread.
 323     (thread-signal new-thread 'error '("Die, die, die!"))
 324     (sleep-for 0.1)
 325     ;; Make sure the thread died.
 326     (should (= (length (all-threads)) 1))
 327     (should (equal (thread-last-error) '(error "Die, die, die!")))))
 328
 329 ;;; threads.el ends here