1 ;;;; a timer facility based heavily on the timer package by Zach Beane
3 ;;;; This software is part of the SBCL system. See the README file for
6 ;;;; This software is derived from the CMU CL system, which was
7 ;;;; written at Carnegie Mellon University and released into the
8 ;;;; public domain. The software is in the public domain and is
9 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
10 ;;;; files for more information.
12 (in-package "SB!IMPL")
14 ;;; Heap (for the priority queue)
16 (declaim (inline heap-parent heap-left heap-right))
18 (defun heap-parent (i)
27 (defun heapify (heap start &key (key #'identity) (test #'>=))
28 (declare (function key test))
29 (flet ((key (obj) (funcall key obj))
30 (ge (i j) (funcall test i j)))
31 (let ((l (heap-left start))
32 (r (heap-right start))
35 (setf largest (if (and (< l size)
36 (not (ge (key (aref heap start))
37 (key (aref heap l)))))
41 (not (ge (key (aref heap largest))
42 (key (aref heap r)))))
44 (when (/= largest start)
45 (rotatef (aref heap largest) (aref heap start))
46 (heapify heap largest :key key :test test)))
49 (defun heap-insert (heap new-item &key (key #'identity) (test #'>=))
50 (declare (function key test))
51 (flet ((key (obj) (funcall key obj))
52 (ge (i j) (funcall test i j)))
53 (vector-push-extend nil heap)
54 (loop for i = (1- (length heap)) then parent-i
55 for parent-i = (heap-parent i)
57 (not (ge (key (aref heap parent-i))
59 do (setf (aref heap i) (aref heap parent-i))
60 finally (setf (aref heap i) new-item)
61 (return-from heap-insert i))))
63 (defun heap-maximum (heap)
64 (unless (zerop (length heap))
67 (defun heap-extract (heap i &key (key #'identity) (test #'>=))
68 (unless (> (length heap) i)
69 (error "Heap underflow"))
72 (setf (aref heap i) (aref heap (1- (length heap))))
73 (decf (fill-pointer heap))
74 (heapify heap i :key key :test test)))
76 (defun heap-extract-maximum (heap &key (key #'identity) (test #'>=))
77 (heap-extract heap 0 :key key :test test))
81 (defstruct (priority-queue
83 (:constructor %make-priority-queue))
87 (defun make-priority-queue (&key (key #'identity) (element-type t))
88 (let ((contents (make-array 100
91 :element-type element-type)))
92 (%make-priority-queue :keyfun key
95 (def!method print-object ((object priority-queue) stream)
96 (print-unreadable-object (object stream :type t :identity t)
97 (format stream "~[empty~:;~:*~D item~:P~]"
98 (length (%pqueue-contents object)))))
100 (defun priority-queue-maximum (priority-queue)
101 "Return the item in PRIORITY-QUEUE with the largest key."
102 (symbol-macrolet ((contents (%pqueue-contents priority-queue)))
103 (unless (zerop (length contents))
104 (heap-maximum contents))))
106 (defun priority-queue-extract-maximum (priority-queue)
107 "Remove and return the item in PRIORITY-QUEUE with the largest key."
108 (symbol-macrolet ((contents (%pqueue-contents priority-queue))
109 (keyfun (%pqueue-keyfun priority-queue)))
110 (unless (zerop (length contents))
111 (heap-extract-maximum contents :key keyfun :test #'<=))))
113 (defun priority-queue-insert (priority-queue new-item)
114 "Add NEW-ITEM to PRIOIRITY-QUEUE."
115 (symbol-macrolet ((contents (%pqueue-contents priority-queue))
116 (keyfun (%pqueue-keyfun priority-queue)))
117 (heap-insert contents new-item :key keyfun :test #'<=)))
119 (defun priority-queue-empty-p (priority-queue)
120 (zerop (length (%pqueue-contents priority-queue))))
122 (defun priority-queue-remove (priority-queue item &key (test #'eq))
123 "Remove and return ITEM from PRIORITY-QUEUE."
124 (symbol-macrolet ((contents (%pqueue-contents priority-queue))
125 (keyfun (%pqueue-keyfun priority-queue)))
126 (let ((i (position item contents :test test)))
128 (heap-extract contents i :key keyfun :test #'<=)
133 (defun make-cancellable-interruptor (function)
134 ;; return a list of two functions: one that does the same as
135 ;; FUNCTION until the other is called, from when it does nothing.
136 (let ((mutex (sb!thread:make-mutex))
140 (sb!thread:with-recursive-lock (mutex)
142 (funcall function))))
144 (sb!thread:with-recursive-lock (mutex)
145 (setq cancelled-p t))))))
151 (:constructor %make-timer))
153 "Timer type. Do not rely on timers being structs as it may change in
159 (thread nil :type (or sb!thread:thread (member t nil)))
163 (def!method print-object ((timer timer) stream)
164 (let ((name (%timer-name timer)))
166 (print-unreadable-object (timer stream :type t :identity t)
168 (print-unreadable-object (timer stream :type t :identity t)
169 ;; body is empty => there is only one space between type and
173 (defun make-timer (function &key name (thread sb!thread:*current-thread*))
175 "Create a timer object that's when scheduled runs FUNCTION. If
176 THREAD is a thread then that thread is to be interrupted with
177 FUNCTION. If THREAD is T then a new thread is created each timer
178 FUNCTION is run. If THREAD is NIL then FUNCTION can be run in any
180 (%make-timer :name name :function function :thread thread))
182 (defun timer-name (timer)
184 "Return the name of TIMER."
187 (defun timer-scheduled-p (timer &key (delta 0))
189 "See if TIMER will still need to be triggered after DELTA seconds
190 from now. For timers with a repeat interval it returns true."
191 (symbol-macrolet ((expire-time (%timer-expire-time timer))
192 (repeat-interval (%timer-repeat-interval timer)))
193 (or (and repeat-interval (plusp repeat-interval))
195 (<= (+ (get-internal-real-time) delta)
200 (defvar *scheduler-lock* (sb!thread:make-mutex :name "Scheduler lock"))
202 (defmacro with-scheduler-lock ((&optional) &body body)
203 ;; Don't let the SIGALRM handler mess things up.
204 `(sb!thread::with-system-mutex (*scheduler-lock*)
207 (defun under-scheduler-lock-p ()
208 (sb!thread:holding-mutex-p *scheduler-lock*))
210 (defparameter *schedule* (make-priority-queue :key #'%timer-expire-time))
212 (defun peek-schedule ()
213 (priority-queue-maximum *schedule*))
215 (defun time-left (timer)
216 (- (%timer-expire-time timer) (get-internal-real-time)))
218 ;;; real time conversion
220 (defun delta->real (delta)
221 (floor (* delta internal-time-units-per-second)))
225 (defun %schedule-timer (timer)
226 (let ((changed-p nil)
227 (old-position (priority-queue-remove *schedule* timer)))
228 ;; Make sure interruptors are cancelled even if this timer was
229 ;; scheduled again since our last attempt.
231 (funcall (%timer-cancel-function timer)))
232 (when (eql 0 old-position)
234 (when (zerop (priority-queue-insert *schedule* timer))
236 (setf (values (%timer-interrupt-function timer)
237 (%timer-cancel-function timer))
238 (values-list (make-cancellable-interruptor
239 (%timer-function timer))))
244 (defun schedule-timer (timer time &key repeat-interval absolute-p)
246 "Schedule TIMER to be triggered at TIME. If ABSOLUTE-P then TIME is
247 universal time, but non-integral values are also allowed, else TIME is
248 measured as the number of seconds from the current time. If
249 REPEAT-INTERVAL is given, TIMER is automatically rescheduled upon
251 ;; CANCEL-FUNCTION may block until all interruptors finish, let's
252 ;; try to cancel without the scheduler lock first.
253 (when (%timer-cancel-function timer)
254 (funcall (%timer-cancel-function timer)))
255 (with-scheduler-lock ()
256 (setf (%timer-expire-time timer) (+ (get-internal-real-time)
259 (- time (get-universal-time))
261 (%timer-repeat-interval timer) (if repeat-interval
262 (delta->real repeat-interval)
264 (%schedule-timer timer)))
266 (defun unschedule-timer (timer)
268 "Cancel TIMER. Once this function returns it is guaranteed that
269 TIMER shall not be triggered again and there are no unfinished
271 (let ((cancel-function (%timer-cancel-function timer)))
272 (when cancel-function
273 (funcall cancel-function)))
274 (with-scheduler-lock ()
275 (setf (%timer-expire-time timer) nil
276 (%timer-repeat-interval timer) nil)
277 (let ((old-position (priority-queue-remove *schedule* timer)))
279 (funcall (%timer-cancel-function timer)))
280 (when (eql 0 old-position)
281 (set-system-timer))))
284 (defun list-all-timers ()
286 "Return a list of all timers in the system."
287 (with-scheduler-lock ()
288 (concatenate 'list (%pqueue-contents *schedule*))))
290 ;;; Not public, but related
292 (defun reschedule-timer (timer)
293 (let ((thread (%timer-thread timer)))
294 (if (and (sb!thread::thread-p thread) (not (sb!thread:thread-alive-p thread)))
295 (unschedule-timer timer)
296 (with-scheduler-lock ()
297 (setf (%timer-expire-time timer) (+ (get-internal-real-time)
298 (%timer-repeat-interval timer)))
299 (%schedule-timer timer)))))
303 (defun real-time->sec-and-usec(time)
306 (multiple-value-bind (s u) (floor time internal-time-units-per-second)
307 (setf u (floor (* (/ u internal-time-units-per-second) 1000000)))
309 ;; 0 0 means "shut down the timer" for setitimer
313 (defun set-system-timer ()
314 (assert (under-scheduler-lock-p))
315 (let ((next-timer (peek-schedule)))
317 (let ((delta (- (%timer-expire-time next-timer)
318 (get-internal-real-time))))
319 (apply #'sb!unix:unix-setitimer
320 :real 0 0 (real-time->sec-and-usec delta)))
321 (sb!unix:unix-setitimer :real 0 0 0 0))))
323 (defun run-timer (timer)
324 (symbol-macrolet ((function (%timer-function timer))
325 (repeat-interval (%timer-repeat-interval timer))
326 (thread (%timer-thread timer)))
327 (when repeat-interval
328 (reschedule-timer timer))
332 (sb!thread:make-thread function))
335 (sb!thread:interrupt-thread thread function)
336 (sb!thread:interrupt-thread-error (c)
338 (warn "Timer ~S failed to interrupt thread ~S."
341 ;; Called from the signal handler.
342 (defun run-expired-timers ()
347 (with-scheduler-lock ()
348 (setq timer (peek-schedule))
350 (> (get-internal-real-time)
351 (%timer-expire-time timer)))
352 (return-from run-expired-timers nil))
353 (assert (eq timer (priority-queue-extract-maximum *schedule*))))
354 ;; run the timer without the lock
356 (with-scheduler-lock ()
357 (set-system-timer))))
359 (defmacro sb!ext:with-timeout (expires &body body)
361 "Execute the body, asynchronously interrupting it and signalling a TIMEOUT
362 condition after at least EXPIRES seconds have passed.
364 Note that it is never safe to unwind from an asynchronous condition. Consider:
366 (defun call-with-foo (function)
371 (funcall function foo))
373 (release-foo foo)))))
375 If TIMEOUT occurs after GET-FOO has executed, but before the assignment, then
376 RELEASE-FOO will be missed. While individual sites like this can be made proof
377 against asynchronous unwinds, this doesn't solve the fundamental issue, as all
378 the frames potentially unwound through need to be proofed, which includes both
379 system and application code -- and in essence proofing everything will make
380 the system uninterruptible."
381 (with-unique-names (timer)
382 ;; FIXME: a temporary compatibility workaround for CLX, if unsafe
383 ;; unwinds are handled revisit it.
385 (let ((,timer (make-timer (lambda ()
386 (cerror "Continue" 'sb!ext::timeout)))))
387 (schedule-timer ,timer ,expires)
390 (unschedule-timer ,timer)))