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