tests/deadline.impure.lisp

   1 (in-package :cl-user)
   2
   3 (use-package :test-util)
   4
   5 (defmacro assert-timeout (form)
   6   (let ((ok (gensym "OK")))
   7     `(let ((,ok ',ok))
   8        (unless (eq ,ok
   9                    (handler-case ,form
  10                      (timeout ()
  11                        ,ok)))
  12          (error "No timeout from form:~%  ~S" ',form)))))
  13
  14 (defun run-sleep (seconds)
  15   (sb-ext:run-program "sleep" (list (format nil "~D" seconds))
  16                       :search t :wait t))
  17
  18 (with-test (:name (:deadline sb-ext:run-program :trivial) :fails-on :win32)
  19   (assert-timeout (sb-sys:with-deadline (:seconds 1)
  20                     (run-sleep 3))))
  21
  22 (with-test (:name (:deadline sb-sys:defer-deadline 1) :fails-on :win32)
  23   (let ((n 0)
  24         (final nil))
  25     (handler-case
  26         (handler-bind ((sb-sys:deadline-timeout
  27                         (lambda (c)
  28                           (when (< n 2)
  29                             (incf n)
  30                             (sb-sys:defer-deadline 0.1 c)))))
  31           (sb-sys:with-deadline (:seconds 1)
  32             (run-sleep 2)))
  33       (sb-sys:deadline-timeout (c)
  34         (setf final c)))
  35     (assert (= n 2))
  36     (assert final)))
  37
  38 (with-test (:name (:deadline sb-sys:defer-deadline 2) :fails-on :win32)
  39   (let ((n 0)
  40         (final nil))
  41     (handler-case
  42         (handler-bind ((sb-sys:deadline-timeout
  43                         (lambda (c)
  44                           (incf n)
  45                           (sb-sys:defer-deadline 0.1 c))))
  46           (sb-sys:with-deadline (:seconds 1)
  47             (run-sleep 2)))
  48       (sb-sys:deadline-timeout (c)
  49         (setf final c)))
  50     (assert (plusp n))
  51     (assert (not final))))
  52
  53 (with-test (:name (:deadline sb-sys:cancel-deadline) :fails-on :win32)
  54   (let ((n 0)
  55         (final nil))
  56     (handler-case
  57         (handler-bind ((sb-sys:deadline-timeout
  58                         (lambda (c)
  59                           (incf n)
  60                           (sb-sys:cancel-deadline c))))
  61           (sb-sys:with-deadline (:seconds 1)
  62             (run-sleep 2)))
  63       (sb-sys:deadline-timeout (c)
  64         (setf final c)))
  65     (assert (= n 1))
  66     (assert (not final))))
  67
  68 (with-test (:name (:deadline sb-thread:grab-mutex)
  69                   :skipped-on '(not :sb-thread))
  70   (assert-timeout
  71    (let ((lock (sb-thread:make-mutex))
  72          (waitp t))
  73      (make-join-thread (lambda ()
  74                          (sb-thread:grab-mutex lock)
  75                          (setf waitp nil)
  76                          (sleep 5)))
  77      (loop while waitp do (sleep 0.01))
  78      (sb-sys:with-deadline (:seconds 1)
  79        (sb-thread:grab-mutex lock)))))
  80
  81 (with-test (:name (:deadline sb-thread:wait-on-semaphore)
  82                   :skipped-on '(not :sb-thread))
  83   (assert-timeout
  84    (let ((sem (sb-thread:make-semaphore :count 0)))
  85      (sb-sys:with-deadline (:seconds 1)
  86        (sb-thread:wait-on-semaphore sem)))))
  87
  88 (with-test (:name (:deadline sb-thread:join-thread)
  89                   :skipped-on '(not :sb-thread))
  90   (assert-timeout
  91    (sb-sys:with-deadline (:seconds 1)
  92      (sb-thread:join-thread
  93       (make-kill-thread (lambda () (loop (sleep 1))))))))
  94
  95 (with-test (:name (:deadline :futex-wait-eintr) :skipped-on '(not :sb-thread))
  96   (let ((lock (sb-thread:make-mutex))
  97         (waitp t))
  98     (make-join-thread (lambda ()
  99                         (sb-thread:grab-mutex lock)
 100                         (setf waitp nil)
 101                         (sleep 5)))
 102     (loop while waitp do (sleep 0.01))
 103     (let ((thread (make-join-thread
 104                    (lambda ()
 105                      (let ((start (get-internal-real-time)))
 106                        (handler-case
 107                            (sb-sys:with-deadline (:seconds 1)
 108                              (sb-thread:grab-mutex lock))
 109                          (sb-sys:deadline-timeout (x)
 110                            (declare (ignore x))
 111                            (let ((end (get-internal-real-time)))
 112                              (float (/ (- end start)
 113                                        internal-time-units-per-second)
 114                                     0.0)))))))))
 115       (sleep 0.3)
 116       (sb-thread:interrupt-thread thread (lambda () 42))
 117       (let ((seconds-passed (sb-thread:join-thread thread)))
 118         (assert (< seconds-passed 1.2))))))