1.0.21.14: fix CHECK-FASL-HEADER buglet
[sbcl.git] / 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
30 respecting deadlines occurs either after the deadline has passed, or
31 would take longer than the time left to complete.
32
33 Currently only blocking IO operations, GET-MUTEX, and CONDITION-WAIT
34 respect deadlines, but this includes their implicit uses inside SBCL
35 itself.
36
37 Unless OVERRIDE is true, existing deadlines can only be restricted,
38 not extended. Deadlines are per thread: children are unaffected by
39 their parent's deadlines.
40
41 Experimental."
42   (with-unique-names (deadline-seconds deadline)
43     ;; We're operating on a millisecond precision, so a single-float
44     ;; is enough, and is an immediate on 64bit platforms.
45     `(let* ((,deadline-seconds (coerce ,seconds 'single-float))
46             (,deadline
47              (+ (seconds-to-internal-time ,deadline-seconds)
48                 (get-internal-real-time))))
49        (multiple-value-bind (*deadline* *deadline-seconds*)
50            (if ,override
51                (values ,deadline ,deadline-seconds)
52                (let ((old *deadline*))
53                  (if (and old (< old ,deadline))
54                      (values old *deadline-seconds*)
55                      (values ,deadline ,deadline-seconds))))
56          ,@body))))
57
58 (declaim (inline decode-internal-time))
59 (defun decode-internal-time (time)
60   #!+sb-doc
61   "Returns internal time value TIME decoded into seconds and microseconds."
62   (multiple-value-bind (sec frac)
63       (truncate time sb!xc:internal-time-units-per-second)
64     (values sec (* frac sb!unix::micro-seconds-per-internal-time-unit))))
65
66 (defun signal-timeout (datum &rest arguments)
67   #!+sb-doc
68   "Signals a timeout condition while inhibiting further timeouts due to
69 deadlines while the condition is being handled."
70   ;; FIXME: Maybe we should make ERROR do WITH-INTERRUPTS instead of
71   ;; putting it all over the place (now that we have ALLOW-WITH-INTERRUPTS.)
72   (with-interrupts
73     ;; Don't signal a deadline while handling a non-deadline timeout.
74     (let ((*deadline* nil))
75       (apply #'error datum arguments))))
76
77 (defun signal-deadline ()
78   #!+sb-doc
79   "Signal a DEADLINE-TIMEOUT condition, and associate a DEFER-DEADLINE
80 restart with it. Implementors of blocking functions are responsible
81 for calling this when a deadline is reached."
82   ;; Make sure we don't signal the same deadline twice. LET is not good
83   ;; enough: we might catch the same deadline again while unwinding.
84   (when *deadline*
85     (setf *deadline* nil))
86   (with-interrupts
87     (restart-case
88         (error 'deadline-timeout :seconds *deadline-seconds*)
89       (defer-deadline (&optional (seconds *deadline-seconds*))
90         :report "Defer the deadline for SECONDS more."
91         (let* ((new-deadline-seconds (coerce seconds 'single-float))
92                (new-deadline (+ (seconds-to-internal-time new-deadline-seconds)
93                                 (get-internal-real-time))))
94           (setf *deadline* new-deadline
95                 *deadline-seconds* new-deadline-seconds)))))
96   nil)
97
98 (defun defer-deadline (seconds &optional condition)
99   "Find the DEFER-DEADLINE restart associated with CONDITION, and
100 calls it with SECONDS as argument (deferring the deadline by that many
101 seconds.) Continues from the indicated restart, or returns NIL if the
102 restart is not found."
103   (try-restart 'defer-deadline condition seconds))
104
105 ;;; Returns TIMEOUT-SEC, TIMEOUT-USEC, DEADLINE-SEC, DEADLINE-USEC, SIGNALP
106 ;;;
107 ;;; Takes *DEADLINE* into account: if it occurs before given SECONDS,
108 ;;; the values are based on it, and DEADLINEP is true -- and the
109 ;;; receipent of the values should call SIGNAL-TIMEOUT if the decoded
110 ;;; timeout is reached.
111 ;;;
112 ;;; If SECONDS is NIL and there is no *DEADLINE* all returned values
113 ;;; are NIL.
114 (defun decode-timeout (seconds)
115   #!+sb-doc
116   "Decodes a relative timeout in SECONDS into five values, taking any
117 global deadlines into account: TO-SEC, TO-USEC, STOP-SEC, STOP-USEC,
118 DEADLINEP.
119
120 TO-SEC and TO-USEC indicate the relative timeout in seconds and microsconds.
121 STOP-SEC and STOP-USEC indicate the absolute timeout in seconds and
122 microseconds. DEADLINEP is true if the returned values reflect a global
123 deadline instead of the local timeout indicated by SECONDS.
124
125 If SECONDS is null and there is no global timeout all returned values will be
126 null. If a global deadline has already passed when DECODE-TIMEOUT is called,
127 it will signal a timeout condition."
128   (tagbody
129    :restart
130      (let* ((timeout (when seconds (seconds-to-internal-time seconds)))
131             (now (get-internal-real-time))
132             (deadline *deadline*)
133             (deadline-timeout
134              (when deadline
135                (let ((time-left (- deadline now)))
136                  (if (plusp time-left)
137                      time-left
138                      (progn
139                        (signal-deadline)
140                        (go :restart)))))))
141        (return-from decode-timeout
142          (multiple-value-bind (final-timeout final-deadline signalp)
143              ;; Use either *DEADLINE* or TIMEOUT to produce both a timeout
144              ;; and deadline in internal-time units
145              (cond ((and deadline timeout)
146                     (if (< timeout deadline-timeout)
147                         (values timeout (+ timeout now) nil)
148                         (values deadline-timeout deadline t)))
149                    (deadline
150                     (values deadline-timeout deadline t))
151                    (timeout
152                     (values timeout (+ timeout now) nil))
153                    (t
154                     (values nil nil nil)))
155            (if final-timeout
156                (multiple-value-bind (to-sec to-usec)
157                    (decode-internal-time final-timeout)
158                  (multiple-value-bind (stop-sec stop-usec)
159                      (decode-internal-time final-deadline)
160                    (values to-sec to-usec stop-sec stop-usec signalp)))
161                (values nil nil nil nil nil)))))))
162