(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)
(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))))
#!+sb-doc
"Signals a timeout condition while inhibiting further timeouts due to
deadlines while the condition is being handled."
- (let ((*deadline* nil))
- (apply #'error datum arguments)))
+ ;; 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))
+
+(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
;;;
global deadlines into account: TO-SEC, TO-USEC, STOP-SEC, STOP-USEC,
DEADLINEP.
-TO-SEC and TO-USEC indicate the relative timeout in seconds and microsconds.
+TO-SEC and TO-USEC indicate the relative timeout in seconds and microseconds.
STOP-SEC and STOP-USEC indicate the absolute timeout in seconds and
microseconds. DEADLINEP is true if the returned values reflect a global
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)
projects / sbcl.git / blobdiff