test/src/thread-tests.el

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