SLEEP respects deadlines established by WITH-DEADLINE

NEWS

@@ -1,6 +1,7 @@
 ;;;; -*- coding: utf-8; fill-column: 78 -*-
 
 changes relative to sbcl-1.4.2:
+  * enhancement: SLEEP respects deadlines established by SB-SYS:WITH-DEADLINE.
   * bug fix: DECODE-TIMEOUT and operators accepting a timeout no longer signal
     an error when called with an argument that is of type (real 0) but not
     (unsigned-byte 62) (lp#1727789)

src/code/deadline.lisp

@@ -60,9 +60,9 @@
 respecting deadlines occurs either after the deadline has passed, or
 would take longer than the time left to complete.
 
-Currently only blocking IO operations, GET-MUTEX, and CONDITION-WAIT
-respect deadlines, but this includes their implicit uses inside SBCL
-itself.
+Currently only SLEEP, blocking IO operations, GET-MUTEX, and
+CONDITION-WAIT respect deadlines, but this includes their implicit
+uses inside SBCL itself.
 
 Unless OVERRIDE is true, existing deadlines can only be restricted,
 not extended. Deadlines are per thread: children are unaffected by

src/code/toplevel.lisp

@@ -130,6 +130,39 @@ means to wait indefinitely.")
            (truncate seconds)
          (values sec (truncate frac (load-time-value 1f-9 t))))))))
 
+(declaim (inline %nanosleep))
+(defun %nanosleep (sec nsec)
+  ;; nanosleep() accepts time_t as the first argument, but on some
+  ;; platforms it is restricted to 100 million seconds. Maybe someone
+  ;; can actually have a reason to sleep for over 3 years?
+  (loop while (> sec (expt 10 8))
+     do (decf sec (expt 10 8))
+       (sb!unix:nanosleep (expt 10 8) 0))
+  (sb!unix:nanosleep sec nsec))
+
+(declaim (inline %sleep))
+#!-win32
+(defun %sleep (seconds)
+  (typecase seconds
+    (double-float
+     (sb!unix::nanosleep-double seconds))
+    (single-float
+     (sb!unix::nanosleep-float seconds))
+    (integer
+     (%nanosleep seconds 0))
+    (t
+     (multiple-value-call #'%nanosleep (split-ratio-for-sleep seconds)))))
+
+#!+(and win32 sb-thread)
+(defun %sleep (seconds)
+  (if (integerp seconds)
+      (%nanosleep seconds 0)
+      (multiple-value-call #'%nanosleep (split-seconds-for-sleep seconds))))
+
+#!+(and win32 (not sb-thread))
+(defun %sleep (seconds)
+  (sb!win32:millisleep (truncate (* seconds 1000))))
+
 (defun sleep (seconds)
   "This function causes execution to be suspended for SECONDS. SECONDS may be
 any non-negative real number."
@@ -142,31 +175,34 @@ any non-negative real number."
            :format-arguments (list seconds)
            :datum seconds
            :expected-type '(real 0)))
-  #!-(and win32 (not sb-thread))
-  (typecase seconds
-    #!-win32
-    (double-float
-     (sb!unix::nanosleep-double seconds))
-    #!-win32
-    (single-float
-     (sb!unix::nanosleep-float seconds))
-    (t
-     (multiple-value-bind (sec nsec)
-         (if (integerp seconds)
-             (values seconds 0)
-             #!-win32
-             (split-ratio-for-sleep seconds)
-             #!+win32
-             (split-seconds-for-sleep seconds))
-       ;; nanosleep() accepts time_t as the first argument, but on some platforms
-       ;; it is restricted to 100 million seconds. Maybe someone can actually
-       ;; have a reason to sleep for over 3 years?
-       (loop while (> sec (expt 10 8))
-             do (decf sec (expt 10 8))
-                (sb!unix:nanosleep (expt 10 8) 0))
-       (sb!unix:nanosleep sec nsec))))
-  #!+(and win32 (not sb-thread))
-  (sb!win32:millisleep (truncate (* seconds 1000)))
+  (if *deadline*
+      (let ((start (get-internal-real-time))
+            ;; SECONDS can be too large to present as INTERNAL-TIME,
+            ;; use the largest representable value in that case.
+            (timeout (or (seconds-to-maybe-internal-time seconds)
+                         (* safe-internal-seconds-limit
+                            internal-time-units-per-second))))
+        (labels ((sleep-for-a-bit (remaining)
+                   (multiple-value-bind
+                         (timeout-sec timeout-usec stop-sec stop-usec deadlinep)
+                       (decode-timeout (/ remaining internal-time-units-per-second))
+                     (declare (ignore stop-sec stop-usec))
+                     ;; Sleep until either the timeout or the deadline
+                     ;; expires.
+                     (when (or (plusp timeout-sec) (plusp timeout-usec))
+                       (%nanosleep timeout-sec (* 1000 timeout-usec)))
+                     ;; If the deadline expired first, signal the
+                     ;; DEADLINE-TIMEOUT. If the deadline is deferred
+                     ;; or canceled, go back to sleep for the
+                     ;; remaining time (if any).
+                     (when deadlinep
+                       (signal-deadline)
+                       (let ((remaining (- timeout
+                                           (- (get-internal-real-time) start))))
+                         (when (plusp remaining)
+                           (sleep-for-a-bit remaining)))))))
+          (sleep-for-a-bit timeout)))
+      (%sleep seconds))
   nil)
 
 ;;;; the default toplevel function

src/compiler/srctran.lisp

@@ -4983,7 +4983,9 @@
 
 #!-(and win32 (not sb-thread))
 (deftransform sleep ((seconds) ((integer 0 #.(expt 10 8))))
-  `(sb!unix:nanosleep seconds 0))
+  `(if sb!impl::*deadline*
+       (locally (declare (notinline sleep)) (sleep seconds))
+       (sb!unix:nanosleep seconds 0)))
 
 #!-(and win32 (not sb-thread))
 (deftransform sleep ((seconds) ((constant-arg (real 0))))
@@ -4992,7 +4994,9 @@
         (sb!impl::split-seconds-for-sleep seconds-value)
       (if (> seconds (expt 10 8))
           (give-up-ir1-transform)
-          `(sb!unix:nanosleep ,seconds ,nano)))))
+          `(if sb!impl::*deadline*
+               (locally (declare (notinline sleep)) (sleep seconds))
+               (sb!unix:nanosleep ,seconds ,nano))))))
 
 ;; On 64-bit architectures the TLS index is in the symbol header,
 ;; !DEFINE-PRIMITIVE-OBJECT doesn't define an accessor for it.

tests/deadline.impure.lisp

@@ -151,3 +151,46 @@
       (sb-thread:interrupt-thread thread (lambda () 42))
       (let ((seconds-passed (sb-thread:join-thread thread)))
         (assert (< seconds-passed 1.2))))))
+
+;;;; Sleep
+
+(with-test (:name (sb-sys:with-deadline sleep :smoke))
+  (assert-timeout ("A deadline was reached after 0.1 seconds.")
+    (sb-sys:with-deadline (:seconds .1) (sleep 1)))
+
+  (assert-no-signal
+      (sb-sys:with-deadline (:seconds .2) (sleep .1))
+    sb-sys:deadline-timeout))
+
+(with-test (:name (sb-sys:with-deadline sleep :long-sleep))
+  (assert-timeout ("A deadline was reached after 0.1 seconds.")
+    (sb-sys:with-deadline (:seconds .1)
+      (sleep (1+ sb-kernel:internal-seconds-limit)))))
+
+(with-test (:name (sb-sys:with-deadline sleep :no-sleep))
+  ;; When SLEEP is called in the context of an expired deadline, the
+  ;; DEADLINE-TIMEOUT must be signaled even if there is no sleeping to
+  ;; be done.
+  (assert-timeout ("A deadline was reached after 0.1 seconds.")
+    (sb-sys:with-deadline (:seconds .1)
+      (let ((sb-impl::*deadline* nil)) (sleep .2))
+      (sleep 0))))
+
+(with-test (:name (sb-sys:with-deadline sleep sb-sys:defer-deadline))
+  (let ((n 0))
+    (assert-no-signal
+        (handler-bind ((sb-sys:deadline-timeout
+                        (lambda (condition)
+                          (incf n)
+                          (sb-sys:defer-deadline .1 condition))))
+          (sb-sys:with-deadline (:seconds .1) (sleep .5)))
+      sb-sys:deadline-timeout)
+    (assert (plusp n))))
+
+(with-test (:name (sb-sys:with-deadline sleep sb-sys:cancel-deadline))
+  (assert-no-signal
+      (handler-bind ((sb-sys:deadline-timeout
+                      (lambda (condition)
+                        (sb-sys:cancel-deadline condition))))
+        (sb-sys:with-deadline (:seconds .1) (sleep 1)))
+    sb-sys:deadline-timeout))