src/code/deadline.lisp

   1 ;;;; global deadlines for blocking functions: a threadsafe alternative
   2 ;;;; to asynch timeouts
   3
   4 ;;;; This software is part of the SBCL system. See the README file for
   5 ;;;; more information.
   6 ;;;;
   7 ;;;; This software is derived from the CMU CL system, which was
   8 ;;;; written at Carnegie Mellon University and released into the
   9 ;;;; public domain. The software is in the public domain and is
  10 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
  11 ;;;; files for more information.
  12
  13 (in-package "SB!IMPL")
  14
  15 (!begin-collecting-cold-init-forms)
  16
  17 ;;; Current deadline as internal time units or NIL.
  18 (declaim (type (or unsigned-byte null) *deadline*))
  19 (defvar *deadline*)
  20 (!cold-init-forms (setq *deadline* nil))
  21
  22 ;;; The relative number of seconds the current deadline corresponds
  23 ;;; to. Used for continuing from TIMEOUT conditions.
  24 (defvar *deadline-seconds*)
  25 (!cold-init-forms (setq *deadline-seconds* nil))
  26
  27 (declaim (inline seconds-to-internal-time))
  28 (defun seconds-to-internal-time (seconds)
  29   (truncate (* seconds sb!xc:internal-time-units-per-second)))
  30
  31 (defmacro with-deadline ((&key seconds override)
  32                          &body body)
  33   "Arranges for a TIMEOUT condition to be signalled if an operation
  34 respecting deadlines occurs either after the deadline has passed, or
  35 would take longer than the time left to complete.
  36
  37 Currently only blocking IO operations, GET-MUTEX, and CONDITION-WAIT
  38 respect deadlines, but this includes their implicit uses inside SBCL
  39 itself.
  40
  41 Unless OVERRIDE is true, existing deadlines can only be restricted,
  42 not extended. Deadlines are per thread: children are unaffected by
  43 their parent's deadlines.
  44
  45 Experimental."
  46   (with-unique-names (deadline-seconds deadline)
  47     ;; We're operating on a millisecond precision, so a single-float
  48     ;; is enough, and is an immediate on 64bit platforms.
  49     `(let* ((,deadline-seconds (coerce ,seconds 'single-float))
  50             (,deadline
  51              (+ (seconds-to-internal-time ,deadline-seconds)
  52                 (get-internal-real-time))))
  53        (multiple-value-bind (*deadline* *deadline-seconds*)
  54            (if ,override
  55                (values ,deadline ,deadline-seconds)
  56                (let ((old *deadline*))
  57                  (if (and old (< old ,deadline))
  58                      (values old *deadline-seconds*)
  59                      (values ,deadline ,deadline-seconds))))
  60          ,@body))))
  61
  62 (declaim (inline decode-internal-time))
  63 (defun decode-internal-time (time)
  64   #!+sb-doc
  65   "Returns internal time value TIME decoded into seconds and microseconds."
  66   (multiple-value-bind (sec frac)
  67       (truncate time sb!xc:internal-time-units-per-second)
  68     (values sec (* frac sb!unix::micro-seconds-per-internal-time-unit))))
  69
  70 (defun signal-timeout (datum &rest arguments)
  71   #!+sb-doc
  72   "Signals a timeout condition while inhibiting further timeouts due to
  73 deadlines while the condition is being handled."
  74   ;; FIXME: Maybe we should make ERROR do WITH-INTERRUPTS instead of
  75   ;; putting it all over the place (now that we have ALLOW-WITH-INTERRUPTS.)
  76   (with-interrupts
  77     ;; Don't signal a deadline while handling a non-deadline timeout.
  78     (let ((*deadline* nil))
  79       (apply #'error datum arguments))))
  80
  81 (defun signal-deadline ()
  82   #!+sb-doc
  83   "Signal a DEADLINE-TIMEOUT condition, and associate a DEFER-DEADLINE
  84 restart with it. Implementors of blocking functions are responsible
  85 for calling this when a deadline is reached."
  86   ;; Make sure we don't signal the same deadline twice. LET is not good
  87   ;; enough: we might catch the same deadline again while unwinding.
  88   (when *deadline*
  89     (setf *deadline* nil))
  90   (with-interrupts
  91     (restart-case
  92         (error 'deadline-timeout :seconds *deadline-seconds*)
  93       (defer-deadline (&optional (seconds *deadline-seconds*))
  94         :report "Defer the deadline for SECONDS more."
  95         :interactive (lambda ()
  96                        (sb!int:read-evaluated-form
  97                         "By how many seconds shall the deadline ~
  98                          be deferred?: "))
  99         (let* ((new-deadline-seconds (coerce seconds 'single-float))
 100                (new-deadline (+ (seconds-to-internal-time new-deadline-seconds)
 101                                 (get-internal-real-time))))
 102           (setf *deadline* new-deadline
 103                 *deadline-seconds* new-deadline-seconds)))
 104       (cancel-deadline ()
 105         :report "Cancel the deadline and continue."
 106         (setf *deadline* nil *deadline-seconds* nil))))
 107   nil)
 108
 109 (defun defer-deadline (seconds &optional condition)
 110   "Find the DEFER-DEADLINE restart associated with CONDITION, and
 111 invoke it with SECONDS as argument (deferring the deadline by that many
 112 seconds.) Otherwise return NIL if the restart is not found."
 113   (try-restart 'defer-deadline condition seconds))
 114
 115 (defun cancel-deadline (&optional condition)
 116   "Find and invoke the CANCEL-DEADLINE restart associated with
 117 CONDITION, or return NIL if the restart is not found."
 118   (try-restart 'cancel-deadline condition))
 119
 120 (declaim (inline relative-decoded-times))
 121 (defun relative-decoded-times (abs-sec abs-usec)
 122   #!+sb-doc
 123   "Returns relative decoded times: difference between SEC and USEC and
 124 current real time."
 125   (multiple-value-bind (now-sec now-usec)
 126       (decode-internal-time (get-internal-real-time))
 127     (let ((rel-sec (- abs-sec now-sec)))
 128       (cond ((> now-usec abs-usec)
 129              (values (max 0 (1- rel-sec))
 130                      (- (+ abs-usec 1000000) now-usec)))
 131             (t
 132              (values (max 0 rel-sec)
 133                      (- abs-usec now-usec)))))))
 134
 135 ;;; Returns TIMEOUT-SEC, TIMEOUT-USEC, DEADLINE-SEC, DEADLINE-USEC, SIGNALP
 136 ;;;
 137 ;;; Takes *DEADLINE* into account: if it occurs before given SECONDS,
 138 ;;; the values are based on it, and DEADLINEP is true -- and the
 139 ;;; receipent of the values should call SIGNAL-TIMEOUT if the decoded
 140 ;;; timeout is reached.
 141 ;;;
 142 ;;; If SECONDS is NIL and there is no *DEADLINE* all returned values
 143 ;;; are NIL.
 144 (defun decode-timeout (seconds)
 145   #!+sb-doc
 146   "Decodes a relative timeout in SECONDS into five values, taking any
 147 global deadlines into account: TO-SEC, TO-USEC, STOP-SEC, STOP-USEC,
 148 DEADLINEP.
 149
 150 TO-SEC and TO-USEC indicate the relative timeout in seconds and microsconds.
 151 STOP-SEC and STOP-USEC indicate the absolute timeout in seconds and
 152 microseconds. DEADLINEP is true if the returned values reflect a global
 153 deadline instead of the local timeout indicated by SECONDS.
 154
 155 If SECONDS is null and there is no global timeout all returned values will be
 156 null. If a global deadline has already passed when DECODE-TIMEOUT is called,
 157 it will signal a timeout condition."
 158   (tagbody
 159    :restart
 160      (let* ((timeout (when seconds (seconds-to-internal-time seconds)))
 161             (now (get-internal-real-time))
 162             (deadline *deadline*)
 163             (deadline-timeout
 164              (when deadline
 165                (let ((time-left (- deadline now)))
 166                  (if (plusp time-left)
 167                      time-left
 168                      (progn
 169                        (signal-deadline)
 170                        (go :restart)))))))
 171        (return-from decode-timeout
 172          (multiple-value-bind (final-timeout final-deadline signalp)
 173              ;; Use either *DEADLINE* or TIMEOUT to produce both a timeout
 174              ;; and deadline in internal-time units
 175              (cond ((and deadline timeout)
 176                     (if (< timeout deadline-timeout)
 177                         (values timeout (+ timeout now) nil)
 178                         (values deadline-timeout deadline t)))
 179                    (deadline
 180                     (values deadline-timeout deadline t))
 181                    (timeout
 182                     (values timeout (+ timeout now) nil))
 183                    (t
 184                     (values nil nil nil)))
 185            (if final-timeout
 186                (multiple-value-bind (to-sec to-usec)
 187                    (decode-internal-time final-timeout)
 188                  (multiple-value-bind (stop-sec stop-usec)
 189                      (decode-internal-time final-deadline)
 190                    (values (max 0 to-sec) (max 0 to-usec) stop-sec stop-usec signalp)))
 191                (values nil nil nil nil nil)))))))
 192
 193 (!defun-from-collected-cold-init-forms !deadline-cold-init)