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 :run-program :trivial))
  19   (assert-timeout (sb-sys:with-deadline (:seconds 1)
  20                     (run-sleep 3))))
  21
  22 (with-test (:name (:deadline :defer-deadline-1))
  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 :defer-deadline-2))
  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 :cancel-deadline))
  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 :get-mutex) :skipped-on '(not (and :sb-thread (not :sb-lutex))))
  69   (assert-timeout
  70    (let ((lock (sb-thread:make-mutex))
  71          (waitp t))
  72      (sb-thread:make-thread (lambda ()
  73                               (sb-thread:get-mutex lock)
  74                               (setf waitp nil)
  75                               (sleep 5)))
  76      (loop while waitp do (sleep 0.01))
  77      (sb-sys:with-deadline (:seconds 1)
  78        (sb-thread:get-mutex lock)))))
  79
  80 (with-test (:name (:deadline :wait-on-semaphore) :skipped-on '(not (and :sb-thread (not :sb-lutex))))
  81   (assert-timeout
  82    (let ((sem (sb-thread::make-semaphore :count 0)))
  83      (sb-sys:with-deadline (:seconds 1)
  84        (sb-thread::wait-on-semaphore sem)))))
  85
  86 (with-test (:name (:deadline :join-thread) :skipped-on '(not (and :sb-thread (not :sb-lutex))))
  87   (assert-timeout
  88    (sb-sys:with-deadline (:seconds 1)
  89      (sb-thread:join-thread
  90       (sb-thread:make-thread (lambda () (loop (sleep 1))))))))
  91
  92 (with-test (:name (:deadline :futex-wait-eintr) :skipped-on '(not (and :sb-thread (not :sb-lutex))))
  93   (let ((lock (sb-thread:make-mutex))
  94         (waitp t))
  95     (sb-thread:make-thread (lambda ()
  96                              (sb-thread:get-mutex lock)
  97                              (setf waitp nil)
  98                              (sleep 5)))
  99     (loop while waitp do (sleep 0.01))
 100     (let ((thread (sb-thread:make-thread
 101                    (lambda ()
 102                      (let ((start (get-internal-real-time)))
 103                        (handler-case
 104                            (sb-sys:with-deadline (:seconds 1)
 105                              (sb-thread:get-mutex lock))
 106                          (sb-sys:deadline-timeout (x)
 107                            (declare (ignore x))
 108                            (let ((end (get-internal-real-time)))
 109                              (float (/ (- end start)
 110                                        internal-time-units-per-second)
 111                                     0.0)))))))))
 112       (sleep 0.3)
 113       (sb-thread:interrupt-thread thread (lambda () 42))
 114       (let ((seconds-passed (sb-thread:join-thread thread)))
 115         (format t "Deadline in ~S~%" seconds-passed)
 116         (assert (< seconds-passed 1.2))))))