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 #+(and sb-thread (not sb-lutex))
  69 (progn
  70
  71   (with-test (:name (:deadline :get-mutex))
  72     (assert-timeout
  73      (let ((lock (sb-thread:make-mutex))
  74            (waitp t))
  75        (sb-thread:make-thread (lambda ()
  76                                 (sb-thread:get-mutex lock)
  77                                 (setf waitp nil)
  78                                 (sleep 5)))
  79        (loop while waitp do (sleep 0.01))
  80        (sb-sys:with-deadline (:seconds 1)
  81          (sb-thread:get-mutex lock)))))
  82
  83   (with-test (:name (:deadline :wait-on-semaphore))
  84     (assert-timeout
  85      (let ((sem (sb-thread::make-semaphore :count 0)))
  86        (sb-sys:with-deadline (:seconds 1)
  87          (sb-thread::wait-on-semaphore sem)))))
  88
  89   (with-test (:name (:deadline :join-thread))
  90     (assert-timeout
  91      (sb-sys:with-deadline (:seconds 1)
  92        (sb-thread:join-thread
  93         (sb-thread:make-thread (lambda () (loop (sleep 1))))))))
  94
  95   (with-test (:name (:deadline :futex-wait-eintr))
  96     (let ((lock (sb-thread:make-mutex))
  97           (waitp t))
  98       (sb-thread:make-thread (lambda ()
  99                                (sb-thread:get-mutex lock)
 100                                (setf waitp nil)
 101                                (sleep 5)))
 102       (loop while waitp do (sleep 0.01))
 103       (let ((thread (sb-thread:make-thread
 104                      (lambda ()
 105                        (let ((start (get-internal-real-time)))
 106                          (handler-case
 107                              (sb-sys:with-deadline (:seconds 1)
 108                                (sb-thread:get-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           (format t "Deadline in ~S~%" seconds-passed)
 119           (assert (< seconds-passed 1.2)))))))