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 (defvar *deadline* nil)
  17 (declaim (type (or unsigned-byte null) *deadline*))
  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   "Arranges for a TIMEOUT condition to be signalled if an operation respecting
  30 deadlines occurs either after the deadline has passed, or would take longer
  31 than the time left to complete.
  32
  33 Currently only blocking IO operations, GET-MUTEX, and CONDITION-WAIT respect
  34 deadlines, but this includes their implicit uses inside SBCL itself.
  35
  36 Experimental."
  37   (with-unique-names (deadline-seconds deadline)
  38     ;; We're operating on a millisecond precision, so a single-float
  39     ;; is enough, and is an immediate on 64bit platforms.
  40     `(let* ((,deadline-seconds (coerce ,seconds 'single-float))
  41             (,deadline
  42              (+ (seconds-to-internal-time ,deadline-seconds)
  43                 (get-internal-real-time))))
  44        (multiple-value-bind (*deadline* *deadline-seconds*)
  45            (if ,override
  46                (values ,deadline ,deadline-seconds)
  47                (let ((old *deadline*))
  48                  (if (and old (< old ,deadline))
  49                      (values old *deadline-seconds*)
  50                      (values ,deadline ,deadline-seconds))))
  51          ,@body))))
  52
  53 (declaim (inline decode-internal-time))
  54 (defun decode-internal-time (time)
  55   #!+sb-doc
  56   "Returns internal time value TIME decoded into seconds and microseconds."
  57   (multiple-value-bind (sec frac)
  58       (truncate time sb!xc:internal-time-units-per-second)
  59     (values sec (* frac sb!unix::micro-seconds-per-internal-time-unit))))
  60
  61 (defun signal-timeout (datum &rest arguments)
  62   #!+sb-doc
  63   "Signals a timeout condition while inhibiting further timeouts due to
  64 deadlines while the condition is being handled."
  65   ;; FIXME: Maybe we should make ERROR do WITH-INTERRUPTS instead of
  66   ;; putting it all over the place (now that we have ALLOW-WITH-INTERRUPTS.)
  67   (with-interrupts
  68     (let ((*deadline* nil))
  69       (apply #'error datum arguments))))
  70
  71 (defun signal-deadline ()
  72   #!+sb-doc
  73   "Signal a DEADLINE-TIMEOUT condition. Implementors of blocking functions
  74 are responsible for calling this when a deadline is reached."
  75   (signal-timeout 'deadline-timeout :seconds *deadline-seconds*))
  76
  77 ;;; Returns TIMEOUT-SEC, TIMEOUT-USEC, DEADLINE-SEC, DEADLINE-USEC, SIGNALP
  78 ;;;
  79 ;;; Takes *DEADLINE* into account: if it occurs before given SECONDS,
  80 ;;; the values are based on it, and DEADLINEP is true -- and the
  81 ;;; receipent of the values should call SIGNAL-TIMEOUT if the decoded
  82 ;;; timeout is reached.
  83 ;;;
  84 ;;; If SECONDS is NIL and there is no *DEADLINE* all returned values
  85 ;;; are NIL.
  86 (defun decode-timeout (seconds)
  87   #!+sb-doc
  88   "Decodes a relative timeout in SECONDS into five values, taking any
  89 global deadlines into account: TO-SEC, TO-USEC, STOP-SEC, STOP-USEC,
  90 DEADLINEP.
  91
  92 TO-SEC and TO-USEC indicate the relative timeout in seconds and microsconds.
  93 STOP-SEC and STOP-USEC indicate the absolute timeout in seconds and
  94 microseconds. DEADLINEP is true if the returned values reflect a global
  95 deadline instead of the local timeout indicated by SECONDS.
  96
  97 If SECONDS is null and there is no global timeout all returned values will be
  98 null. If a global deadline has already passed when DECODE-TIMEOUT is called,
  99 it will signal a timeout condition."
 100   (let* ((timeout (when seconds (seconds-to-internal-time seconds)))
 101          (now (get-internal-real-time))
 102          (deadline *deadline*)
 103          (deadline-timeout
 104           (when deadline
 105             (let ((time-left (- deadline now)))
 106               (if (plusp time-left)
 107                   time-left
 108                   (signal-deadline))))))
 109     (multiple-value-bind (final-timeout final-deadline signalp)
 110         ;; Use either *DEADLINE* or TIMEOUT to produce both a timeout
 111         ;; and deadline in internal-time units
 112         (cond ((and deadline timeout)
 113                (if (< timeout deadline-timeout)
 114                    (values timeout (+ timeout now) nil)
 115                    (values deadline-timeout deadline t)))
 116               (deadline
 117                (values deadline-timeout deadline t))
 118               (timeout
 119                (values timeout (+ timeout now) nil))
 120               (t
 121                (values nil nil nil)))
 122       (if final-timeout
 123           (multiple-value-bind (to-sec to-usec)
 124               (decode-internal-time final-timeout)
 125             (multiple-value-bind (stop-sec stop-usec)
 126                 (decode-internal-time final-deadline)
 127               (values to-sec to-usec stop-sec stop-usec signalp)))
 128           (values nil nil nil nil nil)))))