X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fdeadline.lisp;h=43b4fc9e51ada0f778a494f89a15f93def014c7d;hb=6caf3ed5713773cb423f46bf40a29f2438c97c78;hp=757e4d9752fd8c6c8a6a98a3f92a41f26740f52f;hpb=c548f73e8dd676d6ec4576eba6ab661a5061bdfe;p=sbcl.git diff --git a/src/code/deadline.lisp b/src/code/deadline.lisp index 757e4d9..43b4fc9 100644 --- a/src/code/deadline.lisp +++ b/src/code/deadline.lisp @@ -12,13 +12,17 @@ (in-package "SB!IMPL") +(!begin-collecting-cold-init-forms) + ;;; Current deadline as internal time units or NIL. -(defvar *deadline* nil) (declaim (type (or unsigned-byte null) *deadline*)) +(defvar *deadline*) +(!cold-init-forms (setq *deadline* nil)) ;;; The relative number of seconds the current deadline corresponds ;;; to. Used for continuing from TIMEOUT conditions. -(defvar *deadline-seconds* nil) +(defvar *deadline-seconds*) +(!cold-init-forms (setq *deadline-seconds* nil)) (declaim (inline seconds-to-internal-time)) (defun seconds-to-internal-time (seconds) @@ -26,12 +30,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) @@ -65,14 +74,48 @@ deadlines while the condition is being handled." ;; FIXME: Maybe we should make ERROR do WITH-INTERRUPTS instead of ;; putting it all over the place (now that we have ALLOW-WITH-INTERRUPTS.) (with-interrupts + ;; Don't signal a deadline while handling a non-deadline timeout. (let ((*deadline* nil)) (apply #'error datum arguments)))) (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-timeout 'deadline-timeout :seconds *deadline-seconds*)) + "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)) + (with-interrupts + (restart-case + (error 'deadline-timeout :seconds *deadline-seconds*) + (defer-deadline (&optional (seconds *deadline-seconds*)) + :report "Defer the deadline for SECONDS more." + :interactive (lambda () + (sb!int:read-evaluated-form + "By how many seconds shall the deadline ~ + be deferred?: ")) + (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))) + (cancel-deadline () + :report "Cancel the deadline and continue." + (setf *deadline* nil *deadline-seconds* nil)))) + nil) + +(defun defer-deadline (seconds &optional condition) + "Find the DEFER-DEADLINE restart associated with CONDITION, and +invoke it with SECONDS as argument (deferring the deadline by that many +seconds.) Otherwise return NIL if the restart is not found." + (try-restart 'defer-deadline condition seconds)) + +(defun cancel-deadline (&optional condition) + "Find and invoke the CANCEL-DEADLINE restart associated with +CONDITION, or return NIL if the restart is not found." + (try-restart 'cancel-deadline condition)) ;;; Returns TIMEOUT-SEC, TIMEOUT-USEC, DEADLINE-SEC, DEADLINE-USEC, SIGNALP ;;; @@ -97,32 +140,39 @@ 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))))))) + +(!defun-from-collected-cold-init-forms !deadline-cold-init)