changelog shortlog graph tags branches changeset files revisions annotate raw help

Mercurial > core / lisp/std/tests/thread.lisp

changeset 692: f51b73f49946
author: Richard Westhaver <ellis@rwest.io>
date: Thu, 03 Oct 2024 17:56:11 -0400
permissions: -rw-r--r--
description: std/task and tests 
     1 ;;; thread.lisp --- Thread Tests
     2 
     3 ;; 
     4 
     5 ;;; Code:
     6 (in-package :std/tests)
     7 (in-suite :std)
     8 
     9 (deftest with-threads ()
    10   "Test with-threads macro."
    11   (with-threads (4 :args (&optional (a 0) (b 1) (c 2)))
    12     (is (= 3 (+ a b c)))))
    13 
    14 (deftest threads ()
    15   "Test standard thread functionality."
    16   (is (eq *current-thread*
    17           (find (thread-name *current-thread*) (list-all-threads)
    18                 :key #'thread-name :test #'equal)))
    19   (is (find-thread-by-id (car (thread-id-list))))
    20   (is (not (zerop (thread-count))))
    21   (let ((threads
    22           (make-threads 4 (lambda () (is (= 42 (1+ 41)))) :name "threads")))
    23     (loop for th in threads
    24           do (sb-thread:join-thread th))
    25     (loop for th in threads
    26           collect (is (not (sb-thread:thread-alive-p th)))))
    27   (let ((m (make-mutex :name "mutex-test")))
    28     (is
    29      (and (not
    30            (with-mutex (m)
    31              (join-thread
    32               (make-thread (lambda ()
    33                              (with-mutex (m :timeout 0.1)
    34                                t))))))
    35           (join-thread
    36            (make-thread (lambda ()
    37                           (with-mutex (m :timeout 0.1)
    38                             t)))))))
    39   (let* ((sym (gensym))
    40          (s (make-semaphore :name "semaphore-test"))
    41          (th (make-thread (lambda () (wait-on-semaphore s)))))
    42     (is (equal (multiple-value-list (join-thread th :timeout .001 :default sym))
    43                (list sym :timeout)))
    44     (signal-semaphore s)
    45     (is (join-thread th)))
    46   (signals join-thread-error (join-thread *current-thread*))
    47   (is
    48    (let ((m (make-mutex :name "rlock-test")))
    49      (is (not (with-mutex (m) (join-thread (make-thread (lambda () (with-recursive-lock (m :wait-p nil) t)))))))
    50      (join-thread (make-thread (lambda () (with-recursive-lock (m :wait-p nil) t))))))
    51   (let ((queue (make-waitqueue :name "queue-test"))
    52         (lock (make-mutex :name "lock-test"))
    53         (n 0)
    54         th)
    55     (labels ((in-new-thread ()
    56                (with-mutex (lock)
    57                  (assert (eql (mutex-owner lock) *current-thread*))
    58                  (condition-wait queue lock)
    59                  (assert (eql (mutex-owner lock) *current-thread*))
    60                  (is (= n 1))
    61                  (decf n))))
    62       (setf th (make-thread #'in-new-thread))
    63       (sleep 1)
    64       (is (null (mutex-owner lock)))
    65       (with-mutex (lock)
    66         (incf n)
    67         (condition-notify queue))
    68       (is (= 0 (join-thread th))))))
    69 
    70 (deftest timers ()
    71   "Test various timer functionality."
    72   (sb-int:with-progressive-timeout (ttl :seconds 2)
    73     (sleep 0.1)
    74     (is (/= (ttl) 2.0))))