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