X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fdeadline.lisp;h=d2577dc255735168f356e6156413fbf834a8a4fe;hb=cd1b14acf6f548b28b8a14e554d779f0473122ec;hp=4ea6e72df23bfe0da9a79d775abb2b47d86bd3e4;hpb=6e953f60d904a015b3273db84b5886b04a9ecb1c;p=sbcl.git diff --git a/src/code/deadline.lisp b/src/code/deadline.lisp index 4ea6e72..d2577dc 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,26 +30,35 @@ (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) + (with-unique-names (tmp deadline-seconds deadline) ;; We're operating on a millisecond precision, so a single-float ;; is enough, and is an immediate on 64bit platforms. - `(let* ((,deadline-seconds (coerce ,seconds 'single-float)) + `(let* ((,tmp ,seconds) + (,deadline-seconds + (when ,tmp + (coerce ,tmp 'single-float))) (,deadline - (+ (seconds-to-internal-time ,deadline-seconds) - (get-internal-real-time)))) + (when ,deadline-seconds + (+ (seconds-to-internal-time ,deadline-seconds) + (get-internal-real-time))))) (multiple-value-bind (*deadline* *deadline-seconds*) (if ,override (values ,deadline ,deadline-seconds) (let ((old *deadline*)) - (if (and old (< old ,deadline)) + (if (and old (or (not ,deadline) (< old ,deadline))) (values old *deadline-seconds*) (values ,deadline ,deadline-seconds)))) ,@body)))) @@ -71,13 +84,57 @@ 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." + :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)) + +(declaim (inline relative-decoded-times)) +(defun relative-decoded-times (abs-sec abs-usec) + #!+sb-doc + "Returns relative decoded times: difference between SEC and USEC and +current real time." + (multiple-value-bind (now-sec now-usec) + (decode-internal-time (get-internal-real-time)) + (let ((rel-sec (- abs-sec now-sec))) + (cond ((> now-usec abs-usec) + (values (max 0 (1- rel-sec)) + (- (+ abs-usec 1000000) now-usec))) + (t + (values (max 0 rel-sec) + (- abs-usec now-usec))))))) ;;; Returns TIMEOUT-SEC, TIMEOUT-USEC, DEADLINE-SEC, DEADLINE-USEC, SIGNALP ;;; @@ -102,32 +159,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 (max 0 to-sec) (max 0 to-usec) stop-sec stop-usec signalp))) + (values nil nil nil nil nil))))))) + +(!defun-from-collected-cold-init-forms !deadline-cold-init)