From 3ac386bf6520a67343aadce1b3e61f580406b740 Mon Sep 17 00:00:00 2001 From: Nikodemus Siivola Date: Fri, 19 Oct 2007 13:25:03 +0000 Subject: [PATCH] 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 | 2 + src/code/deadline.lisp | 101 ++++++++++++++++++++++++++++---------------- src/code/serve-event.lisp | 25 ++++++----- src/code/target-thread.lisp | 1 + tests/deadline.impure.lisp | 31 +++++++++++++- version.lisp-expr | 2 +- 6 files changed, 111 insertions(+), 51 deletions(-) diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr index cfe08ac0a..a74cd9917 100644 --- a/package-data-list.lisp-expr +++ b/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" diff --git a/src/code/deadline.lisp b/src/code/deadline.lisp index 4ea6e72df..413eb869a 100644 --- a/src/code/deadline.lisp +++ b/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))))))) diff --git a/src/code/serve-event.lisp b/src/code/serve-event.lisp index ed5c8dba4..af166658e 100644 --- a/src/code/serve-event.lisp +++ b/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. diff --git a/src/code/target-thread.lisp b/src/code/target-thread.lisp index accc71e5e..38549a3d5 100644 --- a/src/code/target-thread.lisp +++ b/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) diff --git a/tests/deadline.impure.lisp b/tests/deadline.impure.lisp index 9d0b4f979..5d24ec9ad 100644 --- a/tests/deadline.impure.lisp +++ b/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 diff --git a/version.lisp-expr b/version.lisp-expr index aaf8ffa0e..dffce3226 100644 --- a/version.lisp-expr +++ b/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" -- 2.11.4.GIT