1.0.10.49: deadline refinements

* Deadlines are per-thread. (Children do no inherit their parents
  deadlines.)

* SIGNAL-DEADLINE estabilishes a DEFER-DEADLINE restart.

* Handle SIGNAL-DEADLINE returning due to deferred deadlines where
  necessary.

* Documentation.

package-data-list.lisp-expr

@@ -831,6 +831,7 @@ possibly temporariliy, because it might be used internally."
                "SIMPLE-STREAM-ERROR"
                "SIMPLE-STORAGE-CONDITION"
                "SIMPLE-STYLE-WARNING"
+               "TRY-RESTART"
 
                "SPECIAL-FORM-FUNCTION"
                "STYLE-WARN" "SIMPLE-COMPILER-NOTE"
@@ -2008,6 +2009,7 @@ SB-KERNEL) have been undone, but probably more remain."
                "DECODE-TIMEOUT"
                "DECODE-INTERNAL-TIME"
                "DEFAULT-INTERRUPT"
+               "DEFER-DEADLINE"
                "DEPORT-BOOLEAN" "DEPORT-INTEGER"
                "DYNAMIC-FOREIGN-SYMBOLS-P"
                "DLOPEN-OR-LOSE"

src/code/deadline.lisp

@@ -26,12 +26,17 @@
 
 (defmacro with-deadline ((&key seconds override)
                          &body body)
-  "Arranges for a TIMEOUT condition to be signalled if an operation respecting
-deadlines occurs either after the deadline has passed, or would take longer
-than the time left to complete.
+  "Arranges for a TIMEOUT condition to be signalled if an operation
+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 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
+their parent's deadlines.
 
 Experimental."
   (with-unique-names (deadline-seconds deadline)
@@ -71,13 +76,30 @@ deadlines while the condition is being handled."
 
 (defun signal-deadline ()
   #!+sb-doc
-  "Signal a DEADLINE-TIMEOUT condition. Implementors of blocking functions
-are responsible for calling this when a deadline is reached."
+  "Signal a DEADLINE-TIMEOUT condition, and associate a DEFER-DEADLINE
+restart with it. Implementors of blocking functions are responsible
+for calling this when a deadline is reached."
   ;; Make sure we don't signal the same deadline twice. LET is not good
   ;; enough: we might catch the same deadline again while unwinding.
   (when *deadline*
     (setf *deadline* nil))
-  (signal-timeout 'deadline-timeout :seconds *deadline-seconds*))
+  (with-interrupts
+    (restart-case
+        (error 'deadline-timeout :seconds *deadline-seconds*)
+      (defer-deadline (&optional (seconds *deadline-seconds*))
+        :report "Defer the deadline for SECONDS more."
+        (let* ((new-deadline-seconds (coerce seconds 'single-float))
+               (new-deadline (+ (seconds-to-internal-time new-deadline-seconds)
+                                (get-internal-real-time))))
+          (setf *deadline* new-deadline
+                *deadline-seconds* new-deadline-seconds))))))
+
+(defun defer-deadline (seconds &optional condition)
+  "Find the DEFER-DEADLINE restart associated with CONDITION, and
+calls it with SECONDS as argument (deferring the deadline by that many
+seconds.) Continues from the indicated restart, or returns NIL if the
+restart is not found."
+  (try-restart 'defer-deadline condition seconds))
 
 ;;; Returns TIMEOUT-SEC, TIMEOUT-USEC, DEADLINE-SEC, DEADLINE-USEC, SIGNALP
 ;;;
@@ -102,32 +124,37 @@ deadline instead of the local timeout indicated by SECONDS.
 If SECONDS is null and there is no global timeout all returned values will be
 null. If a global deadline has already passed when DECODE-TIMEOUT is called,
 it will signal a timeout condition."
-  (let* ((timeout (when seconds (seconds-to-internal-time seconds)))
-         (now (get-internal-real-time))
-         (deadline *deadline*)
-         (deadline-timeout
-          (when deadline
-            (let ((time-left (- deadline now)))
-              (if (plusp time-left)
-                  time-left
-                  (signal-deadline))))))
-    (multiple-value-bind (final-timeout final-deadline signalp)
-        ;; Use either *DEADLINE* or TIMEOUT to produce both a timeout
-        ;; and deadline in internal-time units
-        (cond ((and deadline timeout)
-               (if (< timeout deadline-timeout)
-                   (values timeout (+ timeout now) nil)
-                   (values deadline-timeout deadline t)))
-              (deadline
-               (values deadline-timeout deadline t))
-              (timeout
-               (values timeout (+ timeout now) nil))
-              (t
-               (values nil nil nil)))
-      (if final-timeout
-          (multiple-value-bind (to-sec to-usec)
-              (decode-internal-time final-timeout)
-            (multiple-value-bind (stop-sec stop-usec)
-                (decode-internal-time final-deadline)
-              (values to-sec to-usec stop-sec stop-usec signalp)))
-          (values nil nil nil nil nil)))))
+  (tagbody
+   :restart
+     (let* ((timeout (when seconds (seconds-to-internal-time seconds)))
+            (now (get-internal-real-time))
+            (deadline *deadline*)
+            (deadline-timeout
+             (when deadline
+               (let ((time-left (- deadline now)))
+                 (if (plusp time-left)
+                     time-left
+                     (progn
+                       (signal-deadline)
+                       (go :restart)))))))
+       (return-from decode-timeout
+         (multiple-value-bind (final-timeout final-deadline signalp)
+             ;; Use either *DEADLINE* or TIMEOUT to produce both a timeout
+             ;; and deadline in internal-time units
+             (cond ((and deadline timeout)
+                    (if (< timeout deadline-timeout)
+                        (values timeout (+ timeout now) nil)
+                        (values deadline-timeout deadline t)))
+                   (deadline
+                    (values deadline-timeout deadline t))
+                   (timeout
+                    (values timeout (+ timeout now) nil))
+                   (t
+                    (values nil nil nil)))
+           (if final-timeout
+               (multiple-value-bind (to-sec to-usec)
+                   (decode-internal-time final-timeout)
+                 (multiple-value-bind (stop-sec stop-usec)
+                     (decode-internal-time final-deadline)
+                   (values to-sec to-usec stop-sec stop-usec signalp)))
+               (values nil nil nil nil nil)))))))

src/code/serve-event.lisp

@@ -146,17 +146,18 @@
   "Wait until FD is usable for DIRECTION. DIRECTION should be either :INPUT or
 :OUTPUT. TIMEOUT, if supplied, is the number of seconds to wait before giving
 up."
-  (let (usable)
-    (multiple-value-bind (to-sec to-usec stop-sec stop-usec signalp)
-        (decode-timeout timeout)
-      (declare (type (or integer null) to-sec to-usec))
-      (with-fd-handler (fd direction (lambda (fd)
-                                       (declare (ignore fd))
-                                       (setf usable t)))
-        (loop
+  (prog (usable)
+   :restart
+     (multiple-value-bind (to-sec to-usec stop-sec stop-usec signalp)
+         (decode-timeout timeout)
+       (declare (type (or integer null) to-sec to-usec))
+       (with-fd-handler (fd direction (lambda (fd)
+                                        (declare (ignore fd))
+                                        (setf usable t)))
+         (loop
            (sub-serve-event to-sec to-usec signalp)
            (when usable
-             (return t))
+             (return-from wait-until-fd-usable t))
            (when to-sec
              (multiple-value-bind (sec usec)
                  (decode-internal-time (get-internal-real-time))
@@ -168,8 +169,10 @@ up."
                       (setf to-usec (- stop-usec usec)))))
              (when (or (minusp to-sec) (minusp to-usec))
                (if signalp
-                   (signal-deadline)
-                   (return nil)))))))))
+                   (progn
+                     (signal-deadline)
+                     (go :restart))
+                   (return-from wait-until-fd-usable nil)))))))))
 
 ;;; Wait for up to timeout seconds for an event to happen. Make sure all
 ;;; pending events are processed before returning.

src/code/target-thread.lisp

@@ -683,6 +683,7 @@ around and can be retrieved by JOIN-THREAD."
                   (*restart-clusters* nil)
                   (*handler-clusters* nil)
                   (*condition-restarts* nil)
+                  (sb!impl::*deadline* nil)
                   (sb!impl::*step-out* nil)
                   ;; internal printer variables
                   (sb!impl::*previous-case* nil)

tests/deadline.impure.lisp

@@ -9,8 +9,35 @@
 
 
 (assert-timeout
- (sb-impl::with-deadline (:seconds 1)
-   (run-program "sleep" '("5") :search t :wait t)))
+ (sb-sys:with-deadline (:seconds 1)
+   (run-program "sleep" '("3") :search t :wait t)))
+
+(let ((n 0)
+      (final nil))
+  (handler-case
+      (handler-bind ((sb-sys:deadline-timeout (lambda (c)
+                                                (when (< n 2)
+                                                  (incf n)
+                                                  (sb-sys:defer-deadline 0.1 c)))))
+        (sb-sys:with-deadline (:seconds 1)
+          (run-program "sleep" '("2") :search t :wait t)))
+    (sb-sys:deadline-timeout (c)
+      (setf final c)))
+  (assert (= n 2))
+  (assert final))
+
+(let ((n 0)
+      (final nil))
+  (handler-case
+      (handler-bind ((sb-sys:deadline-timeout (lambda (c)
+                                                (incf n)
+                                                (sb-sys:defer-deadline 0.1 c))))
+        (sb-sys:with-deadline (:seconds 1)
+          (run-program "sleep" '("2") :search t :wait t)))
+    (sb-sys:deadline-timeout (c)
+      (setf final c)))
+  (assert (plusp n))
+  (assert (not final)))
 
 #+(and sb-thread (not sb-lutex))
 (progn

version.lisp-expr

@@ -17,4 +17,4 @@
 ;;; checkins which aren't released. (And occasionally for internal
 ;;; versions, especially for internal versions off the main CVS
 ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
-"1.0.10.48"
+"1.0.10.49"